1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 /* General assumptions:
25 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
26 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
27 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
28 * XXX What about infinities? They are equal to their own floor! -mhw
29 * All objects satisfying SCM_FRACTIONP are never an integer.
34 - see if special casing bignums and reals in integer-exponent when
35 possible (to use mpz_pow and mpf_pow_ui) is faster.
37 - look in to better short-circuiting of common cases in
38 integer-expt and elsewhere.
40 - see if direct mpz operations can help in ash and elsewhere.
59 #include "libguile/_scm.h"
60 #include "libguile/feature.h"
61 #include "libguile/ports.h"
62 #include "libguile/root.h"
63 #include "libguile/smob.h"
64 #include "libguile/strings.h"
65 #include "libguile/bdw-gc.h"
67 #include "libguile/validate.h"
68 #include "libguile/numbers.h"
69 #include "libguile/deprecation.h"
71 #include "libguile/eq.h"
73 /* GMP's `mpz_t' must fit into a double cell. */
74 verify (sizeof (mpz_t
) <= (2 * sizeof (scm_t_bits
)));
76 /* values per glibc, if not already defined */
78 #define M_LOG10E 0.43429448190325182765
81 #define M_LN2 0.69314718055994530942
84 #define M_PI 3.14159265358979323846
87 typedef scm_t_signed_bits scm_t_inum
;
88 #define scm_from_inum(x) (scm_from_signed_integer (x))
90 /* Tests to see if a C double is neither infinite nor a NaN.
91 TODO: if it's available, use C99's isfinite(x) instead */
92 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
94 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
95 of the infinity, but other platforms return a boolean only. */
96 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
97 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
102 Wonder if this might be faster for some of our code? A switch on
103 the numtag would jump directly to the right case, and the
104 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
106 #define SCM_I_NUMTAG_NOTNUM 0
107 #define SCM_I_NUMTAG_INUM 1
108 #define SCM_I_NUMTAG_BIG scm_tc16_big
109 #define SCM_I_NUMTAG_REAL scm_tc16_real
110 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
111 #define SCM_I_NUMTAG(x) \
112 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
113 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
114 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
115 : SCM_I_NUMTAG_NOTNUM)))
117 /* the macro above will not work as is with fractions */
121 static SCM exactly_one_half
;
122 static SCM flo_log10e
;
124 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
126 /* FLOBUFLEN is the maximum number of characters neccessary for the
127 * printed or scm_string representation of an inexact number.
129 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
132 #if !defined (HAVE_ASINH)
133 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
135 #if !defined (HAVE_ACOSH)
136 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
138 #if !defined (HAVE_ATANH)
139 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
142 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
143 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
144 in March 2006), mpz_cmp_d now handles infinities properly. */
146 #define xmpz_cmp_d(z, d) \
147 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
149 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
153 #if defined (GUILE_I)
154 #if defined HAVE_COMPLEX_DOUBLE
156 /* For an SCM object Z which is a complex number (ie. satisfies
157 SCM_COMPLEXP), return its value as a C level "complex double". */
158 #define SCM_COMPLEX_VALUE(z) \
159 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
161 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
163 /* Convert a C "complex double" to an SCM value. */
165 scm_from_complex_double (complex double z
)
167 return scm_c_make_rectangular (creal (z
), cimag (z
));
170 #endif /* HAVE_COMPLEX_DOUBLE */
175 static mpz_t z_negative_one
;
178 /* Clear the `mpz_t' embedded in bignum PTR. */
180 finalize_bignum (GC_PTR ptr
, GC_PTR data
)
184 bignum
= PTR2SCM (ptr
);
185 mpz_clear (SCM_I_BIG_MPZ (bignum
));
188 /* Return a new uninitialized bignum. */
193 GC_finalization_proc prev_finalizer
;
194 GC_PTR prev_finalizer_data
;
196 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
197 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
201 GC_REGISTER_FINALIZER_NO_ORDER (p
, finalize_bignum
, NULL
,
203 &prev_finalizer_data
);
212 /* Return a newly created bignum. */
213 SCM z
= make_bignum ();
214 mpz_init (SCM_I_BIG_MPZ (z
));
219 scm_i_inum2big (scm_t_inum x
)
221 /* Return a newly created bignum initialized to X. */
222 SCM z
= make_bignum ();
223 #if SIZEOF_VOID_P == SIZEOF_LONG
224 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
226 /* Note that in this case, you'll also have to check all mpz_*_ui and
227 mpz_*_si invocations in Guile. */
228 #error creation of mpz not implemented for this inum size
234 scm_i_long2big (long x
)
236 /* Return a newly created bignum initialized to X. */
237 SCM z
= make_bignum ();
238 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
243 scm_i_ulong2big (unsigned long x
)
245 /* Return a newly created bignum initialized to X. */
246 SCM z
= make_bignum ();
247 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
252 scm_i_clonebig (SCM src_big
, int same_sign_p
)
254 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
255 SCM z
= make_bignum ();
256 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
258 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
263 scm_i_bigcmp (SCM x
, SCM y
)
265 /* Return neg if x < y, pos if x > y, and 0 if x == y */
266 /* presume we already know x and y are bignums */
267 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
268 scm_remember_upto_here_2 (x
, y
);
273 scm_i_dbl2big (double d
)
275 /* results are only defined if d is an integer */
276 SCM z
= make_bignum ();
277 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
281 /* Convert a integer in double representation to a SCM number. */
284 scm_i_dbl2num (double u
)
286 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
287 powers of 2, so there's no rounding when making "double" values
288 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
289 get rounded on a 64-bit machine, hence the "+1".
291 The use of floor() to force to an integer value ensures we get a
292 "numerically closest" value without depending on how a
293 double->long cast or how mpz_set_d will round. For reference,
294 double->long probably follows the hardware rounding mode,
295 mpz_set_d truncates towards zero. */
297 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
298 representable as a double? */
300 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
301 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
302 return SCM_I_MAKINUM ((scm_t_inum
) u
);
304 return scm_i_dbl2big (u
);
307 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
308 with R5RS exact->inexact.
310 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
311 (ie. truncate towards zero), then adjust to get the closest double by
312 examining the next lower bit and adding 1 (to the absolute value) if
315 Bignums exactly half way between representable doubles are rounded to the
316 next higher absolute value (ie. away from zero). This seems like an
317 adequate interpretation of R5RS "numerically closest", and it's easier
318 and faster than a full "nearest-even" style.
320 The bit test must be done on the absolute value of the mpz_t, which means
321 we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
322 negatives as twos complement.
324 In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
325 following the hardware rounding mode, but applied to the absolute
326 value of the mpz_t operand. This is not what we want so we put the
327 high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
328 (released in March 2006) mpz_get_d now always truncates towards zero.
330 ENHANCE-ME: The temporary init+clear to force the rounding in GMP
331 before 4.2 is a slowdown. It'd be faster to pick out the relevant
332 high bits with mpz_getlimbn. */
335 scm_i_big2dbl (SCM b
)
340 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
344 /* For GMP earlier than 4.2, force truncation towards zero */
346 /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
347 _not_ the number of bits, so this code will break badly on a
348 system with non-binary doubles. */
351 if (bits
> DBL_MANT_DIG
)
353 size_t shift
= bits
- DBL_MANT_DIG
;
354 mpz_init2 (tmp
, DBL_MANT_DIG
);
355 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
356 result
= ldexp (mpz_get_d (tmp
), shift
);
361 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
365 /* GMP 4.2 or later */
366 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
369 if (bits
> DBL_MANT_DIG
)
371 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
372 /* test bit number "pos" in absolute value */
373 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
374 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
376 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
380 scm_remember_upto_here_1 (b
);
385 scm_i_normbig (SCM b
)
387 /* convert a big back to a fixnum if it'll fit */
388 /* presume b is a bignum */
389 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
391 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
392 if (SCM_FIXABLE (val
))
393 b
= SCM_I_MAKINUM (val
);
398 static SCM_C_INLINE_KEYWORD SCM
399 scm_i_mpz2num (mpz_t b
)
401 /* convert a mpz number to a SCM number. */
402 if (mpz_fits_slong_p (b
))
404 scm_t_inum val
= mpz_get_si (b
);
405 if (SCM_FIXABLE (val
))
406 return SCM_I_MAKINUM (val
);
410 SCM z
= make_bignum ();
411 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
416 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
417 static SCM
scm_divide2real (SCM x
, SCM y
);
420 scm_i_make_ratio (SCM numerator
, SCM denominator
)
421 #define FUNC_NAME "make-ratio"
423 /* First make sure the arguments are proper.
425 if (SCM_I_INUMP (denominator
))
427 if (scm_is_eq (denominator
, SCM_INUM0
))
428 scm_num_overflow ("make-ratio");
429 if (scm_is_eq (denominator
, SCM_INUM1
))
434 if (!(SCM_BIGP(denominator
)))
435 SCM_WRONG_TYPE_ARG (2, denominator
);
437 if (!SCM_I_INUMP (numerator
) && !SCM_BIGP (numerator
))
438 SCM_WRONG_TYPE_ARG (1, numerator
);
440 /* Then flip signs so that the denominator is positive.
442 if (scm_is_true (scm_negative_p (denominator
)))
444 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
445 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
448 /* Now consider for each of the four fixnum/bignum combinations
449 whether the rational number is really an integer.
451 if (SCM_I_INUMP (numerator
))
453 scm_t_inum x
= SCM_I_INUM (numerator
);
454 if (scm_is_eq (numerator
, SCM_INUM0
))
456 if (SCM_I_INUMP (denominator
))
459 y
= SCM_I_INUM (denominator
);
463 return SCM_I_MAKINUM (x
/ y
);
467 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
468 of that value for the denominator, as a bignum. Apart from
469 that case, abs(bignum) > abs(inum) so inum/bignum is not an
471 if (x
== SCM_MOST_NEGATIVE_FIXNUM
472 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
473 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
474 return SCM_I_MAKINUM(-1);
477 else if (SCM_BIGP (numerator
))
479 if (SCM_I_INUMP (denominator
))
481 scm_t_inum yy
= SCM_I_INUM (denominator
);
482 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
483 return scm_divide (numerator
, denominator
);
487 if (scm_is_eq (numerator
, denominator
))
489 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
490 SCM_I_BIG_MPZ (denominator
)))
491 return scm_divide(numerator
, denominator
);
495 /* No, it's a proper fraction.
498 SCM divisor
= scm_gcd (numerator
, denominator
);
499 if (!(scm_is_eq (divisor
, SCM_INUM1
)))
501 numerator
= scm_divide (numerator
, divisor
);
502 denominator
= scm_divide (denominator
, divisor
);
505 return scm_double_cell (scm_tc16_fraction
,
506 SCM_UNPACK (numerator
),
507 SCM_UNPACK (denominator
), 0);
513 scm_i_fraction2double (SCM z
)
515 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
516 SCM_FRACTION_DENOMINATOR (z
)));
520 double_is_non_negative_zero (double x
)
522 static double zero
= 0.0;
524 return !memcmp (&x
, &zero
, sizeof(double));
527 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
529 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
531 #define FUNC_NAME s_scm_exact_p
533 if (SCM_INEXACTP (x
))
535 else if (SCM_NUMBERP (x
))
538 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
543 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
545 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
547 #define FUNC_NAME s_scm_inexact_p
549 if (SCM_INEXACTP (x
))
551 else if (SCM_NUMBERP (x
))
554 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
559 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
561 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
563 #define FUNC_NAME s_scm_odd_p
567 scm_t_inum val
= SCM_I_INUM (n
);
568 return scm_from_bool ((val
& 1L) != 0);
570 else if (SCM_BIGP (n
))
572 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
573 scm_remember_upto_here_1 (n
);
574 return scm_from_bool (odd_p
);
576 else if (SCM_REALP (n
))
578 double val
= SCM_REAL_VALUE (n
);
579 if (DOUBLE_IS_FINITE (val
))
581 double rem
= fabs (fmod (val
, 2.0));
588 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
593 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
595 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
597 #define FUNC_NAME s_scm_even_p
601 scm_t_inum val
= SCM_I_INUM (n
);
602 return scm_from_bool ((val
& 1L) == 0);
604 else if (SCM_BIGP (n
))
606 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
607 scm_remember_upto_here_1 (n
);
608 return scm_from_bool (even_p
);
610 else if (SCM_REALP (n
))
612 double val
= SCM_REAL_VALUE (n
);
613 if (DOUBLE_IS_FINITE (val
))
615 double rem
= fabs (fmod (val
, 2.0));
622 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
626 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
628 "Return @code{#t} if the real number @var{x} is neither\n"
629 "infinite nor a NaN, @code{#f} otherwise.")
630 #define FUNC_NAME s_scm_finite_p
633 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
634 else if (scm_is_real (x
))
637 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
641 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
643 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
644 "@samp{-inf.0}. Otherwise return @code{#f}.")
645 #define FUNC_NAME s_scm_inf_p
648 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
649 else if (scm_is_real (x
))
652 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
656 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
658 "Return @code{#t} if the real number @var{x} is a NaN,\n"
659 "or @code{#f} otherwise.")
660 #define FUNC_NAME s_scm_nan_p
663 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
664 else if (scm_is_real (x
))
667 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
671 /* Guile's idea of infinity. */
672 static double guile_Inf
;
674 /* Guile's idea of not a number. */
675 static double guile_NaN
;
678 guile_ieee_init (void)
680 /* Some version of gcc on some old version of Linux used to crash when
681 trying to make Inf and NaN. */
684 /* C99 INFINITY, when available.
685 FIXME: The standard allows for INFINITY to be something that overflows
686 at compile time. We ought to have a configure test to check for that
687 before trying to use it. (But in practice we believe this is not a
688 problem on any system guile is likely to target.) */
689 guile_Inf
= INFINITY
;
690 #elif defined HAVE_DINFINITY
692 extern unsigned int DINFINITY
[2];
693 guile_Inf
= (*((double *) (DINFINITY
)));
700 if (guile_Inf
== tmp
)
707 /* C99 NAN, when available */
709 #elif defined HAVE_DQNAN
712 extern unsigned int DQNAN
[2];
713 guile_NaN
= (*((double *)(DQNAN
)));
716 guile_NaN
= guile_Inf
/ guile_Inf
;
720 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
723 #define FUNC_NAME s_scm_inf
725 static int initialized
= 0;
731 return scm_from_double (guile_Inf
);
735 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
738 #define FUNC_NAME s_scm_nan
740 static int initialized
= 0;
746 return scm_from_double (guile_NaN
);
751 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
753 "Return the absolute value of @var{x}.")
754 #define FUNC_NAME s_scm_abs
758 scm_t_inum xx
= SCM_I_INUM (x
);
761 else if (SCM_POSFIXABLE (-xx
))
762 return SCM_I_MAKINUM (-xx
);
764 return scm_i_inum2big (-xx
);
766 else if (SCM_LIKELY (SCM_REALP (x
)))
768 double xx
= SCM_REAL_VALUE (x
);
769 /* If x is a NaN then xx<0 is false so we return x unchanged */
771 return scm_from_double (-xx
);
772 /* Handle signed zeroes properly */
773 else if (SCM_UNLIKELY (xx
== 0.0))
778 else if (SCM_BIGP (x
))
780 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
782 return scm_i_clonebig (x
, 0);
786 else if (SCM_FRACTIONP (x
))
788 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
790 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
791 SCM_FRACTION_DENOMINATOR (x
));
794 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
799 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
801 "Return the quotient of the numbers @var{x} and @var{y}.")
802 #define FUNC_NAME s_scm_quotient
804 if (SCM_LIKELY (scm_is_integer (x
)))
806 if (SCM_LIKELY (scm_is_integer (y
)))
807 return scm_truncate_quotient (x
, y
);
809 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
812 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
816 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
818 "Return the remainder of the numbers @var{x} and @var{y}.\n"
820 "(remainder 13 4) @result{} 1\n"
821 "(remainder -13 4) @result{} -1\n"
823 #define FUNC_NAME s_scm_remainder
825 if (SCM_LIKELY (scm_is_integer (x
)))
827 if (SCM_LIKELY (scm_is_integer (y
)))
828 return scm_truncate_remainder (x
, y
);
830 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
833 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
838 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
840 "Return the modulo of the numbers @var{x} and @var{y}.\n"
842 "(modulo 13 4) @result{} 1\n"
843 "(modulo -13 4) @result{} 3\n"
845 #define FUNC_NAME s_scm_modulo
847 if (SCM_LIKELY (scm_is_integer (x
)))
849 if (SCM_LIKELY (scm_is_integer (y
)))
850 return scm_floor_remainder (x
, y
);
852 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
855 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
859 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
860 two-valued functions. It is called from primitive generics that take
861 two arguments and return two values, when the core procedure is
862 unable to handle the given argument types. If there are GOOPS
863 methods for this primitive generic, it dispatches to GOOPS and, if
864 successful, expects two values to be returned, which are placed in
865 *rp1 and *rp2. If there are no GOOPS methods, it throws a
866 wrong-type-arg exception.
868 FIXME: This obviously belongs somewhere else, but until we decide on
869 the right API, it is here as a static function, because it is needed
870 by the *_divide functions below.
873 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
874 const char *subr
, SCM
*rp1
, SCM
*rp2
)
877 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
879 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
882 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
884 "Return the integer @var{q} such that\n"
885 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
886 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
888 "(euclidean-quotient 123 10) @result{} 12\n"
889 "(euclidean-quotient 123 -10) @result{} -12\n"
890 "(euclidean-quotient -123 10) @result{} -13\n"
891 "(euclidean-quotient -123 -10) @result{} 13\n"
892 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
893 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
895 #define FUNC_NAME s_scm_euclidean_quotient
897 if (scm_is_false (scm_negative_p (y
)))
898 return scm_floor_quotient (x
, y
);
900 return scm_ceiling_quotient (x
, y
);
904 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
906 "Return the real number @var{r} such that\n"
907 "@math{0 <= @var{r} < abs(@var{y})} and\n"
908 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
909 "for some integer @var{q}.\n"
911 "(euclidean-remainder 123 10) @result{} 3\n"
912 "(euclidean-remainder 123 -10) @result{} 3\n"
913 "(euclidean-remainder -123 10) @result{} 7\n"
914 "(euclidean-remainder -123 -10) @result{} 7\n"
915 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
916 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
918 #define FUNC_NAME s_scm_euclidean_remainder
920 if (scm_is_false (scm_negative_p (y
)))
921 return scm_floor_remainder (x
, y
);
923 return scm_ceiling_remainder (x
, y
);
927 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
929 "Return the integer @var{q} and the real number @var{r}\n"
930 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
931 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
933 "(euclidean/ 123 10) @result{} 12 and 3\n"
934 "(euclidean/ 123 -10) @result{} -12 and 3\n"
935 "(euclidean/ -123 10) @result{} -13 and 7\n"
936 "(euclidean/ -123 -10) @result{} 13 and 7\n"
937 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
938 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
940 #define FUNC_NAME s_scm_i_euclidean_divide
942 if (scm_is_false (scm_negative_p (y
)))
943 return scm_i_floor_divide (x
, y
);
945 return scm_i_ceiling_divide (x
, y
);
950 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
952 if (scm_is_false (scm_negative_p (y
)))
953 return scm_floor_divide (x
, y
, qp
, rp
);
955 return scm_ceiling_divide (x
, y
, qp
, rp
);
958 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
959 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
961 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
963 "Return the floor of @math{@var{x} / @var{y}}.\n"
965 "(floor-quotient 123 10) @result{} 12\n"
966 "(floor-quotient 123 -10) @result{} -13\n"
967 "(floor-quotient -123 10) @result{} -13\n"
968 "(floor-quotient -123 -10) @result{} 12\n"
969 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
970 "(floor-quotient 16/3 -10/7) @result{} -4\n"
972 #define FUNC_NAME s_scm_floor_quotient
974 if (SCM_LIKELY (SCM_I_INUMP (x
)))
976 scm_t_inum xx
= SCM_I_INUM (x
);
977 if (SCM_LIKELY (SCM_I_INUMP (y
)))
979 scm_t_inum yy
= SCM_I_INUM (y
);
982 if (SCM_LIKELY (yy
> 0))
984 if (SCM_UNLIKELY (xx
< 0))
987 else if (SCM_UNLIKELY (yy
== 0))
988 scm_num_overflow (s_scm_floor_quotient
);
992 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
993 return SCM_I_MAKINUM (qq
);
995 return scm_i_inum2big (qq
);
997 else if (SCM_BIGP (y
))
999 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1000 scm_remember_upto_here_1 (y
);
1002 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1004 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1006 else if (SCM_REALP (y
))
1007 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1008 else if (SCM_FRACTIONP (y
))
1009 return scm_i_exact_rational_floor_quotient (x
, y
);
1011 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1012 s_scm_floor_quotient
);
1014 else if (SCM_BIGP (x
))
1016 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1018 scm_t_inum yy
= SCM_I_INUM (y
);
1019 if (SCM_UNLIKELY (yy
== 0))
1020 scm_num_overflow (s_scm_floor_quotient
);
1021 else if (SCM_UNLIKELY (yy
== 1))
1025 SCM q
= scm_i_mkbig ();
1027 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1030 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1031 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1033 scm_remember_upto_here_1 (x
);
1034 return scm_i_normbig (q
);
1037 else if (SCM_BIGP (y
))
1039 SCM q
= scm_i_mkbig ();
1040 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1043 scm_remember_upto_here_2 (x
, y
);
1044 return scm_i_normbig (q
);
1046 else if (SCM_REALP (y
))
1047 return scm_i_inexact_floor_quotient
1048 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1049 else if (SCM_FRACTIONP (y
))
1050 return scm_i_exact_rational_floor_quotient (x
, y
);
1052 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1053 s_scm_floor_quotient
);
1055 else if (SCM_REALP (x
))
1057 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1058 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1059 return scm_i_inexact_floor_quotient
1060 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1062 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1063 s_scm_floor_quotient
);
1065 else if (SCM_FRACTIONP (x
))
1068 return scm_i_inexact_floor_quotient
1069 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1070 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1071 return scm_i_exact_rational_floor_quotient (x
, y
);
1073 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1074 s_scm_floor_quotient
);
1077 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1078 s_scm_floor_quotient
);
1083 scm_i_inexact_floor_quotient (double x
, double y
)
1085 if (SCM_UNLIKELY (y
== 0))
1086 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1088 return scm_from_double (floor (x
/ y
));
1092 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1094 return scm_floor_quotient
1095 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1096 scm_product (scm_numerator (y
), scm_denominator (x
)));
1099 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1100 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1102 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1104 "Return the real number @var{r} such that\n"
1105 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1106 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1108 "(floor-remainder 123 10) @result{} 3\n"
1109 "(floor-remainder 123 -10) @result{} -7\n"
1110 "(floor-remainder -123 10) @result{} 7\n"
1111 "(floor-remainder -123 -10) @result{} -3\n"
1112 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1113 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1115 #define FUNC_NAME s_scm_floor_remainder
1117 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1119 scm_t_inum xx
= SCM_I_INUM (x
);
1120 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1122 scm_t_inum yy
= SCM_I_INUM (y
);
1123 if (SCM_UNLIKELY (yy
== 0))
1124 scm_num_overflow (s_scm_floor_remainder
);
1127 scm_t_inum rr
= xx
% yy
;
1128 int needs_adjustment
;
1130 if (SCM_LIKELY (yy
> 0))
1131 needs_adjustment
= (rr
< 0);
1133 needs_adjustment
= (rr
> 0);
1135 if (needs_adjustment
)
1137 return SCM_I_MAKINUM (rr
);
1140 else if (SCM_BIGP (y
))
1142 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1143 scm_remember_upto_here_1 (y
);
1148 SCM r
= scm_i_mkbig ();
1149 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1150 scm_remember_upto_here_1 (y
);
1151 return scm_i_normbig (r
);
1160 SCM r
= scm_i_mkbig ();
1161 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1162 scm_remember_upto_here_1 (y
);
1163 return scm_i_normbig (r
);
1166 else if (SCM_REALP (y
))
1167 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1168 else if (SCM_FRACTIONP (y
))
1169 return scm_i_exact_rational_floor_remainder (x
, y
);
1171 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1172 s_scm_floor_remainder
);
1174 else if (SCM_BIGP (x
))
1176 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1178 scm_t_inum yy
= SCM_I_INUM (y
);
1179 if (SCM_UNLIKELY (yy
== 0))
1180 scm_num_overflow (s_scm_floor_remainder
);
1185 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1187 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1188 scm_remember_upto_here_1 (x
);
1189 return SCM_I_MAKINUM (rr
);
1192 else if (SCM_BIGP (y
))
1194 SCM r
= scm_i_mkbig ();
1195 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1198 scm_remember_upto_here_2 (x
, y
);
1199 return scm_i_normbig (r
);
1201 else if (SCM_REALP (y
))
1202 return scm_i_inexact_floor_remainder
1203 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1204 else if (SCM_FRACTIONP (y
))
1205 return scm_i_exact_rational_floor_remainder (x
, y
);
1207 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1208 s_scm_floor_remainder
);
1210 else if (SCM_REALP (x
))
1212 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1213 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1214 return scm_i_inexact_floor_remainder
1215 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1217 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1218 s_scm_floor_remainder
);
1220 else if (SCM_FRACTIONP (x
))
1223 return scm_i_inexact_floor_remainder
1224 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1225 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1226 return scm_i_exact_rational_floor_remainder (x
, y
);
1228 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1229 s_scm_floor_remainder
);
1232 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1233 s_scm_floor_remainder
);
1238 scm_i_inexact_floor_remainder (double x
, double y
)
1240 /* Although it would be more efficient to use fmod here, we can't
1241 because it would in some cases produce results inconsistent with
1242 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1243 close). In particular, when x is very close to a multiple of y,
1244 then r might be either 0.0 or y, but those two cases must
1245 correspond to different choices of q. If r = 0.0 then q must be
1246 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1247 and remainder chooses the other, it would be bad. */
1248 if (SCM_UNLIKELY (y
== 0))
1249 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1251 return scm_from_double (x
- y
* floor (x
/ y
));
1255 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1257 SCM xd
= scm_denominator (x
);
1258 SCM yd
= scm_denominator (y
);
1259 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1260 scm_product (scm_numerator (y
), xd
));
1261 return scm_divide (r1
, scm_product (xd
, yd
));
1265 static void scm_i_inexact_floor_divide (double x
, double y
,
1267 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1270 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1272 "Return the integer @var{q} and the real number @var{r}\n"
1273 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1274 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1276 "(floor/ 123 10) @result{} 12 and 3\n"
1277 "(floor/ 123 -10) @result{} -13 and -7\n"
1278 "(floor/ -123 10) @result{} -13 and 7\n"
1279 "(floor/ -123 -10) @result{} 12 and -3\n"
1280 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1281 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1283 #define FUNC_NAME s_scm_i_floor_divide
1287 scm_floor_divide(x
, y
, &q
, &r
);
1288 return scm_values (scm_list_2 (q
, r
));
1292 #define s_scm_floor_divide s_scm_i_floor_divide
1293 #define g_scm_floor_divide g_scm_i_floor_divide
1296 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1298 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1300 scm_t_inum xx
= SCM_I_INUM (x
);
1301 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1303 scm_t_inum yy
= SCM_I_INUM (y
);
1304 if (SCM_UNLIKELY (yy
== 0))
1305 scm_num_overflow (s_scm_floor_divide
);
1308 scm_t_inum qq
= xx
/ yy
;
1309 scm_t_inum rr
= xx
% yy
;
1310 int needs_adjustment
;
1312 if (SCM_LIKELY (yy
> 0))
1313 needs_adjustment
= (rr
< 0);
1315 needs_adjustment
= (rr
> 0);
1317 if (needs_adjustment
)
1323 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1324 *qp
= SCM_I_MAKINUM (qq
);
1326 *qp
= scm_i_inum2big (qq
);
1327 *rp
= SCM_I_MAKINUM (rr
);
1331 else if (SCM_BIGP (y
))
1333 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1334 scm_remember_upto_here_1 (y
);
1339 SCM r
= scm_i_mkbig ();
1340 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1341 scm_remember_upto_here_1 (y
);
1342 *qp
= SCM_I_MAKINUM (-1);
1343 *rp
= scm_i_normbig (r
);
1358 SCM r
= scm_i_mkbig ();
1359 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1360 scm_remember_upto_here_1 (y
);
1361 *qp
= SCM_I_MAKINUM (-1);
1362 *rp
= scm_i_normbig (r
);
1366 else if (SCM_REALP (y
))
1367 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1368 else if (SCM_FRACTIONP (y
))
1369 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1371 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1372 s_scm_floor_divide
, qp
, rp
);
1374 else if (SCM_BIGP (x
))
1376 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1378 scm_t_inum yy
= SCM_I_INUM (y
);
1379 if (SCM_UNLIKELY (yy
== 0))
1380 scm_num_overflow (s_scm_floor_divide
);
1383 SCM q
= scm_i_mkbig ();
1384 SCM r
= scm_i_mkbig ();
1386 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1387 SCM_I_BIG_MPZ (x
), yy
);
1390 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1391 SCM_I_BIG_MPZ (x
), -yy
);
1392 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1394 scm_remember_upto_here_1 (x
);
1395 *qp
= scm_i_normbig (q
);
1396 *rp
= scm_i_normbig (r
);
1400 else if (SCM_BIGP (y
))
1402 SCM q
= scm_i_mkbig ();
1403 SCM r
= scm_i_mkbig ();
1404 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1405 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1406 scm_remember_upto_here_2 (x
, y
);
1407 *qp
= scm_i_normbig (q
);
1408 *rp
= scm_i_normbig (r
);
1411 else if (SCM_REALP (y
))
1412 return scm_i_inexact_floor_divide
1413 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1414 else if (SCM_FRACTIONP (y
))
1415 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1417 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1418 s_scm_floor_divide
, qp
, rp
);
1420 else if (SCM_REALP (x
))
1422 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1423 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1424 return scm_i_inexact_floor_divide
1425 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1427 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1428 s_scm_floor_divide
, qp
, rp
);
1430 else if (SCM_FRACTIONP (x
))
1433 return scm_i_inexact_floor_divide
1434 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1435 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1436 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1438 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1439 s_scm_floor_divide
, qp
, rp
);
1442 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1443 s_scm_floor_divide
, qp
, rp
);
1447 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1449 if (SCM_UNLIKELY (y
== 0))
1450 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1453 double q
= floor (x
/ y
);
1454 double r
= x
- q
* y
;
1455 *qp
= scm_from_double (q
);
1456 *rp
= scm_from_double (r
);
1461 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1464 SCM xd
= scm_denominator (x
);
1465 SCM yd
= scm_denominator (y
);
1467 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1468 scm_product (scm_numerator (y
), xd
),
1470 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1473 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1474 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1476 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1478 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1480 "(ceiling-quotient 123 10) @result{} 13\n"
1481 "(ceiling-quotient 123 -10) @result{} -12\n"
1482 "(ceiling-quotient -123 10) @result{} -12\n"
1483 "(ceiling-quotient -123 -10) @result{} 13\n"
1484 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1485 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1487 #define FUNC_NAME s_scm_ceiling_quotient
1489 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1491 scm_t_inum xx
= SCM_I_INUM (x
);
1492 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1494 scm_t_inum yy
= SCM_I_INUM (y
);
1495 if (SCM_UNLIKELY (yy
== 0))
1496 scm_num_overflow (s_scm_ceiling_quotient
);
1499 scm_t_inum xx1
= xx
;
1501 if (SCM_LIKELY (yy
> 0))
1503 if (SCM_LIKELY (xx
>= 0))
1506 else if (SCM_UNLIKELY (yy
== 0))
1507 scm_num_overflow (s_scm_ceiling_quotient
);
1511 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1512 return SCM_I_MAKINUM (qq
);
1514 return scm_i_inum2big (qq
);
1517 else if (SCM_BIGP (y
))
1519 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1520 scm_remember_upto_here_1 (y
);
1521 if (SCM_LIKELY (sign
> 0))
1523 if (SCM_LIKELY (xx
> 0))
1525 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1526 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1527 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1529 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1530 scm_remember_upto_here_1 (y
);
1531 return SCM_I_MAKINUM (-1);
1541 else if (SCM_REALP (y
))
1542 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1543 else if (SCM_FRACTIONP (y
))
1544 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1546 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1547 s_scm_ceiling_quotient
);
1549 else if (SCM_BIGP (x
))
1551 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1553 scm_t_inum yy
= SCM_I_INUM (y
);
1554 if (SCM_UNLIKELY (yy
== 0))
1555 scm_num_overflow (s_scm_ceiling_quotient
);
1556 else if (SCM_UNLIKELY (yy
== 1))
1560 SCM q
= scm_i_mkbig ();
1562 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1565 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1566 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1568 scm_remember_upto_here_1 (x
);
1569 return scm_i_normbig (q
);
1572 else if (SCM_BIGP (y
))
1574 SCM q
= scm_i_mkbig ();
1575 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1578 scm_remember_upto_here_2 (x
, y
);
1579 return scm_i_normbig (q
);
1581 else if (SCM_REALP (y
))
1582 return scm_i_inexact_ceiling_quotient
1583 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1584 else if (SCM_FRACTIONP (y
))
1585 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1587 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1588 s_scm_ceiling_quotient
);
1590 else if (SCM_REALP (x
))
1592 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1593 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1594 return scm_i_inexact_ceiling_quotient
1595 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1597 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1598 s_scm_ceiling_quotient
);
1600 else if (SCM_FRACTIONP (x
))
1603 return scm_i_inexact_ceiling_quotient
1604 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1605 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1606 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1608 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1609 s_scm_ceiling_quotient
);
1612 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1613 s_scm_ceiling_quotient
);
1618 scm_i_inexact_ceiling_quotient (double x
, double y
)
1620 if (SCM_UNLIKELY (y
== 0))
1621 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1623 return scm_from_double (ceil (x
/ y
));
1627 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1629 return scm_ceiling_quotient
1630 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1631 scm_product (scm_numerator (y
), scm_denominator (x
)));
1634 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1635 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1637 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1639 "Return the real number @var{r} such that\n"
1640 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1641 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1643 "(ceiling-remainder 123 10) @result{} -7\n"
1644 "(ceiling-remainder 123 -10) @result{} 3\n"
1645 "(ceiling-remainder -123 10) @result{} -3\n"
1646 "(ceiling-remainder -123 -10) @result{} 7\n"
1647 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1648 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1650 #define FUNC_NAME s_scm_ceiling_remainder
1652 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1654 scm_t_inum xx
= SCM_I_INUM (x
);
1655 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1657 scm_t_inum yy
= SCM_I_INUM (y
);
1658 if (SCM_UNLIKELY (yy
== 0))
1659 scm_num_overflow (s_scm_ceiling_remainder
);
1662 scm_t_inum rr
= xx
% yy
;
1663 int needs_adjustment
;
1665 if (SCM_LIKELY (yy
> 0))
1666 needs_adjustment
= (rr
> 0);
1668 needs_adjustment
= (rr
< 0);
1670 if (needs_adjustment
)
1672 return SCM_I_MAKINUM (rr
);
1675 else if (SCM_BIGP (y
))
1677 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1678 scm_remember_upto_here_1 (y
);
1679 if (SCM_LIKELY (sign
> 0))
1681 if (SCM_LIKELY (xx
> 0))
1683 SCM r
= scm_i_mkbig ();
1684 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1685 scm_remember_upto_here_1 (y
);
1686 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1687 return scm_i_normbig (r
);
1689 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1690 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1691 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1693 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1694 scm_remember_upto_here_1 (y
);
1704 SCM r
= scm_i_mkbig ();
1705 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1706 scm_remember_upto_here_1 (y
);
1707 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1708 return scm_i_normbig (r
);
1711 else if (SCM_REALP (y
))
1712 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1713 else if (SCM_FRACTIONP (y
))
1714 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1716 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1717 s_scm_ceiling_remainder
);
1719 else if (SCM_BIGP (x
))
1721 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1723 scm_t_inum yy
= SCM_I_INUM (y
);
1724 if (SCM_UNLIKELY (yy
== 0))
1725 scm_num_overflow (s_scm_ceiling_remainder
);
1730 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1732 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1733 scm_remember_upto_here_1 (x
);
1734 return SCM_I_MAKINUM (rr
);
1737 else if (SCM_BIGP (y
))
1739 SCM r
= scm_i_mkbig ();
1740 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1743 scm_remember_upto_here_2 (x
, y
);
1744 return scm_i_normbig (r
);
1746 else if (SCM_REALP (y
))
1747 return scm_i_inexact_ceiling_remainder
1748 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1749 else if (SCM_FRACTIONP (y
))
1750 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1752 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1753 s_scm_ceiling_remainder
);
1755 else if (SCM_REALP (x
))
1757 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1758 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1759 return scm_i_inexact_ceiling_remainder
1760 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1762 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1763 s_scm_ceiling_remainder
);
1765 else if (SCM_FRACTIONP (x
))
1768 return scm_i_inexact_ceiling_remainder
1769 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1770 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1771 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1773 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1774 s_scm_ceiling_remainder
);
1777 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1778 s_scm_ceiling_remainder
);
1783 scm_i_inexact_ceiling_remainder (double x
, double y
)
1785 /* Although it would be more efficient to use fmod here, we can't
1786 because it would in some cases produce results inconsistent with
1787 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1788 close). In particular, when x is very close to a multiple of y,
1789 then r might be either 0.0 or -y, but those two cases must
1790 correspond to different choices of q. If r = 0.0 then q must be
1791 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1792 and remainder chooses the other, it would be bad. */
1793 if (SCM_UNLIKELY (y
== 0))
1794 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1796 return scm_from_double (x
- y
* ceil (x
/ y
));
1800 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1802 SCM xd
= scm_denominator (x
);
1803 SCM yd
= scm_denominator (y
);
1804 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1805 scm_product (scm_numerator (y
), xd
));
1806 return scm_divide (r1
, scm_product (xd
, yd
));
1809 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1811 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1814 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1816 "Return the integer @var{q} and the real number @var{r}\n"
1817 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1818 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1820 "(ceiling/ 123 10) @result{} 13 and -7\n"
1821 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1822 "(ceiling/ -123 10) @result{} -12 and -3\n"
1823 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1824 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1825 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1827 #define FUNC_NAME s_scm_i_ceiling_divide
1831 scm_ceiling_divide(x
, y
, &q
, &r
);
1832 return scm_values (scm_list_2 (q
, r
));
1836 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1837 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1840 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1842 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1844 scm_t_inum xx
= SCM_I_INUM (x
);
1845 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1847 scm_t_inum yy
= SCM_I_INUM (y
);
1848 if (SCM_UNLIKELY (yy
== 0))
1849 scm_num_overflow (s_scm_ceiling_divide
);
1852 scm_t_inum qq
= xx
/ yy
;
1853 scm_t_inum rr
= xx
% yy
;
1854 int needs_adjustment
;
1856 if (SCM_LIKELY (yy
> 0))
1857 needs_adjustment
= (rr
> 0);
1859 needs_adjustment
= (rr
< 0);
1861 if (needs_adjustment
)
1866 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1867 *qp
= SCM_I_MAKINUM (qq
);
1869 *qp
= scm_i_inum2big (qq
);
1870 *rp
= SCM_I_MAKINUM (rr
);
1874 else if (SCM_BIGP (y
))
1876 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1877 scm_remember_upto_here_1 (y
);
1878 if (SCM_LIKELY (sign
> 0))
1880 if (SCM_LIKELY (xx
> 0))
1882 SCM r
= scm_i_mkbig ();
1883 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1884 scm_remember_upto_here_1 (y
);
1885 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1887 *rp
= scm_i_normbig (r
);
1889 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1890 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1891 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1893 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1894 scm_remember_upto_here_1 (y
);
1895 *qp
= SCM_I_MAKINUM (-1);
1911 SCM r
= scm_i_mkbig ();
1912 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1913 scm_remember_upto_here_1 (y
);
1914 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1916 *rp
= scm_i_normbig (r
);
1920 else if (SCM_REALP (y
))
1921 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1922 else if (SCM_FRACTIONP (y
))
1923 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1925 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1926 s_scm_ceiling_divide
, qp
, rp
);
1928 else if (SCM_BIGP (x
))
1930 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1932 scm_t_inum yy
= SCM_I_INUM (y
);
1933 if (SCM_UNLIKELY (yy
== 0))
1934 scm_num_overflow (s_scm_ceiling_divide
);
1937 SCM q
= scm_i_mkbig ();
1938 SCM r
= scm_i_mkbig ();
1940 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1941 SCM_I_BIG_MPZ (x
), yy
);
1944 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1945 SCM_I_BIG_MPZ (x
), -yy
);
1946 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1948 scm_remember_upto_here_1 (x
);
1949 *qp
= scm_i_normbig (q
);
1950 *rp
= scm_i_normbig (r
);
1954 else if (SCM_BIGP (y
))
1956 SCM q
= scm_i_mkbig ();
1957 SCM r
= scm_i_mkbig ();
1958 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1959 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1960 scm_remember_upto_here_2 (x
, y
);
1961 *qp
= scm_i_normbig (q
);
1962 *rp
= scm_i_normbig (r
);
1965 else if (SCM_REALP (y
))
1966 return scm_i_inexact_ceiling_divide
1967 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1968 else if (SCM_FRACTIONP (y
))
1969 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1971 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1972 s_scm_ceiling_divide
, qp
, rp
);
1974 else if (SCM_REALP (x
))
1976 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1977 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1978 return scm_i_inexact_ceiling_divide
1979 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1981 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1982 s_scm_ceiling_divide
, qp
, rp
);
1984 else if (SCM_FRACTIONP (x
))
1987 return scm_i_inexact_ceiling_divide
1988 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1989 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1990 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1992 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1993 s_scm_ceiling_divide
, qp
, rp
);
1996 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
1997 s_scm_ceiling_divide
, qp
, rp
);
2001 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2003 if (SCM_UNLIKELY (y
== 0))
2004 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2007 double q
= ceil (x
/ y
);
2008 double r
= x
- q
* y
;
2009 *qp
= scm_from_double (q
);
2010 *rp
= scm_from_double (r
);
2015 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2018 SCM xd
= scm_denominator (x
);
2019 SCM yd
= scm_denominator (y
);
2021 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2022 scm_product (scm_numerator (y
), xd
),
2024 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2027 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2028 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2030 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2032 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2034 "(truncate-quotient 123 10) @result{} 12\n"
2035 "(truncate-quotient 123 -10) @result{} -12\n"
2036 "(truncate-quotient -123 10) @result{} -12\n"
2037 "(truncate-quotient -123 -10) @result{} 12\n"
2038 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2039 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2041 #define FUNC_NAME s_scm_truncate_quotient
2043 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2045 scm_t_inum xx
= SCM_I_INUM (x
);
2046 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2048 scm_t_inum yy
= SCM_I_INUM (y
);
2049 if (SCM_UNLIKELY (yy
== 0))
2050 scm_num_overflow (s_scm_truncate_quotient
);
2053 scm_t_inum qq
= xx
/ yy
;
2054 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2055 return SCM_I_MAKINUM (qq
);
2057 return scm_i_inum2big (qq
);
2060 else if (SCM_BIGP (y
))
2062 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2063 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2064 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2066 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2067 scm_remember_upto_here_1 (y
);
2068 return SCM_I_MAKINUM (-1);
2073 else if (SCM_REALP (y
))
2074 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2075 else if (SCM_FRACTIONP (y
))
2076 return scm_i_exact_rational_truncate_quotient (x
, y
);
2078 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2079 s_scm_truncate_quotient
);
2081 else if (SCM_BIGP (x
))
2083 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2085 scm_t_inum yy
= SCM_I_INUM (y
);
2086 if (SCM_UNLIKELY (yy
== 0))
2087 scm_num_overflow (s_scm_truncate_quotient
);
2088 else if (SCM_UNLIKELY (yy
== 1))
2092 SCM q
= scm_i_mkbig ();
2094 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2097 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2098 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2100 scm_remember_upto_here_1 (x
);
2101 return scm_i_normbig (q
);
2104 else if (SCM_BIGP (y
))
2106 SCM q
= scm_i_mkbig ();
2107 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2110 scm_remember_upto_here_2 (x
, y
);
2111 return scm_i_normbig (q
);
2113 else if (SCM_REALP (y
))
2114 return scm_i_inexact_truncate_quotient
2115 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2116 else if (SCM_FRACTIONP (y
))
2117 return scm_i_exact_rational_truncate_quotient (x
, y
);
2119 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2120 s_scm_truncate_quotient
);
2122 else if (SCM_REALP (x
))
2124 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2125 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2126 return scm_i_inexact_truncate_quotient
2127 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2129 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2130 s_scm_truncate_quotient
);
2132 else if (SCM_FRACTIONP (x
))
2135 return scm_i_inexact_truncate_quotient
2136 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2137 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2138 return scm_i_exact_rational_truncate_quotient (x
, y
);
2140 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2141 s_scm_truncate_quotient
);
2144 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2145 s_scm_truncate_quotient
);
2150 scm_i_inexact_truncate_quotient (double x
, double y
)
2152 if (SCM_UNLIKELY (y
== 0))
2153 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2155 return scm_from_double (trunc (x
/ y
));
2159 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2161 return scm_truncate_quotient
2162 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2163 scm_product (scm_numerator (y
), scm_denominator (x
)));
2166 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2167 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2169 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2171 "Return the real number @var{r} such that\n"
2172 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2173 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2175 "(truncate-remainder 123 10) @result{} 3\n"
2176 "(truncate-remainder 123 -10) @result{} 3\n"
2177 "(truncate-remainder -123 10) @result{} -3\n"
2178 "(truncate-remainder -123 -10) @result{} -3\n"
2179 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2180 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2182 #define FUNC_NAME s_scm_truncate_remainder
2184 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2186 scm_t_inum xx
= SCM_I_INUM (x
);
2187 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2189 scm_t_inum yy
= SCM_I_INUM (y
);
2190 if (SCM_UNLIKELY (yy
== 0))
2191 scm_num_overflow (s_scm_truncate_remainder
);
2193 return SCM_I_MAKINUM (xx
% yy
);
2195 else if (SCM_BIGP (y
))
2197 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2198 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2199 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2201 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2202 scm_remember_upto_here_1 (y
);
2208 else if (SCM_REALP (y
))
2209 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2210 else if (SCM_FRACTIONP (y
))
2211 return scm_i_exact_rational_truncate_remainder (x
, y
);
2213 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2214 s_scm_truncate_remainder
);
2216 else if (SCM_BIGP (x
))
2218 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2220 scm_t_inum yy
= SCM_I_INUM (y
);
2221 if (SCM_UNLIKELY (yy
== 0))
2222 scm_num_overflow (s_scm_truncate_remainder
);
2225 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2226 (yy
> 0) ? yy
: -yy
)
2227 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2228 scm_remember_upto_here_1 (x
);
2229 return SCM_I_MAKINUM (rr
);
2232 else if (SCM_BIGP (y
))
2234 SCM r
= scm_i_mkbig ();
2235 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2238 scm_remember_upto_here_2 (x
, y
);
2239 return scm_i_normbig (r
);
2241 else if (SCM_REALP (y
))
2242 return scm_i_inexact_truncate_remainder
2243 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2244 else if (SCM_FRACTIONP (y
))
2245 return scm_i_exact_rational_truncate_remainder (x
, y
);
2247 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2248 s_scm_truncate_remainder
);
2250 else if (SCM_REALP (x
))
2252 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2253 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2254 return scm_i_inexact_truncate_remainder
2255 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2257 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2258 s_scm_truncate_remainder
);
2260 else if (SCM_FRACTIONP (x
))
2263 return scm_i_inexact_truncate_remainder
2264 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2265 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2266 return scm_i_exact_rational_truncate_remainder (x
, y
);
2268 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2269 s_scm_truncate_remainder
);
2272 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2273 s_scm_truncate_remainder
);
2278 scm_i_inexact_truncate_remainder (double x
, double y
)
2280 /* Although it would be more efficient to use fmod here, we can't
2281 because it would in some cases produce results inconsistent with
2282 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2283 close). In particular, when x is very close to a multiple of y,
2284 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2285 correspond to different choices of q. If quotient chooses one and
2286 remainder chooses the other, it would be bad. */
2287 if (SCM_UNLIKELY (y
== 0))
2288 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2290 return scm_from_double (x
- y
* trunc (x
/ y
));
2294 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2296 SCM xd
= scm_denominator (x
);
2297 SCM yd
= scm_denominator (y
);
2298 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2299 scm_product (scm_numerator (y
), xd
));
2300 return scm_divide (r1
, scm_product (xd
, yd
));
2304 static void scm_i_inexact_truncate_divide (double x
, double y
,
2306 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2309 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2311 "Return the integer @var{q} and the real number @var{r}\n"
2312 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2313 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2315 "(truncate/ 123 10) @result{} 12 and 3\n"
2316 "(truncate/ 123 -10) @result{} -12 and 3\n"
2317 "(truncate/ -123 10) @result{} -12 and -3\n"
2318 "(truncate/ -123 -10) @result{} 12 and -3\n"
2319 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2320 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2322 #define FUNC_NAME s_scm_i_truncate_divide
2326 scm_truncate_divide(x
, y
, &q
, &r
);
2327 return scm_values (scm_list_2 (q
, r
));
2331 #define s_scm_truncate_divide s_scm_i_truncate_divide
2332 #define g_scm_truncate_divide g_scm_i_truncate_divide
2335 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2337 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2339 scm_t_inum xx
= SCM_I_INUM (x
);
2340 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2342 scm_t_inum yy
= SCM_I_INUM (y
);
2343 if (SCM_UNLIKELY (yy
== 0))
2344 scm_num_overflow (s_scm_truncate_divide
);
2347 scm_t_inum qq
= xx
/ yy
;
2348 scm_t_inum rr
= xx
% yy
;
2349 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2350 *qp
= SCM_I_MAKINUM (qq
);
2352 *qp
= scm_i_inum2big (qq
);
2353 *rp
= SCM_I_MAKINUM (rr
);
2357 else if (SCM_BIGP (y
))
2359 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2360 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2361 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2363 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2364 scm_remember_upto_here_1 (y
);
2365 *qp
= SCM_I_MAKINUM (-1);
2375 else if (SCM_REALP (y
))
2376 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2377 else if (SCM_FRACTIONP (y
))
2378 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2380 return two_valued_wta_dispatch_2
2381 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2382 s_scm_truncate_divide
, qp
, rp
);
2384 else if (SCM_BIGP (x
))
2386 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2388 scm_t_inum yy
= SCM_I_INUM (y
);
2389 if (SCM_UNLIKELY (yy
== 0))
2390 scm_num_overflow (s_scm_truncate_divide
);
2393 SCM q
= scm_i_mkbig ();
2396 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2397 SCM_I_BIG_MPZ (x
), yy
);
2400 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2401 SCM_I_BIG_MPZ (x
), -yy
);
2402 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2404 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2405 scm_remember_upto_here_1 (x
);
2406 *qp
= scm_i_normbig (q
);
2407 *rp
= SCM_I_MAKINUM (rr
);
2411 else if (SCM_BIGP (y
))
2413 SCM q
= scm_i_mkbig ();
2414 SCM r
= scm_i_mkbig ();
2415 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2416 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2417 scm_remember_upto_here_2 (x
, y
);
2418 *qp
= scm_i_normbig (q
);
2419 *rp
= scm_i_normbig (r
);
2421 else if (SCM_REALP (y
))
2422 return scm_i_inexact_truncate_divide
2423 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2424 else if (SCM_FRACTIONP (y
))
2425 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2427 return two_valued_wta_dispatch_2
2428 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2429 s_scm_truncate_divide
, qp
, rp
);
2431 else if (SCM_REALP (x
))
2433 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2434 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2435 return scm_i_inexact_truncate_divide
2436 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2438 return two_valued_wta_dispatch_2
2439 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2440 s_scm_truncate_divide
, qp
, rp
);
2442 else if (SCM_FRACTIONP (x
))
2445 return scm_i_inexact_truncate_divide
2446 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2447 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2448 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2450 return two_valued_wta_dispatch_2
2451 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2452 s_scm_truncate_divide
, qp
, rp
);
2455 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2456 s_scm_truncate_divide
, qp
, rp
);
2460 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2462 if (SCM_UNLIKELY (y
== 0))
2463 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2466 double q
= trunc (x
/ y
);
2467 double r
= x
- q
* y
;
2468 *qp
= scm_from_double (q
);
2469 *rp
= scm_from_double (r
);
2474 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2477 SCM xd
= scm_denominator (x
);
2478 SCM yd
= scm_denominator (y
);
2480 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2481 scm_product (scm_numerator (y
), xd
),
2483 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2486 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2487 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2488 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2490 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2492 "Return the integer @var{q} such that\n"
2493 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2494 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2496 "(centered-quotient 123 10) @result{} 12\n"
2497 "(centered-quotient 123 -10) @result{} -12\n"
2498 "(centered-quotient -123 10) @result{} -12\n"
2499 "(centered-quotient -123 -10) @result{} 12\n"
2500 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2501 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2503 #define FUNC_NAME s_scm_centered_quotient
2505 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2507 scm_t_inum xx
= SCM_I_INUM (x
);
2508 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2510 scm_t_inum yy
= SCM_I_INUM (y
);
2511 if (SCM_UNLIKELY (yy
== 0))
2512 scm_num_overflow (s_scm_centered_quotient
);
2515 scm_t_inum qq
= xx
/ yy
;
2516 scm_t_inum rr
= xx
% yy
;
2517 if (SCM_LIKELY (xx
> 0))
2519 if (SCM_LIKELY (yy
> 0))
2521 if (rr
>= (yy
+ 1) / 2)
2526 if (rr
>= (1 - yy
) / 2)
2532 if (SCM_LIKELY (yy
> 0))
2543 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2544 return SCM_I_MAKINUM (qq
);
2546 return scm_i_inum2big (qq
);
2549 else if (SCM_BIGP (y
))
2551 /* Pass a denormalized bignum version of x (even though it
2552 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2553 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2555 else if (SCM_REALP (y
))
2556 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2557 else if (SCM_FRACTIONP (y
))
2558 return scm_i_exact_rational_centered_quotient (x
, y
);
2560 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2561 s_scm_centered_quotient
);
2563 else if (SCM_BIGP (x
))
2565 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2567 scm_t_inum yy
= SCM_I_INUM (y
);
2568 if (SCM_UNLIKELY (yy
== 0))
2569 scm_num_overflow (s_scm_centered_quotient
);
2570 else if (SCM_UNLIKELY (yy
== 1))
2574 SCM q
= scm_i_mkbig ();
2576 /* Arrange for rr to initially be non-positive,
2577 because that simplifies the test to see
2578 if it is within the needed bounds. */
2581 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2582 SCM_I_BIG_MPZ (x
), yy
);
2583 scm_remember_upto_here_1 (x
);
2585 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2586 SCM_I_BIG_MPZ (q
), 1);
2590 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2591 SCM_I_BIG_MPZ (x
), -yy
);
2592 scm_remember_upto_here_1 (x
);
2593 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2595 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2596 SCM_I_BIG_MPZ (q
), 1);
2598 return scm_i_normbig (q
);
2601 else if (SCM_BIGP (y
))
2602 return scm_i_bigint_centered_quotient (x
, y
);
2603 else if (SCM_REALP (y
))
2604 return scm_i_inexact_centered_quotient
2605 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2606 else if (SCM_FRACTIONP (y
))
2607 return scm_i_exact_rational_centered_quotient (x
, y
);
2609 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2610 s_scm_centered_quotient
);
2612 else if (SCM_REALP (x
))
2614 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2615 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2616 return scm_i_inexact_centered_quotient
2617 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2619 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2620 s_scm_centered_quotient
);
2622 else if (SCM_FRACTIONP (x
))
2625 return scm_i_inexact_centered_quotient
2626 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2627 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2628 return scm_i_exact_rational_centered_quotient (x
, y
);
2630 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2631 s_scm_centered_quotient
);
2634 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2635 s_scm_centered_quotient
);
2640 scm_i_inexact_centered_quotient (double x
, double y
)
2642 if (SCM_LIKELY (y
> 0))
2643 return scm_from_double (floor (x
/y
+ 0.5));
2644 else if (SCM_LIKELY (y
< 0))
2645 return scm_from_double (ceil (x
/y
- 0.5));
2647 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2652 /* Assumes that both x and y are bigints, though
2653 x might be able to fit into a fixnum. */
2655 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2659 /* Note that x might be small enough to fit into a
2660 fixnum, so we must not let it escape into the wild */
2664 /* min_r will eventually become -abs(y)/2 */
2665 min_r
= scm_i_mkbig ();
2666 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2667 SCM_I_BIG_MPZ (y
), 1);
2669 /* Arrange for rr to initially be non-positive,
2670 because that simplifies the test to see
2671 if it is within the needed bounds. */
2672 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2674 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2675 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2676 scm_remember_upto_here_2 (x
, y
);
2677 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2678 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2679 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2680 SCM_I_BIG_MPZ (q
), 1);
2684 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2685 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2686 scm_remember_upto_here_2 (x
, y
);
2687 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2688 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2689 SCM_I_BIG_MPZ (q
), 1);
2691 scm_remember_upto_here_2 (r
, min_r
);
2692 return scm_i_normbig (q
);
2696 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2698 return scm_centered_quotient
2699 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2700 scm_product (scm_numerator (y
), scm_denominator (x
)));
2703 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2704 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2705 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2707 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2709 "Return the real number @var{r} such that\n"
2710 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2711 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2712 "for some integer @var{q}.\n"
2714 "(centered-remainder 123 10) @result{} 3\n"
2715 "(centered-remainder 123 -10) @result{} 3\n"
2716 "(centered-remainder -123 10) @result{} -3\n"
2717 "(centered-remainder -123 -10) @result{} -3\n"
2718 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2719 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2721 #define FUNC_NAME s_scm_centered_remainder
2723 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2725 scm_t_inum xx
= SCM_I_INUM (x
);
2726 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2728 scm_t_inum yy
= SCM_I_INUM (y
);
2729 if (SCM_UNLIKELY (yy
== 0))
2730 scm_num_overflow (s_scm_centered_remainder
);
2733 scm_t_inum rr
= xx
% yy
;
2734 if (SCM_LIKELY (xx
> 0))
2736 if (SCM_LIKELY (yy
> 0))
2738 if (rr
>= (yy
+ 1) / 2)
2743 if (rr
>= (1 - yy
) / 2)
2749 if (SCM_LIKELY (yy
> 0))
2760 return SCM_I_MAKINUM (rr
);
2763 else if (SCM_BIGP (y
))
2765 /* Pass a denormalized bignum version of x (even though it
2766 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2767 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2769 else if (SCM_REALP (y
))
2770 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2771 else if (SCM_FRACTIONP (y
))
2772 return scm_i_exact_rational_centered_remainder (x
, y
);
2774 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2775 s_scm_centered_remainder
);
2777 else if (SCM_BIGP (x
))
2779 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2781 scm_t_inum yy
= SCM_I_INUM (y
);
2782 if (SCM_UNLIKELY (yy
== 0))
2783 scm_num_overflow (s_scm_centered_remainder
);
2787 /* Arrange for rr to initially be non-positive,
2788 because that simplifies the test to see
2789 if it is within the needed bounds. */
2792 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2793 scm_remember_upto_here_1 (x
);
2799 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2800 scm_remember_upto_here_1 (x
);
2804 return SCM_I_MAKINUM (rr
);
2807 else if (SCM_BIGP (y
))
2808 return scm_i_bigint_centered_remainder (x
, y
);
2809 else if (SCM_REALP (y
))
2810 return scm_i_inexact_centered_remainder
2811 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2812 else if (SCM_FRACTIONP (y
))
2813 return scm_i_exact_rational_centered_remainder (x
, y
);
2815 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2816 s_scm_centered_remainder
);
2818 else if (SCM_REALP (x
))
2820 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2821 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2822 return scm_i_inexact_centered_remainder
2823 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2825 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2826 s_scm_centered_remainder
);
2828 else if (SCM_FRACTIONP (x
))
2831 return scm_i_inexact_centered_remainder
2832 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2833 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2834 return scm_i_exact_rational_centered_remainder (x
, y
);
2836 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2837 s_scm_centered_remainder
);
2840 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2841 s_scm_centered_remainder
);
2846 scm_i_inexact_centered_remainder (double x
, double y
)
2850 /* Although it would be more efficient to use fmod here, we can't
2851 because it would in some cases produce results inconsistent with
2852 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2853 close). In particular, when x-y/2 is very close to a multiple of
2854 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2855 two cases must correspond to different choices of q. If quotient
2856 chooses one and remainder chooses the other, it would be bad. */
2857 if (SCM_LIKELY (y
> 0))
2858 q
= floor (x
/y
+ 0.5);
2859 else if (SCM_LIKELY (y
< 0))
2860 q
= ceil (x
/y
- 0.5);
2862 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2865 return scm_from_double (x
- q
* y
);
2868 /* Assumes that both x and y are bigints, though
2869 x might be able to fit into a fixnum. */
2871 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2875 /* Note that x might be small enough to fit into a
2876 fixnum, so we must not let it escape into the wild */
2879 /* min_r will eventually become -abs(y)/2 */
2880 min_r
= scm_i_mkbig ();
2881 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2882 SCM_I_BIG_MPZ (y
), 1);
2884 /* Arrange for rr to initially be non-positive,
2885 because that simplifies the test to see
2886 if it is within the needed bounds. */
2887 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2889 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2890 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2891 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2892 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2893 mpz_add (SCM_I_BIG_MPZ (r
),
2899 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2900 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2901 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2902 mpz_sub (SCM_I_BIG_MPZ (r
),
2906 scm_remember_upto_here_2 (x
, y
);
2907 return scm_i_normbig (r
);
2911 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2913 SCM xd
= scm_denominator (x
);
2914 SCM yd
= scm_denominator (y
);
2915 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2916 scm_product (scm_numerator (y
), xd
));
2917 return scm_divide (r1
, scm_product (xd
, yd
));
2921 static void scm_i_inexact_centered_divide (double x
, double y
,
2923 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2924 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2927 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2929 "Return the integer @var{q} and the real number @var{r}\n"
2930 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2931 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2933 "(centered/ 123 10) @result{} 12 and 3\n"
2934 "(centered/ 123 -10) @result{} -12 and 3\n"
2935 "(centered/ -123 10) @result{} -12 and -3\n"
2936 "(centered/ -123 -10) @result{} 12 and -3\n"
2937 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2938 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2940 #define FUNC_NAME s_scm_i_centered_divide
2944 scm_centered_divide(x
, y
, &q
, &r
);
2945 return scm_values (scm_list_2 (q
, r
));
2949 #define s_scm_centered_divide s_scm_i_centered_divide
2950 #define g_scm_centered_divide g_scm_i_centered_divide
2953 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2955 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2957 scm_t_inum xx
= SCM_I_INUM (x
);
2958 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2960 scm_t_inum yy
= SCM_I_INUM (y
);
2961 if (SCM_UNLIKELY (yy
== 0))
2962 scm_num_overflow (s_scm_centered_divide
);
2965 scm_t_inum qq
= xx
/ yy
;
2966 scm_t_inum rr
= xx
% yy
;
2967 if (SCM_LIKELY (xx
> 0))
2969 if (SCM_LIKELY (yy
> 0))
2971 if (rr
>= (yy
+ 1) / 2)
2976 if (rr
>= (1 - yy
) / 2)
2982 if (SCM_LIKELY (yy
> 0))
2993 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2994 *qp
= SCM_I_MAKINUM (qq
);
2996 *qp
= scm_i_inum2big (qq
);
2997 *rp
= SCM_I_MAKINUM (rr
);
3001 else if (SCM_BIGP (y
))
3003 /* Pass a denormalized bignum version of x (even though it
3004 can fit in a fixnum) to scm_i_bigint_centered_divide */
3005 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3007 else if (SCM_REALP (y
))
3008 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3009 else if (SCM_FRACTIONP (y
))
3010 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3012 return two_valued_wta_dispatch_2
3013 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3014 s_scm_centered_divide
, qp
, rp
);
3016 else if (SCM_BIGP (x
))
3018 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3020 scm_t_inum yy
= SCM_I_INUM (y
);
3021 if (SCM_UNLIKELY (yy
== 0))
3022 scm_num_overflow (s_scm_centered_divide
);
3025 SCM q
= scm_i_mkbig ();
3027 /* Arrange for rr to initially be non-positive,
3028 because that simplifies the test to see
3029 if it is within the needed bounds. */
3032 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3033 SCM_I_BIG_MPZ (x
), yy
);
3034 scm_remember_upto_here_1 (x
);
3037 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3038 SCM_I_BIG_MPZ (q
), 1);
3044 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3045 SCM_I_BIG_MPZ (x
), -yy
);
3046 scm_remember_upto_here_1 (x
);
3047 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3050 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3051 SCM_I_BIG_MPZ (q
), 1);
3055 *qp
= scm_i_normbig (q
);
3056 *rp
= SCM_I_MAKINUM (rr
);
3060 else if (SCM_BIGP (y
))
3061 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3062 else if (SCM_REALP (y
))
3063 return scm_i_inexact_centered_divide
3064 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3065 else if (SCM_FRACTIONP (y
))
3066 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3068 return two_valued_wta_dispatch_2
3069 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3070 s_scm_centered_divide
, qp
, rp
);
3072 else if (SCM_REALP (x
))
3074 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3075 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3076 return scm_i_inexact_centered_divide
3077 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3079 return two_valued_wta_dispatch_2
3080 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3081 s_scm_centered_divide
, qp
, rp
);
3083 else if (SCM_FRACTIONP (x
))
3086 return scm_i_inexact_centered_divide
3087 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3088 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3089 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3091 return two_valued_wta_dispatch_2
3092 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3093 s_scm_centered_divide
, qp
, rp
);
3096 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3097 s_scm_centered_divide
, qp
, rp
);
3101 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3105 if (SCM_LIKELY (y
> 0))
3106 q
= floor (x
/y
+ 0.5);
3107 else if (SCM_LIKELY (y
< 0))
3108 q
= ceil (x
/y
- 0.5);
3110 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3114 *qp
= scm_from_double (q
);
3115 *rp
= scm_from_double (r
);
3118 /* Assumes that both x and y are bigints, though
3119 x might be able to fit into a fixnum. */
3121 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3125 /* Note that x might be small enough to fit into a
3126 fixnum, so we must not let it escape into the wild */
3130 /* min_r will eventually become -abs(y/2) */
3131 min_r
= scm_i_mkbig ();
3132 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3133 SCM_I_BIG_MPZ (y
), 1);
3135 /* Arrange for rr to initially be non-positive,
3136 because that simplifies the test to see
3137 if it is within the needed bounds. */
3138 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3140 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3141 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3142 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3143 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3145 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3146 SCM_I_BIG_MPZ (q
), 1);
3147 mpz_add (SCM_I_BIG_MPZ (r
),
3154 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3155 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3156 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3158 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3159 SCM_I_BIG_MPZ (q
), 1);
3160 mpz_sub (SCM_I_BIG_MPZ (r
),
3165 scm_remember_upto_here_2 (x
, y
);
3166 *qp
= scm_i_normbig (q
);
3167 *rp
= scm_i_normbig (r
);
3171 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3174 SCM xd
= scm_denominator (x
);
3175 SCM yd
= scm_denominator (y
);
3177 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3178 scm_product (scm_numerator (y
), xd
),
3180 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3183 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3184 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3185 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3187 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3189 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3190 "with ties going to the nearest even integer.\n"
3192 "(round-quotient 123 10) @result{} 12\n"
3193 "(round-quotient 123 -10) @result{} -12\n"
3194 "(round-quotient -123 10) @result{} -12\n"
3195 "(round-quotient -123 -10) @result{} 12\n"
3196 "(round-quotient 125 10) @result{} 12\n"
3197 "(round-quotient 127 10) @result{} 13\n"
3198 "(round-quotient 135 10) @result{} 14\n"
3199 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3200 "(round-quotient 16/3 -10/7) @result{} -4\n"
3202 #define FUNC_NAME s_scm_round_quotient
3204 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3206 scm_t_inum xx
= SCM_I_INUM (x
);
3207 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3209 scm_t_inum yy
= SCM_I_INUM (y
);
3210 if (SCM_UNLIKELY (yy
== 0))
3211 scm_num_overflow (s_scm_round_quotient
);
3214 scm_t_inum qq
= xx
/ yy
;
3215 scm_t_inum rr
= xx
% yy
;
3217 scm_t_inum r2
= 2 * rr
;
3219 if (SCM_LIKELY (yy
< 0))
3239 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3240 return SCM_I_MAKINUM (qq
);
3242 return scm_i_inum2big (qq
);
3245 else if (SCM_BIGP (y
))
3247 /* Pass a denormalized bignum version of x (even though it
3248 can fit in a fixnum) to scm_i_bigint_round_quotient */
3249 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3251 else if (SCM_REALP (y
))
3252 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3253 else if (SCM_FRACTIONP (y
))
3254 return scm_i_exact_rational_round_quotient (x
, y
);
3256 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3257 s_scm_round_quotient
);
3259 else if (SCM_BIGP (x
))
3261 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3263 scm_t_inum yy
= SCM_I_INUM (y
);
3264 if (SCM_UNLIKELY (yy
== 0))
3265 scm_num_overflow (s_scm_round_quotient
);
3266 else if (SCM_UNLIKELY (yy
== 1))
3270 SCM q
= scm_i_mkbig ();
3272 int needs_adjustment
;
3276 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3277 SCM_I_BIG_MPZ (x
), yy
);
3278 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3279 needs_adjustment
= (2*rr
>= yy
);
3281 needs_adjustment
= (2*rr
> yy
);
3285 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3286 SCM_I_BIG_MPZ (x
), -yy
);
3287 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3288 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3289 needs_adjustment
= (2*rr
<= yy
);
3291 needs_adjustment
= (2*rr
< yy
);
3293 scm_remember_upto_here_1 (x
);
3294 if (needs_adjustment
)
3295 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3296 return scm_i_normbig (q
);
3299 else if (SCM_BIGP (y
))
3300 return scm_i_bigint_round_quotient (x
, y
);
3301 else if (SCM_REALP (y
))
3302 return scm_i_inexact_round_quotient
3303 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3304 else if (SCM_FRACTIONP (y
))
3305 return scm_i_exact_rational_round_quotient (x
, y
);
3307 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3308 s_scm_round_quotient
);
3310 else if (SCM_REALP (x
))
3312 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3313 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3314 return scm_i_inexact_round_quotient
3315 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3317 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3318 s_scm_round_quotient
);
3320 else if (SCM_FRACTIONP (x
))
3323 return scm_i_inexact_round_quotient
3324 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3325 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3326 return scm_i_exact_rational_round_quotient (x
, y
);
3328 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3329 s_scm_round_quotient
);
3332 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3333 s_scm_round_quotient
);
3338 scm_i_inexact_round_quotient (double x
, double y
)
3340 if (SCM_UNLIKELY (y
== 0))
3341 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3343 return scm_from_double (scm_c_round (x
/ y
));
3346 /* Assumes that both x and y are bigints, though
3347 x might be able to fit into a fixnum. */
3349 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3352 int cmp
, needs_adjustment
;
3354 /* Note that x might be small enough to fit into a
3355 fixnum, so we must not let it escape into the wild */
3358 r2
= scm_i_mkbig ();
3360 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3361 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3362 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3363 scm_remember_upto_here_2 (x
, r
);
3365 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3366 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3367 needs_adjustment
= (cmp
>= 0);
3369 needs_adjustment
= (cmp
> 0);
3370 scm_remember_upto_here_2 (r2
, y
);
3372 if (needs_adjustment
)
3373 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3375 return scm_i_normbig (q
);
3379 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3381 return scm_round_quotient
3382 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3383 scm_product (scm_numerator (y
), scm_denominator (x
)));
3386 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3387 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3388 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3390 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3392 "Return the real number @var{r} such that\n"
3393 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3394 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3395 "nearest integer, with ties going to the nearest\n"
3398 "(round-remainder 123 10) @result{} 3\n"
3399 "(round-remainder 123 -10) @result{} 3\n"
3400 "(round-remainder -123 10) @result{} -3\n"
3401 "(round-remainder -123 -10) @result{} -3\n"
3402 "(round-remainder 125 10) @result{} 5\n"
3403 "(round-remainder 127 10) @result{} -3\n"
3404 "(round-remainder 135 10) @result{} -5\n"
3405 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3406 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3408 #define FUNC_NAME s_scm_round_remainder
3410 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3412 scm_t_inum xx
= SCM_I_INUM (x
);
3413 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3415 scm_t_inum yy
= SCM_I_INUM (y
);
3416 if (SCM_UNLIKELY (yy
== 0))
3417 scm_num_overflow (s_scm_round_remainder
);
3420 scm_t_inum qq
= xx
/ yy
;
3421 scm_t_inum rr
= xx
% yy
;
3423 scm_t_inum r2
= 2 * rr
;
3425 if (SCM_LIKELY (yy
< 0))
3445 return SCM_I_MAKINUM (rr
);
3448 else if (SCM_BIGP (y
))
3450 /* Pass a denormalized bignum version of x (even though it
3451 can fit in a fixnum) to scm_i_bigint_round_remainder */
3452 return scm_i_bigint_round_remainder
3453 (scm_i_long2big (xx
), y
);
3455 else if (SCM_REALP (y
))
3456 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3457 else if (SCM_FRACTIONP (y
))
3458 return scm_i_exact_rational_round_remainder (x
, y
);
3460 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3461 s_scm_round_remainder
);
3463 else if (SCM_BIGP (x
))
3465 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3467 scm_t_inum yy
= SCM_I_INUM (y
);
3468 if (SCM_UNLIKELY (yy
== 0))
3469 scm_num_overflow (s_scm_round_remainder
);
3472 SCM q
= scm_i_mkbig ();
3474 int needs_adjustment
;
3478 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3479 SCM_I_BIG_MPZ (x
), yy
);
3480 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3481 needs_adjustment
= (2*rr
>= yy
);
3483 needs_adjustment
= (2*rr
> yy
);
3487 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3488 SCM_I_BIG_MPZ (x
), -yy
);
3489 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3490 needs_adjustment
= (2*rr
<= yy
);
3492 needs_adjustment
= (2*rr
< yy
);
3494 scm_remember_upto_here_2 (x
, q
);
3495 if (needs_adjustment
)
3497 return SCM_I_MAKINUM (rr
);
3500 else if (SCM_BIGP (y
))
3501 return scm_i_bigint_round_remainder (x
, y
);
3502 else if (SCM_REALP (y
))
3503 return scm_i_inexact_round_remainder
3504 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3505 else if (SCM_FRACTIONP (y
))
3506 return scm_i_exact_rational_round_remainder (x
, y
);
3508 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3509 s_scm_round_remainder
);
3511 else if (SCM_REALP (x
))
3513 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3514 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3515 return scm_i_inexact_round_remainder
3516 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3518 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3519 s_scm_round_remainder
);
3521 else if (SCM_FRACTIONP (x
))
3524 return scm_i_inexact_round_remainder
3525 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3526 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3527 return scm_i_exact_rational_round_remainder (x
, y
);
3529 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3530 s_scm_round_remainder
);
3533 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3534 s_scm_round_remainder
);
3539 scm_i_inexact_round_remainder (double x
, double y
)
3541 /* Although it would be more efficient to use fmod here, we can't
3542 because it would in some cases produce results inconsistent with
3543 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3544 close). In particular, when x-y/2 is very close to a multiple of
3545 y, then r might be either -abs(y/2) or abs(y/2), but those two
3546 cases must correspond to different choices of q. If quotient
3547 chooses one and remainder chooses the other, it would be bad. */
3549 if (SCM_UNLIKELY (y
== 0))
3550 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3553 double q
= scm_c_round (x
/ y
);
3554 return scm_from_double (x
- q
* y
);
3558 /* Assumes that both x and y are bigints, though
3559 x might be able to fit into a fixnum. */
3561 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3564 int cmp
, needs_adjustment
;
3566 /* Note that x might be small enough to fit into a
3567 fixnum, so we must not let it escape into the wild */
3570 r2
= scm_i_mkbig ();
3572 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3573 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3574 scm_remember_upto_here_1 (x
);
3575 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3577 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3578 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3579 needs_adjustment
= (cmp
>= 0);
3581 needs_adjustment
= (cmp
> 0);
3582 scm_remember_upto_here_2 (q
, r2
);
3584 if (needs_adjustment
)
3585 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3587 scm_remember_upto_here_1 (y
);
3588 return scm_i_normbig (r
);
3592 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3594 SCM xd
= scm_denominator (x
);
3595 SCM yd
= scm_denominator (y
);
3596 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3597 scm_product (scm_numerator (y
), xd
));
3598 return scm_divide (r1
, scm_product (xd
, yd
));
3602 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3603 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3604 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3606 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3608 "Return the integer @var{q} and the real number @var{r}\n"
3609 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3610 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3611 "nearest integer, with ties going to the nearest even integer.\n"
3613 "(round/ 123 10) @result{} 12 and 3\n"
3614 "(round/ 123 -10) @result{} -12 and 3\n"
3615 "(round/ -123 10) @result{} -12 and -3\n"
3616 "(round/ -123 -10) @result{} 12 and -3\n"
3617 "(round/ 125 10) @result{} 12 and 5\n"
3618 "(round/ 127 10) @result{} 13 and -3\n"
3619 "(round/ 135 10) @result{} 14 and -5\n"
3620 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3621 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3623 #define FUNC_NAME s_scm_i_round_divide
3627 scm_round_divide(x
, y
, &q
, &r
);
3628 return scm_values (scm_list_2 (q
, r
));
3632 #define s_scm_round_divide s_scm_i_round_divide
3633 #define g_scm_round_divide g_scm_i_round_divide
3636 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3638 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3640 scm_t_inum xx
= SCM_I_INUM (x
);
3641 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3643 scm_t_inum yy
= SCM_I_INUM (y
);
3644 if (SCM_UNLIKELY (yy
== 0))
3645 scm_num_overflow (s_scm_round_divide
);
3648 scm_t_inum qq
= xx
/ yy
;
3649 scm_t_inum rr
= xx
% yy
;
3651 scm_t_inum r2
= 2 * rr
;
3653 if (SCM_LIKELY (yy
< 0))
3673 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3674 *qp
= SCM_I_MAKINUM (qq
);
3676 *qp
= scm_i_inum2big (qq
);
3677 *rp
= SCM_I_MAKINUM (rr
);
3681 else if (SCM_BIGP (y
))
3683 /* Pass a denormalized bignum version of x (even though it
3684 can fit in a fixnum) to scm_i_bigint_round_divide */
3685 return scm_i_bigint_round_divide
3686 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3688 else if (SCM_REALP (y
))
3689 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3690 else if (SCM_FRACTIONP (y
))
3691 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3693 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3694 s_scm_round_divide
, qp
, rp
);
3696 else if (SCM_BIGP (x
))
3698 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3700 scm_t_inum yy
= SCM_I_INUM (y
);
3701 if (SCM_UNLIKELY (yy
== 0))
3702 scm_num_overflow (s_scm_round_divide
);
3705 SCM q
= scm_i_mkbig ();
3707 int needs_adjustment
;
3711 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3712 SCM_I_BIG_MPZ (x
), yy
);
3713 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3714 needs_adjustment
= (2*rr
>= yy
);
3716 needs_adjustment
= (2*rr
> yy
);
3720 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3721 SCM_I_BIG_MPZ (x
), -yy
);
3722 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3723 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3724 needs_adjustment
= (2*rr
<= yy
);
3726 needs_adjustment
= (2*rr
< yy
);
3728 scm_remember_upto_here_1 (x
);
3729 if (needs_adjustment
)
3731 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3734 *qp
= scm_i_normbig (q
);
3735 *rp
= SCM_I_MAKINUM (rr
);
3739 else if (SCM_BIGP (y
))
3740 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3741 else if (SCM_REALP (y
))
3742 return scm_i_inexact_round_divide
3743 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3744 else if (SCM_FRACTIONP (y
))
3745 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3747 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3748 s_scm_round_divide
, qp
, rp
);
3750 else if (SCM_REALP (x
))
3752 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3753 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3754 return scm_i_inexact_round_divide
3755 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3757 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3758 s_scm_round_divide
, qp
, rp
);
3760 else if (SCM_FRACTIONP (x
))
3763 return scm_i_inexact_round_divide
3764 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3765 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3766 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3768 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3769 s_scm_round_divide
, qp
, rp
);
3772 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3773 s_scm_round_divide
, qp
, rp
);
3777 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3779 if (SCM_UNLIKELY (y
== 0))
3780 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3783 double q
= scm_c_round (x
/ y
);
3784 double r
= x
- q
* y
;
3785 *qp
= scm_from_double (q
);
3786 *rp
= scm_from_double (r
);
3790 /* Assumes that both x and y are bigints, though
3791 x might be able to fit into a fixnum. */
3793 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3796 int cmp
, needs_adjustment
;
3798 /* Note that x might be small enough to fit into a
3799 fixnum, so we must not let it escape into the wild */
3802 r2
= scm_i_mkbig ();
3804 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3805 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3806 scm_remember_upto_here_1 (x
);
3807 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3809 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3810 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3811 needs_adjustment
= (cmp
>= 0);
3813 needs_adjustment
= (cmp
> 0);
3815 if (needs_adjustment
)
3817 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3818 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3821 scm_remember_upto_here_2 (r2
, y
);
3822 *qp
= scm_i_normbig (q
);
3823 *rp
= scm_i_normbig (r
);
3827 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3830 SCM xd
= scm_denominator (x
);
3831 SCM yd
= scm_denominator (y
);
3833 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3834 scm_product (scm_numerator (y
), xd
),
3836 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3840 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3841 (SCM x
, SCM y
, SCM rest
),
3842 "Return the greatest common divisor of all parameter values.\n"
3843 "If called without arguments, 0 is returned.")
3844 #define FUNC_NAME s_scm_i_gcd
3846 while (!scm_is_null (rest
))
3847 { x
= scm_gcd (x
, y
);
3849 rest
= scm_cdr (rest
);
3851 return scm_gcd (x
, y
);
3855 #define s_gcd s_scm_i_gcd
3856 #define g_gcd g_scm_i_gcd
3859 scm_gcd (SCM x
, SCM y
)
3862 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3864 if (SCM_I_INUMP (x
))
3866 if (SCM_I_INUMP (y
))
3868 scm_t_inum xx
= SCM_I_INUM (x
);
3869 scm_t_inum yy
= SCM_I_INUM (y
);
3870 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3871 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3881 /* Determine a common factor 2^k */
3882 while (!(1 & (u
| v
)))
3888 /* Now, any factor 2^n can be eliminated */
3908 return (SCM_POSFIXABLE (result
)
3909 ? SCM_I_MAKINUM (result
)
3910 : scm_i_inum2big (result
));
3912 else if (SCM_BIGP (y
))
3918 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3920 else if (SCM_BIGP (x
))
3922 if (SCM_I_INUMP (y
))
3927 yy
= SCM_I_INUM (y
);
3932 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3933 scm_remember_upto_here_1 (x
);
3934 return (SCM_POSFIXABLE (result
)
3935 ? SCM_I_MAKINUM (result
)
3936 : scm_from_unsigned_integer (result
));
3938 else if (SCM_BIGP (y
))
3940 SCM result
= scm_i_mkbig ();
3941 mpz_gcd (SCM_I_BIG_MPZ (result
),
3944 scm_remember_upto_here_2 (x
, y
);
3945 return scm_i_normbig (result
);
3948 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3951 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3954 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3955 (SCM x
, SCM y
, SCM rest
),
3956 "Return the least common multiple of the arguments.\n"
3957 "If called without arguments, 1 is returned.")
3958 #define FUNC_NAME s_scm_i_lcm
3960 while (!scm_is_null (rest
))
3961 { x
= scm_lcm (x
, y
);
3963 rest
= scm_cdr (rest
);
3965 return scm_lcm (x
, y
);
3969 #define s_lcm s_scm_i_lcm
3970 #define g_lcm g_scm_i_lcm
3973 scm_lcm (SCM n1
, SCM n2
)
3975 if (SCM_UNBNDP (n2
))
3977 if (SCM_UNBNDP (n1
))
3978 return SCM_I_MAKINUM (1L);
3979 n2
= SCM_I_MAKINUM (1L);
3982 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
3983 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
3984 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
3985 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
3987 if (SCM_I_INUMP (n1
))
3989 if (SCM_I_INUMP (n2
))
3991 SCM d
= scm_gcd (n1
, n2
);
3992 if (scm_is_eq (d
, SCM_INUM0
))
3995 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
3999 /* inum n1, big n2 */
4002 SCM result
= scm_i_mkbig ();
4003 scm_t_inum nn1
= SCM_I_INUM (n1
);
4004 if (nn1
== 0) return SCM_INUM0
;
4005 if (nn1
< 0) nn1
= - nn1
;
4006 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4007 scm_remember_upto_here_1 (n2
);
4015 if (SCM_I_INUMP (n2
))
4022 SCM result
= scm_i_mkbig ();
4023 mpz_lcm(SCM_I_BIG_MPZ (result
),
4025 SCM_I_BIG_MPZ (n2
));
4026 scm_remember_upto_here_2(n1
, n2
);
4027 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4033 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4038 + + + x (map digit:logand X Y)
4039 + - + x (map digit:logand X (lognot (+ -1 Y)))
4040 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4041 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4046 + + + (map digit:logior X Y)
4047 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4048 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4049 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4054 + + + (map digit:logxor X Y)
4055 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4056 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4057 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4062 + + (any digit:logand X Y)
4063 + - (any digit:logand X (lognot (+ -1 Y)))
4064 - + (any digit:logand (lognot (+ -1 X)) Y)
4069 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4070 (SCM x
, SCM y
, SCM rest
),
4071 "Return the bitwise AND of the integer arguments.\n\n"
4073 "(logand) @result{} -1\n"
4074 "(logand 7) @result{} 7\n"
4075 "(logand #b111 #b011 #b001) @result{} 1\n"
4077 #define FUNC_NAME s_scm_i_logand
4079 while (!scm_is_null (rest
))
4080 { x
= scm_logand (x
, y
);
4082 rest
= scm_cdr (rest
);
4084 return scm_logand (x
, y
);
4088 #define s_scm_logand s_scm_i_logand
4090 SCM
scm_logand (SCM n1
, SCM n2
)
4091 #define FUNC_NAME s_scm_logand
4095 if (SCM_UNBNDP (n2
))
4097 if (SCM_UNBNDP (n1
))
4098 return SCM_I_MAKINUM (-1);
4099 else if (!SCM_NUMBERP (n1
))
4100 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4101 else if (SCM_NUMBERP (n1
))
4104 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4107 if (SCM_I_INUMP (n1
))
4109 nn1
= SCM_I_INUM (n1
);
4110 if (SCM_I_INUMP (n2
))
4112 scm_t_inum nn2
= SCM_I_INUM (n2
);
4113 return SCM_I_MAKINUM (nn1
& nn2
);
4115 else if SCM_BIGP (n2
)
4121 SCM result_z
= scm_i_mkbig ();
4123 mpz_init_set_si (nn1_z
, nn1
);
4124 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4125 scm_remember_upto_here_1 (n2
);
4127 return scm_i_normbig (result_z
);
4131 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4133 else if (SCM_BIGP (n1
))
4135 if (SCM_I_INUMP (n2
))
4138 nn1
= SCM_I_INUM (n1
);
4141 else if (SCM_BIGP (n2
))
4143 SCM result_z
= scm_i_mkbig ();
4144 mpz_and (SCM_I_BIG_MPZ (result_z
),
4146 SCM_I_BIG_MPZ (n2
));
4147 scm_remember_upto_here_2 (n1
, n2
);
4148 return scm_i_normbig (result_z
);
4151 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4154 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4159 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4160 (SCM x
, SCM y
, SCM rest
),
4161 "Return the bitwise OR of the integer arguments.\n\n"
4163 "(logior) @result{} 0\n"
4164 "(logior 7) @result{} 7\n"
4165 "(logior #b000 #b001 #b011) @result{} 3\n"
4167 #define FUNC_NAME s_scm_i_logior
4169 while (!scm_is_null (rest
))
4170 { x
= scm_logior (x
, y
);
4172 rest
= scm_cdr (rest
);
4174 return scm_logior (x
, y
);
4178 #define s_scm_logior s_scm_i_logior
4180 SCM
scm_logior (SCM n1
, SCM n2
)
4181 #define FUNC_NAME s_scm_logior
4185 if (SCM_UNBNDP (n2
))
4187 if (SCM_UNBNDP (n1
))
4189 else if (SCM_NUMBERP (n1
))
4192 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4195 if (SCM_I_INUMP (n1
))
4197 nn1
= SCM_I_INUM (n1
);
4198 if (SCM_I_INUMP (n2
))
4200 long nn2
= SCM_I_INUM (n2
);
4201 return SCM_I_MAKINUM (nn1
| nn2
);
4203 else if (SCM_BIGP (n2
))
4209 SCM result_z
= scm_i_mkbig ();
4211 mpz_init_set_si (nn1_z
, nn1
);
4212 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4213 scm_remember_upto_here_1 (n2
);
4215 return scm_i_normbig (result_z
);
4219 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4221 else if (SCM_BIGP (n1
))
4223 if (SCM_I_INUMP (n2
))
4226 nn1
= SCM_I_INUM (n1
);
4229 else if (SCM_BIGP (n2
))
4231 SCM result_z
= scm_i_mkbig ();
4232 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4234 SCM_I_BIG_MPZ (n2
));
4235 scm_remember_upto_here_2 (n1
, n2
);
4236 return scm_i_normbig (result_z
);
4239 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4242 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4247 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4248 (SCM x
, SCM y
, SCM rest
),
4249 "Return the bitwise XOR of the integer arguments. A bit is\n"
4250 "set in the result if it is set in an odd number of arguments.\n"
4252 "(logxor) @result{} 0\n"
4253 "(logxor 7) @result{} 7\n"
4254 "(logxor #b000 #b001 #b011) @result{} 2\n"
4255 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4257 #define FUNC_NAME s_scm_i_logxor
4259 while (!scm_is_null (rest
))
4260 { x
= scm_logxor (x
, y
);
4262 rest
= scm_cdr (rest
);
4264 return scm_logxor (x
, y
);
4268 #define s_scm_logxor s_scm_i_logxor
4270 SCM
scm_logxor (SCM n1
, SCM n2
)
4271 #define FUNC_NAME s_scm_logxor
4275 if (SCM_UNBNDP (n2
))
4277 if (SCM_UNBNDP (n1
))
4279 else if (SCM_NUMBERP (n1
))
4282 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4285 if (SCM_I_INUMP (n1
))
4287 nn1
= SCM_I_INUM (n1
);
4288 if (SCM_I_INUMP (n2
))
4290 scm_t_inum nn2
= SCM_I_INUM (n2
);
4291 return SCM_I_MAKINUM (nn1
^ nn2
);
4293 else if (SCM_BIGP (n2
))
4297 SCM result_z
= scm_i_mkbig ();
4299 mpz_init_set_si (nn1_z
, nn1
);
4300 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4301 scm_remember_upto_here_1 (n2
);
4303 return scm_i_normbig (result_z
);
4307 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4309 else if (SCM_BIGP (n1
))
4311 if (SCM_I_INUMP (n2
))
4314 nn1
= SCM_I_INUM (n1
);
4317 else if (SCM_BIGP (n2
))
4319 SCM result_z
= scm_i_mkbig ();
4320 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4322 SCM_I_BIG_MPZ (n2
));
4323 scm_remember_upto_here_2 (n1
, n2
);
4324 return scm_i_normbig (result_z
);
4327 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4330 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4335 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4337 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4338 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4339 "without actually calculating the @code{logand}, just testing\n"
4343 "(logtest #b0100 #b1011) @result{} #f\n"
4344 "(logtest #b0100 #b0111) @result{} #t\n"
4346 #define FUNC_NAME s_scm_logtest
4350 if (SCM_I_INUMP (j
))
4352 nj
= SCM_I_INUM (j
);
4353 if (SCM_I_INUMP (k
))
4355 scm_t_inum nk
= SCM_I_INUM (k
);
4356 return scm_from_bool (nj
& nk
);
4358 else if (SCM_BIGP (k
))
4366 mpz_init_set_si (nj_z
, nj
);
4367 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4368 scm_remember_upto_here_1 (k
);
4369 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4375 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4377 else if (SCM_BIGP (j
))
4379 if (SCM_I_INUMP (k
))
4382 nj
= SCM_I_INUM (j
);
4385 else if (SCM_BIGP (k
))
4389 mpz_init (result_z
);
4393 scm_remember_upto_here_2 (j
, k
);
4394 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4395 mpz_clear (result_z
);
4399 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4402 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4407 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4409 "Test whether bit number @var{index} in @var{j} is set.\n"
4410 "@var{index} starts from 0 for the least significant bit.\n"
4413 "(logbit? 0 #b1101) @result{} #t\n"
4414 "(logbit? 1 #b1101) @result{} #f\n"
4415 "(logbit? 2 #b1101) @result{} #t\n"
4416 "(logbit? 3 #b1101) @result{} #t\n"
4417 "(logbit? 4 #b1101) @result{} #f\n"
4419 #define FUNC_NAME s_scm_logbit_p
4421 unsigned long int iindex
;
4422 iindex
= scm_to_ulong (index
);
4424 if (SCM_I_INUMP (j
))
4426 /* bits above what's in an inum follow the sign bit */
4427 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4428 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4430 else if (SCM_BIGP (j
))
4432 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4433 scm_remember_upto_here_1 (j
);
4434 return scm_from_bool (val
);
4437 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4442 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4444 "Return the integer which is the ones-complement of the integer\n"
4448 "(number->string (lognot #b10000000) 2)\n"
4449 " @result{} \"-10000001\"\n"
4450 "(number->string (lognot #b0) 2)\n"
4451 " @result{} \"-1\"\n"
4453 #define FUNC_NAME s_scm_lognot
4455 if (SCM_I_INUMP (n
)) {
4456 /* No overflow here, just need to toggle all the bits making up the inum.
4457 Enhancement: No need to strip the tag and add it back, could just xor
4458 a block of 1 bits, if that worked with the various debug versions of
4460 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4462 } else if (SCM_BIGP (n
)) {
4463 SCM result
= scm_i_mkbig ();
4464 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4465 scm_remember_upto_here_1 (n
);
4469 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4474 /* returns 0 if IN is not an integer. OUT must already be
4477 coerce_to_big (SCM in
, mpz_t out
)
4480 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4481 else if (SCM_I_INUMP (in
))
4482 mpz_set_si (out
, SCM_I_INUM (in
));
4489 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4490 (SCM n
, SCM k
, SCM m
),
4491 "Return @var{n} raised to the integer exponent\n"
4492 "@var{k}, modulo @var{m}.\n"
4495 "(modulo-expt 2 3 5)\n"
4498 #define FUNC_NAME s_scm_modulo_expt
4504 /* There are two classes of error we might encounter --
4505 1) Math errors, which we'll report by calling scm_num_overflow,
4507 2) wrong-type errors, which of course we'll report by calling
4509 We don't report those errors immediately, however; instead we do
4510 some cleanup first. These variables tell us which error (if
4511 any) we should report after cleaning up.
4513 int report_overflow
= 0;
4515 int position_of_wrong_type
= 0;
4516 SCM value_of_wrong_type
= SCM_INUM0
;
4518 SCM result
= SCM_UNDEFINED
;
4524 if (scm_is_eq (m
, SCM_INUM0
))
4526 report_overflow
= 1;
4530 if (!coerce_to_big (n
, n_tmp
))
4532 value_of_wrong_type
= n
;
4533 position_of_wrong_type
= 1;
4537 if (!coerce_to_big (k
, k_tmp
))
4539 value_of_wrong_type
= k
;
4540 position_of_wrong_type
= 2;
4544 if (!coerce_to_big (m
, m_tmp
))
4546 value_of_wrong_type
= m
;
4547 position_of_wrong_type
= 3;
4551 /* if the exponent K is negative, and we simply call mpz_powm, we
4552 will get a divide-by-zero exception when an inverse 1/n mod m
4553 doesn't exist (or is not unique). Since exceptions are hard to
4554 handle, we'll attempt the inversion "by hand" -- that way, we get
4555 a simple failure code, which is easy to handle. */
4557 if (-1 == mpz_sgn (k_tmp
))
4559 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4561 report_overflow
= 1;
4564 mpz_neg (k_tmp
, k_tmp
);
4567 result
= scm_i_mkbig ();
4568 mpz_powm (SCM_I_BIG_MPZ (result
),
4573 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4574 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4581 if (report_overflow
)
4582 scm_num_overflow (FUNC_NAME
);
4584 if (position_of_wrong_type
)
4585 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4586 value_of_wrong_type
);
4588 return scm_i_normbig (result
);
4592 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4594 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4595 "exact integer, @var{n} can be any number.\n"
4597 "Negative @var{k} is supported, and results in\n"
4598 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4599 "@math{@var{n}^0} is 1, as usual, and that\n"
4600 "includes @math{0^0} is 1.\n"
4603 "(integer-expt 2 5) @result{} 32\n"
4604 "(integer-expt -3 3) @result{} -27\n"
4605 "(integer-expt 5 -3) @result{} 1/125\n"
4606 "(integer-expt 0 0) @result{} 1\n"
4608 #define FUNC_NAME s_scm_integer_expt
4611 SCM z_i2
= SCM_BOOL_F
;
4613 SCM acc
= SCM_I_MAKINUM (1L);
4615 /* Specifically refrain from checking the type of the first argument.
4616 This allows us to exponentiate any object that can be multiplied.
4617 If we must raise to a negative power, we must also be able to
4618 take its reciprocal. */
4619 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4620 SCM_WRONG_TYPE_ARG (2, k
);
4622 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4623 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4624 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4625 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4626 /* The next check is necessary only because R6RS specifies different
4627 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4628 we simply skip this case and move on. */
4629 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4631 /* k cannot be 0 at this point, because we
4632 have already checked for that case above */
4633 if (scm_is_true (scm_positive_p (k
)))
4635 else /* return NaN for (0 ^ k) for negative k per R6RS */
4639 if (SCM_I_INUMP (k
))
4640 i2
= SCM_I_INUM (k
);
4641 else if (SCM_BIGP (k
))
4643 z_i2
= scm_i_clonebig (k
, 1);
4644 scm_remember_upto_here_1 (k
);
4648 SCM_WRONG_TYPE_ARG (2, k
);
4652 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4654 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4655 n
= scm_divide (n
, SCM_UNDEFINED
);
4659 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4663 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4665 return scm_product (acc
, n
);
4667 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4668 acc
= scm_product (acc
, n
);
4669 n
= scm_product (n
, n
);
4670 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4678 n
= scm_divide (n
, SCM_UNDEFINED
);
4685 return scm_product (acc
, n
);
4687 acc
= scm_product (acc
, n
);
4688 n
= scm_product (n
, n
);
4695 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4697 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4698 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4700 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4701 "@var{cnt} is negative it's a division, rounded towards negative\n"
4702 "infinity. (Note that this is not the same rounding as\n"
4703 "@code{quotient} does.)\n"
4705 "With @var{n} viewed as an infinite precision twos complement,\n"
4706 "@code{ash} means a left shift introducing zero bits, or a right\n"
4707 "shift dropping bits.\n"
4710 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4711 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4713 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4714 "(ash -23 -2) @result{} -6\n"
4716 #define FUNC_NAME s_scm_ash
4719 bits_to_shift
= scm_to_long (cnt
);
4721 if (SCM_I_INUMP (n
))
4723 scm_t_inum nn
= SCM_I_INUM (n
);
4725 if (bits_to_shift
> 0)
4727 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4728 overflow a non-zero fixnum. For smaller shifts we check the
4729 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4730 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4731 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4737 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4739 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4742 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4746 SCM result
= scm_i_inum2big (nn
);
4747 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4754 bits_to_shift
= -bits_to_shift
;
4755 if (bits_to_shift
>= SCM_LONG_BIT
)
4756 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4758 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4762 else if (SCM_BIGP (n
))
4766 if (bits_to_shift
== 0)
4769 result
= scm_i_mkbig ();
4770 if (bits_to_shift
>= 0)
4772 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4778 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4779 we have to allocate a bignum even if the result is going to be a
4781 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4783 return scm_i_normbig (result
);
4789 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4795 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4796 (SCM n
, SCM start
, SCM end
),
4797 "Return the integer composed of the @var{start} (inclusive)\n"
4798 "through @var{end} (exclusive) bits of @var{n}. The\n"
4799 "@var{start}th bit becomes the 0-th bit in the result.\n"
4802 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4803 " @result{} \"1010\"\n"
4804 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4805 " @result{} \"10110\"\n"
4807 #define FUNC_NAME s_scm_bit_extract
4809 unsigned long int istart
, iend
, bits
;
4810 istart
= scm_to_ulong (start
);
4811 iend
= scm_to_ulong (end
);
4812 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4814 /* how many bits to keep */
4815 bits
= iend
- istart
;
4817 if (SCM_I_INUMP (n
))
4819 scm_t_inum in
= SCM_I_INUM (n
);
4821 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4822 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4823 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4825 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4827 /* Since we emulate two's complement encoded numbers, this
4828 * special case requires us to produce a result that has
4829 * more bits than can be stored in a fixnum.
4831 SCM result
= scm_i_inum2big (in
);
4832 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4837 /* mask down to requisite bits */
4838 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4839 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4841 else if (SCM_BIGP (n
))
4846 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4850 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4851 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4852 such bits into a ulong. */
4853 result
= scm_i_mkbig ();
4854 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4855 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4856 result
= scm_i_normbig (result
);
4858 scm_remember_upto_here_1 (n
);
4862 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4867 static const char scm_logtab
[] = {
4868 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4871 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4873 "Return the number of bits in integer @var{n}. If integer is\n"
4874 "positive, the 1-bits in its binary representation are counted.\n"
4875 "If negative, the 0-bits in its two's-complement binary\n"
4876 "representation are counted. If 0, 0 is returned.\n"
4879 "(logcount #b10101010)\n"
4886 #define FUNC_NAME s_scm_logcount
4888 if (SCM_I_INUMP (n
))
4890 unsigned long c
= 0;
4891 scm_t_inum nn
= SCM_I_INUM (n
);
4896 c
+= scm_logtab
[15 & nn
];
4899 return SCM_I_MAKINUM (c
);
4901 else if (SCM_BIGP (n
))
4903 unsigned long count
;
4904 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4905 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4907 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4908 scm_remember_upto_here_1 (n
);
4909 return SCM_I_MAKINUM (count
);
4912 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4917 static const char scm_ilentab
[] = {
4918 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4922 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4924 "Return the number of bits necessary to represent @var{n}.\n"
4927 "(integer-length #b10101010)\n"
4929 "(integer-length 0)\n"
4931 "(integer-length #b1111)\n"
4934 #define FUNC_NAME s_scm_integer_length
4936 if (SCM_I_INUMP (n
))
4938 unsigned long c
= 0;
4940 scm_t_inum nn
= SCM_I_INUM (n
);
4946 l
= scm_ilentab
[15 & nn
];
4949 return SCM_I_MAKINUM (c
- 4 + l
);
4951 else if (SCM_BIGP (n
))
4953 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4954 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4955 1 too big, so check for that and adjust. */
4956 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4957 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4958 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4959 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4961 scm_remember_upto_here_1 (n
);
4962 return SCM_I_MAKINUM (size
);
4965 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4969 /*** NUMBERS -> STRINGS ***/
4970 #define SCM_MAX_DBL_PREC 60
4971 #define SCM_MAX_DBL_RADIX 36
4973 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
4974 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
4975 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
4978 void init_dblprec(int *prec
, int radix
) {
4979 /* determine floating point precision by adding successively
4980 smaller increments to 1.0 until it is considered == 1.0 */
4981 double f
= ((double)1.0)/radix
;
4982 double fsum
= 1.0 + f
;
4987 if (++(*prec
) > SCM_MAX_DBL_PREC
)
4999 void init_fx_radix(double *fx_list
, int radix
)
5001 /* initialize a per-radix list of tolerances. When added
5002 to a number < 1.0, we can determine if we should raund
5003 up and quit converting a number to a string. */
5007 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5008 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5011 /* use this array as a way to generate a single digit */
5012 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5015 idbl2str (double f
, char *a
, int radix
)
5017 int efmt
, dpt
, d
, i
, wp
;
5019 #ifdef DBL_MIN_10_EXP
5022 #endif /* DBL_MIN_10_EXP */
5027 radix
> SCM_MAX_DBL_RADIX
)
5029 /* revert to existing behavior */
5033 wp
= scm_dblprec
[radix
-2];
5034 fx
= fx_per_radix
[radix
-2];
5038 #ifdef HAVE_COPYSIGN
5039 double sgn
= copysign (1.0, f
);
5044 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5050 strcpy (a
, "-inf.0");
5052 strcpy (a
, "+inf.0");
5057 strcpy (a
, "+nan.0");
5067 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5068 make-uniform-vector, from causing infinite loops. */
5069 /* just do the checking...if it passes, we do the conversion for our
5070 radix again below */
5077 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5085 while (f_cpy
> 10.0)
5088 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5109 if (f
+ fx
[wp
] >= radix
)
5116 /* adding 9999 makes this equivalent to abs(x) % 3 */
5117 dpt
= (exp
+ 9999) % 3;
5121 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5143 a
[ch
++] = number_chars
[d
];
5146 if (f
+ fx
[wp
] >= 1.0)
5148 a
[ch
- 1] = number_chars
[d
+1];
5160 if ((dpt
> 4) && (exp
> 6))
5162 d
= (a
[0] == '-' ? 2 : 1);
5163 for (i
= ch
++; i
> d
; i
--)
5176 if (a
[ch
- 1] == '.')
5177 a
[ch
++] = '0'; /* trailing zero */
5186 for (i
= radix
; i
<= exp
; i
*= radix
);
5187 for (i
/= radix
; i
; i
/= radix
)
5189 a
[ch
++] = number_chars
[exp
/ i
];
5198 icmplx2str (double real
, double imag
, char *str
, int radix
)
5203 i
= idbl2str (real
, str
, radix
);
5204 #ifdef HAVE_COPYSIGN
5205 sgn
= copysign (1.0, imag
);
5209 /* Don't output a '+' for negative numbers or for Inf and
5210 NaN. They will provide their own sign. */
5211 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5213 i
+= idbl2str (imag
, &str
[i
], radix
);
5219 iflo2str (SCM flt
, char *str
, int radix
)
5222 if (SCM_REALP (flt
))
5223 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5225 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5230 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5231 characters in the result.
5233 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5235 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5240 return scm_iuint2str (-num
, rad
, p
) + 1;
5243 return scm_iuint2str (num
, rad
, p
);
5246 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5247 characters in the result.
5249 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5251 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5255 scm_t_uintmax n
= num
;
5257 if (rad
< 2 || rad
> 36)
5258 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5260 for (n
/= rad
; n
> 0; n
/= rad
)
5270 p
[i
] = number_chars
[d
];
5275 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5277 "Return a string holding the external representation of the\n"
5278 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5279 "inexact, a radix of 10 will be used.")
5280 #define FUNC_NAME s_scm_number_to_string
5284 if (SCM_UNBNDP (radix
))
5287 base
= scm_to_signed_integer (radix
, 2, 36);
5289 if (SCM_I_INUMP (n
))
5291 char num_buf
[SCM_INTBUFLEN
];
5292 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5293 return scm_from_locale_stringn (num_buf
, length
);
5295 else if (SCM_BIGP (n
))
5297 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5298 scm_remember_upto_here_1 (n
);
5299 return scm_take_locale_string (str
);
5301 else if (SCM_FRACTIONP (n
))
5303 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5304 scm_from_locale_string ("/"),
5305 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5307 else if (SCM_INEXACTP (n
))
5309 char num_buf
[FLOBUFLEN
];
5310 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5313 SCM_WRONG_TYPE_ARG (1, n
);
5318 /* These print routines used to be stubbed here so that scm_repl.c
5319 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5322 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5324 char num_buf
[FLOBUFLEN
];
5325 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5330 scm_i_print_double (double val
, SCM port
)
5332 char num_buf
[FLOBUFLEN
];
5333 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5337 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5340 char num_buf
[FLOBUFLEN
];
5341 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5346 scm_i_print_complex (double real
, double imag
, SCM port
)
5348 char num_buf
[FLOBUFLEN
];
5349 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5353 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5356 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5357 scm_display (str
, port
);
5358 scm_remember_upto_here_1 (str
);
5363 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5365 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5366 scm_remember_upto_here_1 (exp
);
5367 scm_lfwrite (str
, (size_t) strlen (str
), port
);
5371 /*** END nums->strs ***/
5374 /*** STRINGS -> NUMBERS ***/
5376 /* The following functions implement the conversion from strings to numbers.
5377 * The implementation somehow follows the grammar for numbers as it is given
5378 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5379 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5380 * points should be noted about the implementation:
5382 * * Each function keeps a local index variable 'idx' that points at the
5383 * current position within the parsed string. The global index is only
5384 * updated if the function could parse the corresponding syntactic unit
5387 * * Similarly, the functions keep track of indicators of inexactness ('#',
5388 * '.' or exponents) using local variables ('hash_seen', 'x').
5390 * * Sequences of digits are parsed into temporary variables holding fixnums.
5391 * Only if these fixnums would overflow, the result variables are updated
5392 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5393 * the temporary variables holding the fixnums are cleared, and the process
5394 * starts over again. If for example fixnums were able to store five decimal
5395 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5396 * and the result was computed as 12345 * 100000 + 67890. In other words,
5397 * only every five digits two bignum operations were performed.
5399 * Notes on the handling of exactness specifiers:
5401 * When parsing non-real complex numbers, we apply exactness specifiers on
5402 * per-component basis, as is done in PLT Scheme. For complex numbers
5403 * written in rectangular form, exactness specifiers are applied to the
5404 * real and imaginary parts before calling scm_make_rectangular. For
5405 * complex numbers written in polar form, exactness specifiers are applied
5406 * to the magnitude and angle before calling scm_make_polar.
5408 * There are two kinds of exactness specifiers: forced and implicit. A
5409 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5410 * the entire number, and applies to both components of a complex number.
5411 * "#e" causes each component to be made exact, and "#i" causes each
5412 * component to be made inexact. If no forced exactness specifier is
5413 * present, then the exactness of each component is determined
5414 * independently by the presence or absence of a decimal point or hash mark
5415 * within that component. If a decimal point or hash mark is present, the
5416 * component is made inexact, otherwise it is made exact.
5418 * After the exactness specifiers have been applied to each component, they
5419 * are passed to either scm_make_rectangular or scm_make_polar to produce
5420 * the final result. Note that this will result in a real number if the
5421 * imaginary part, magnitude, or angle is an exact 0.
5423 * For example, (string->number "#i5.0+0i") does the equivalent of:
5425 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5428 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5430 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5432 /* Caller is responsible for checking that the return value is in range
5433 for the given radix, which should be <= 36. */
5435 char_decimal_value (scm_t_uint32 c
)
5437 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5438 that's certainly above any valid decimal, so we take advantage of
5439 that to elide some tests. */
5440 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5442 /* If that failed, try extended hexadecimals, then. Only accept ascii
5447 if (c
>= (scm_t_uint32
) 'a')
5448 d
= c
- (scm_t_uint32
)'a' + 10U;
5454 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5455 unsigned int radix
, enum t_exactness
*p_exactness
)
5457 unsigned int idx
= *p_idx
;
5458 unsigned int hash_seen
= 0;
5459 scm_t_bits shift
= 1;
5461 unsigned int digit_value
;
5464 size_t len
= scm_i_string_length (mem
);
5469 c
= scm_i_string_ref (mem
, idx
);
5470 digit_value
= char_decimal_value (c
);
5471 if (digit_value
>= radix
)
5475 result
= SCM_I_MAKINUM (digit_value
);
5478 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5488 digit_value
= char_decimal_value (c
);
5489 /* This check catches non-decimals in addition to out-of-range
5491 if (digit_value
>= radix
)
5496 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5498 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5500 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5507 shift
= shift
* radix
;
5508 add
= add
* radix
+ digit_value
;
5513 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5515 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5519 *p_exactness
= INEXACT
;
5525 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5526 * covers the parts of the rules that start at a potential point. The value
5527 * of the digits up to the point have been parsed by the caller and are given
5528 * in variable result. The content of *p_exactness indicates, whether a hash
5529 * has already been seen in the digits before the point.
5532 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5535 mem2decimal_from_point (SCM result
, SCM mem
,
5536 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5538 unsigned int idx
= *p_idx
;
5539 enum t_exactness x
= *p_exactness
;
5540 size_t len
= scm_i_string_length (mem
);
5545 if (scm_i_string_ref (mem
, idx
) == '.')
5547 scm_t_bits shift
= 1;
5549 unsigned int digit_value
;
5550 SCM big_shift
= SCM_INUM1
;
5555 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5556 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5561 digit_value
= DIGIT2UINT (c
);
5572 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5574 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5575 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5577 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5585 add
= add
* 10 + digit_value
;
5591 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5592 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5593 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5596 result
= scm_divide (result
, big_shift
);
5598 /* We've seen a decimal point, thus the value is implicitly inexact. */
5610 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5612 switch (scm_i_string_ref (mem
, idx
))
5624 c
= scm_i_string_ref (mem
, idx
);
5632 c
= scm_i_string_ref (mem
, idx
);
5641 c
= scm_i_string_ref (mem
, idx
);
5646 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5650 exponent
= DIGIT2UINT (c
);
5653 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5654 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5657 if (exponent
<= SCM_MAXEXP
)
5658 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5664 if (exponent
> SCM_MAXEXP
)
5666 size_t exp_len
= idx
- start
;
5667 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5668 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5669 scm_out_of_range ("string->number", exp_num
);
5672 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5674 result
= scm_product (result
, e
);
5676 result
= scm_divide (result
, e
);
5678 /* We've seen an exponent, thus the value is implicitly inexact. */
5696 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5699 mem2ureal (SCM mem
, unsigned int *p_idx
,
5700 unsigned int radix
, enum t_exactness forced_x
)
5702 unsigned int idx
= *p_idx
;
5704 size_t len
= scm_i_string_length (mem
);
5706 /* Start off believing that the number will be exact. This changes
5707 to INEXACT if we see a decimal point or a hash. */
5708 enum t_exactness implicit_x
= EXACT
;
5713 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5719 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5721 /* Cobble up the fractional part. We might want to set the
5722 NaN's mantissa from it. */
5724 mem2uinteger (mem
, &idx
, 10, &implicit_x
);
5729 if (scm_i_string_ref (mem
, idx
) == '.')
5733 else if (idx
+ 1 == len
)
5735 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5738 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5739 p_idx
, &implicit_x
);
5745 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5746 if (scm_is_false (uinteger
))
5751 else if (scm_i_string_ref (mem
, idx
) == '/')
5759 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5760 if (scm_is_false (divisor
))
5763 /* both are int/big here, I assume */
5764 result
= scm_i_make_ratio (uinteger
, divisor
);
5766 else if (radix
== 10)
5768 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5769 if (scm_is_false (result
))
5781 if (SCM_INEXACTP (result
))
5782 return scm_inexact_to_exact (result
);
5786 if (SCM_INEXACTP (result
))
5789 return scm_exact_to_inexact (result
);
5791 if (implicit_x
== INEXACT
)
5793 if (SCM_INEXACTP (result
))
5796 return scm_exact_to_inexact (result
);
5802 /* We should never get here */
5803 scm_syserror ("mem2ureal");
5807 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5810 mem2complex (SCM mem
, unsigned int idx
,
5811 unsigned int radix
, enum t_exactness forced_x
)
5816 size_t len
= scm_i_string_length (mem
);
5821 c
= scm_i_string_ref (mem
, idx
);
5836 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5837 if (scm_is_false (ureal
))
5839 /* input must be either +i or -i */
5844 if (scm_i_string_ref (mem
, idx
) == 'i'
5845 || scm_i_string_ref (mem
, idx
) == 'I')
5851 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5858 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5859 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5864 c
= scm_i_string_ref (mem
, idx
);
5868 /* either +<ureal>i or -<ureal>i */
5875 return scm_make_rectangular (SCM_INUM0
, ureal
);
5878 /* polar input: <real>@<real>. */
5889 c
= scm_i_string_ref (mem
, idx
);
5907 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5908 if (scm_is_false (angle
))
5913 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5914 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5916 result
= scm_make_polar (ureal
, angle
);
5921 /* expecting input matching <real>[+-]<ureal>?i */
5928 int sign
= (c
== '+') ? 1 : -1;
5929 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5931 if (scm_is_false (imag
))
5932 imag
= SCM_I_MAKINUM (sign
);
5933 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5934 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5938 if (scm_i_string_ref (mem
, idx
) != 'i'
5939 && scm_i_string_ref (mem
, idx
) != 'I')
5946 return scm_make_rectangular (ureal
, imag
);
5955 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
5957 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
5960 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
5962 unsigned int idx
= 0;
5963 unsigned int radix
= NO_RADIX
;
5964 enum t_exactness forced_x
= NO_EXACTNESS
;
5965 size_t len
= scm_i_string_length (mem
);
5967 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
5968 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
5970 switch (scm_i_string_ref (mem
, idx
+ 1))
5973 if (radix
!= NO_RADIX
)
5978 if (radix
!= NO_RADIX
)
5983 if (forced_x
!= NO_EXACTNESS
)
5988 if (forced_x
!= NO_EXACTNESS
)
5993 if (radix
!= NO_RADIX
)
5998 if (radix
!= NO_RADIX
)
6008 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6009 if (radix
== NO_RADIX
)
6010 radix
= default_radix
;
6012 return mem2complex (mem
, idx
, radix
, forced_x
);
6016 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6017 unsigned int default_radix
)
6019 SCM str
= scm_from_locale_stringn (mem
, len
);
6021 return scm_i_string_to_number (str
, default_radix
);
6025 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6026 (SCM string
, SCM radix
),
6027 "Return a number of the maximally precise representation\n"
6028 "expressed by the given @var{string}. @var{radix} must be an\n"
6029 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6030 "is a default radix that may be overridden by an explicit radix\n"
6031 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6032 "supplied, then the default radix is 10. If string is not a\n"
6033 "syntactically valid notation for a number, then\n"
6034 "@code{string->number} returns @code{#f}.")
6035 #define FUNC_NAME s_scm_string_to_number
6039 SCM_VALIDATE_STRING (1, string
);
6041 if (SCM_UNBNDP (radix
))
6044 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6046 answer
= scm_i_string_to_number (string
, base
);
6047 scm_remember_upto_here_1 (string
);
6053 /*** END strs->nums ***/
6056 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6058 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6060 #define FUNC_NAME s_scm_number_p
6062 return scm_from_bool (SCM_NUMBERP (x
));
6066 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6068 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6069 "otherwise. Note that the sets of real, rational and integer\n"
6070 "values form subsets of the set of complex numbers, i. e. the\n"
6071 "predicate will also be fulfilled if @var{x} is a real,\n"
6072 "rational or integer number.")
6073 #define FUNC_NAME s_scm_complex_p
6075 /* all numbers are complex. */
6076 return scm_number_p (x
);
6080 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6082 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6083 "otherwise. Note that the set of integer values forms a subset of\n"
6084 "the set of real numbers, i. e. the predicate will also be\n"
6085 "fulfilled if @var{x} is an integer number.")
6086 #define FUNC_NAME s_scm_real_p
6088 return scm_from_bool
6089 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6093 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6095 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6096 "otherwise. Note that the set of integer values forms a subset of\n"
6097 "the set of rational numbers, i. e. the predicate will also be\n"
6098 "fulfilled if @var{x} is an integer number.")
6099 #define FUNC_NAME s_scm_rational_p
6101 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6103 else if (SCM_REALP (x
))
6104 /* due to their limited precision, finite floating point numbers are
6105 rational as well. (finite means neither infinity nor a NaN) */
6106 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6112 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6114 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6116 #define FUNC_NAME s_scm_integer_p
6118 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6120 else if (SCM_REALP (x
))
6122 double val
= SCM_REAL_VALUE (x
);
6123 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6131 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6132 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6133 (SCM x
, SCM y
, SCM rest
),
6134 "Return @code{#t} if all parameters are numerically equal.")
6135 #define FUNC_NAME s_scm_i_num_eq_p
6137 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6139 while (!scm_is_null (rest
))
6141 if (scm_is_false (scm_num_eq_p (x
, y
)))
6145 rest
= scm_cdr (rest
);
6147 return scm_num_eq_p (x
, y
);
6151 scm_num_eq_p (SCM x
, SCM y
)
6154 if (SCM_I_INUMP (x
))
6156 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6157 if (SCM_I_INUMP (y
))
6159 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6160 return scm_from_bool (xx
== yy
);
6162 else if (SCM_BIGP (y
))
6164 else if (SCM_REALP (y
))
6166 /* On a 32-bit system an inum fits a double, we can cast the inum
6167 to a double and compare.
6169 But on a 64-bit system an inum is bigger than a double and
6170 casting it to a double (call that dxx) will round. dxx is at
6171 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6172 an integer and fits a long. So we cast yy to a long and
6173 compare with plain xx.
6175 An alternative (for any size system actually) would be to check
6176 yy is an integer (with floor) and is in range of an inum
6177 (compare against appropriate powers of 2) then test
6178 xx==(scm_t_signed_bits)yy. It's just a matter of which
6179 casts/comparisons might be fastest or easiest for the cpu. */
6181 double yy
= SCM_REAL_VALUE (y
);
6182 return scm_from_bool ((double) xx
== yy
6183 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6184 || xx
== (scm_t_signed_bits
) yy
));
6186 else if (SCM_COMPLEXP (y
))
6187 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6188 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6189 else if (SCM_FRACTIONP (y
))
6192 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6194 else if (SCM_BIGP (x
))
6196 if (SCM_I_INUMP (y
))
6198 else if (SCM_BIGP (y
))
6200 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6201 scm_remember_upto_here_2 (x
, y
);
6202 return scm_from_bool (0 == cmp
);
6204 else if (SCM_REALP (y
))
6207 if (isnan (SCM_REAL_VALUE (y
)))
6209 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6210 scm_remember_upto_here_1 (x
);
6211 return scm_from_bool (0 == cmp
);
6213 else if (SCM_COMPLEXP (y
))
6216 if (0.0 != SCM_COMPLEX_IMAG (y
))
6218 if (isnan (SCM_COMPLEX_REAL (y
)))
6220 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6221 scm_remember_upto_here_1 (x
);
6222 return scm_from_bool (0 == cmp
);
6224 else if (SCM_FRACTIONP (y
))
6227 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6229 else if (SCM_REALP (x
))
6231 double xx
= SCM_REAL_VALUE (x
);
6232 if (SCM_I_INUMP (y
))
6234 /* see comments with inum/real above */
6235 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6236 return scm_from_bool (xx
== (double) yy
6237 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6238 || (scm_t_signed_bits
) xx
== yy
));
6240 else if (SCM_BIGP (y
))
6243 if (isnan (SCM_REAL_VALUE (x
)))
6245 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6246 scm_remember_upto_here_1 (y
);
6247 return scm_from_bool (0 == cmp
);
6249 else if (SCM_REALP (y
))
6250 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6251 else if (SCM_COMPLEXP (y
))
6252 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6253 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6254 else if (SCM_FRACTIONP (y
))
6256 double xx
= SCM_REAL_VALUE (x
);
6260 return scm_from_bool (xx
< 0.0);
6261 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6265 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6267 else if (SCM_COMPLEXP (x
))
6269 if (SCM_I_INUMP (y
))
6270 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6271 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6272 else if (SCM_BIGP (y
))
6275 if (0.0 != SCM_COMPLEX_IMAG (x
))
6277 if (isnan (SCM_COMPLEX_REAL (x
)))
6279 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6280 scm_remember_upto_here_1 (y
);
6281 return scm_from_bool (0 == cmp
);
6283 else if (SCM_REALP (y
))
6284 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6285 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6286 else if (SCM_COMPLEXP (y
))
6287 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6288 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6289 else if (SCM_FRACTIONP (y
))
6292 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6294 xx
= SCM_COMPLEX_REAL (x
);
6298 return scm_from_bool (xx
< 0.0);
6299 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6303 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6305 else if (SCM_FRACTIONP (x
))
6307 if (SCM_I_INUMP (y
))
6309 else if (SCM_BIGP (y
))
6311 else if (SCM_REALP (y
))
6313 double yy
= SCM_REAL_VALUE (y
);
6317 return scm_from_bool (0.0 < yy
);
6318 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6321 else if (SCM_COMPLEXP (y
))
6324 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6326 yy
= SCM_COMPLEX_REAL (y
);
6330 return scm_from_bool (0.0 < yy
);
6331 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6334 else if (SCM_FRACTIONP (y
))
6335 return scm_i_fraction_equalp (x
, y
);
6337 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6340 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6344 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6345 done are good for inums, but for bignums an answer can almost always be
6346 had by just examining a few high bits of the operands, as done by GMP in
6347 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6348 of the float exponent to take into account. */
6350 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6351 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6352 (SCM x
, SCM y
, SCM rest
),
6353 "Return @code{#t} if the list of parameters is monotonically\n"
6355 #define FUNC_NAME s_scm_i_num_less_p
6357 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6359 while (!scm_is_null (rest
))
6361 if (scm_is_false (scm_less_p (x
, y
)))
6365 rest
= scm_cdr (rest
);
6367 return scm_less_p (x
, y
);
6371 scm_less_p (SCM x
, SCM y
)
6374 if (SCM_I_INUMP (x
))
6376 scm_t_inum xx
= SCM_I_INUM (x
);
6377 if (SCM_I_INUMP (y
))
6379 scm_t_inum yy
= SCM_I_INUM (y
);
6380 return scm_from_bool (xx
< yy
);
6382 else if (SCM_BIGP (y
))
6384 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6385 scm_remember_upto_here_1 (y
);
6386 return scm_from_bool (sgn
> 0);
6388 else if (SCM_REALP (y
))
6389 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6390 else if (SCM_FRACTIONP (y
))
6392 /* "x < a/b" becomes "x*b < a" */
6394 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6395 y
= SCM_FRACTION_NUMERATOR (y
);
6399 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6401 else if (SCM_BIGP (x
))
6403 if (SCM_I_INUMP (y
))
6405 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6406 scm_remember_upto_here_1 (x
);
6407 return scm_from_bool (sgn
< 0);
6409 else if (SCM_BIGP (y
))
6411 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6412 scm_remember_upto_here_2 (x
, y
);
6413 return scm_from_bool (cmp
< 0);
6415 else if (SCM_REALP (y
))
6418 if (isnan (SCM_REAL_VALUE (y
)))
6420 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6421 scm_remember_upto_here_1 (x
);
6422 return scm_from_bool (cmp
< 0);
6424 else if (SCM_FRACTIONP (y
))
6427 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6429 else if (SCM_REALP (x
))
6431 if (SCM_I_INUMP (y
))
6432 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6433 else if (SCM_BIGP (y
))
6436 if (isnan (SCM_REAL_VALUE (x
)))
6438 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6439 scm_remember_upto_here_1 (y
);
6440 return scm_from_bool (cmp
> 0);
6442 else if (SCM_REALP (y
))
6443 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6444 else if (SCM_FRACTIONP (y
))
6446 double xx
= SCM_REAL_VALUE (x
);
6450 return scm_from_bool (xx
< 0.0);
6451 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6455 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6457 else if (SCM_FRACTIONP (x
))
6459 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6461 /* "a/b < y" becomes "a < y*b" */
6462 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6463 x
= SCM_FRACTION_NUMERATOR (x
);
6466 else if (SCM_REALP (y
))
6468 double yy
= SCM_REAL_VALUE (y
);
6472 return scm_from_bool (0.0 < yy
);
6473 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6476 else if (SCM_FRACTIONP (y
))
6478 /* "a/b < c/d" becomes "a*d < c*b" */
6479 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6480 SCM_FRACTION_DENOMINATOR (y
));
6481 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6482 SCM_FRACTION_DENOMINATOR (x
));
6488 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6491 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6495 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6496 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6497 (SCM x
, SCM y
, SCM rest
),
6498 "Return @code{#t} if the list of parameters is monotonically\n"
6500 #define FUNC_NAME s_scm_i_num_gr_p
6502 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6504 while (!scm_is_null (rest
))
6506 if (scm_is_false (scm_gr_p (x
, y
)))
6510 rest
= scm_cdr (rest
);
6512 return scm_gr_p (x
, y
);
6515 #define FUNC_NAME s_scm_i_num_gr_p
6517 scm_gr_p (SCM x
, SCM y
)
6519 if (!SCM_NUMBERP (x
))
6520 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6521 else if (!SCM_NUMBERP (y
))
6522 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6524 return scm_less_p (y
, x
);
6529 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6530 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6531 (SCM x
, SCM y
, SCM rest
),
6532 "Return @code{#t} if the list of parameters is monotonically\n"
6534 #define FUNC_NAME s_scm_i_num_leq_p
6536 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6538 while (!scm_is_null (rest
))
6540 if (scm_is_false (scm_leq_p (x
, y
)))
6544 rest
= scm_cdr (rest
);
6546 return scm_leq_p (x
, y
);
6549 #define FUNC_NAME s_scm_i_num_leq_p
6551 scm_leq_p (SCM x
, SCM y
)
6553 if (!SCM_NUMBERP (x
))
6554 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6555 else if (!SCM_NUMBERP (y
))
6556 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6557 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6560 return scm_not (scm_less_p (y
, x
));
6565 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6566 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6567 (SCM x
, SCM y
, SCM rest
),
6568 "Return @code{#t} if the list of parameters is monotonically\n"
6570 #define FUNC_NAME s_scm_i_num_geq_p
6572 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6574 while (!scm_is_null (rest
))
6576 if (scm_is_false (scm_geq_p (x
, y
)))
6580 rest
= scm_cdr (rest
);
6582 return scm_geq_p (x
, y
);
6585 #define FUNC_NAME s_scm_i_num_geq_p
6587 scm_geq_p (SCM x
, SCM y
)
6589 if (!SCM_NUMBERP (x
))
6590 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6591 else if (!SCM_NUMBERP (y
))
6592 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6593 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6596 return scm_not (scm_less_p (x
, y
));
6601 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6603 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6605 #define FUNC_NAME s_scm_zero_p
6607 if (SCM_I_INUMP (z
))
6608 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6609 else if (SCM_BIGP (z
))
6611 else if (SCM_REALP (z
))
6612 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6613 else if (SCM_COMPLEXP (z
))
6614 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6615 && SCM_COMPLEX_IMAG (z
) == 0.0);
6616 else if (SCM_FRACTIONP (z
))
6619 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6624 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6626 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6628 #define FUNC_NAME s_scm_positive_p
6630 if (SCM_I_INUMP (x
))
6631 return scm_from_bool (SCM_I_INUM (x
) > 0);
6632 else if (SCM_BIGP (x
))
6634 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6635 scm_remember_upto_here_1 (x
);
6636 return scm_from_bool (sgn
> 0);
6638 else if (SCM_REALP (x
))
6639 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6640 else if (SCM_FRACTIONP (x
))
6641 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6643 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6648 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6650 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6652 #define FUNC_NAME s_scm_negative_p
6654 if (SCM_I_INUMP (x
))
6655 return scm_from_bool (SCM_I_INUM (x
) < 0);
6656 else if (SCM_BIGP (x
))
6658 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6659 scm_remember_upto_here_1 (x
);
6660 return scm_from_bool (sgn
< 0);
6662 else if (SCM_REALP (x
))
6663 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6664 else if (SCM_FRACTIONP (x
))
6665 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6667 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6672 /* scm_min and scm_max return an inexact when either argument is inexact, as
6673 required by r5rs. On that basis, for exact/inexact combinations the
6674 exact is converted to inexact to compare and possibly return. This is
6675 unlike scm_less_p above which takes some trouble to preserve all bits in
6676 its test, such trouble is not required for min and max. */
6678 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6679 (SCM x
, SCM y
, SCM rest
),
6680 "Return the maximum of all parameter values.")
6681 #define FUNC_NAME s_scm_i_max
6683 while (!scm_is_null (rest
))
6684 { x
= scm_max (x
, y
);
6686 rest
= scm_cdr (rest
);
6688 return scm_max (x
, y
);
6692 #define s_max s_scm_i_max
6693 #define g_max g_scm_i_max
6696 scm_max (SCM x
, SCM y
)
6701 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6702 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6705 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6708 if (SCM_I_INUMP (x
))
6710 scm_t_inum xx
= SCM_I_INUM (x
);
6711 if (SCM_I_INUMP (y
))
6713 scm_t_inum yy
= SCM_I_INUM (y
);
6714 return (xx
< yy
) ? y
: x
;
6716 else if (SCM_BIGP (y
))
6718 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6719 scm_remember_upto_here_1 (y
);
6720 return (sgn
< 0) ? x
: y
;
6722 else if (SCM_REALP (y
))
6725 double yyd
= SCM_REAL_VALUE (y
);
6728 return scm_from_double (xxd
);
6729 /* If y is a NaN, then "==" is false and we return the NaN */
6730 else if (SCM_LIKELY (!(xxd
== yyd
)))
6732 /* Handle signed zeroes properly */
6738 else if (SCM_FRACTIONP (y
))
6741 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6744 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6746 else if (SCM_BIGP (x
))
6748 if (SCM_I_INUMP (y
))
6750 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6751 scm_remember_upto_here_1 (x
);
6752 return (sgn
< 0) ? y
: x
;
6754 else if (SCM_BIGP (y
))
6756 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6757 scm_remember_upto_here_2 (x
, y
);
6758 return (cmp
> 0) ? x
: y
;
6760 else if (SCM_REALP (y
))
6762 /* if y==NaN then xx>yy is false, so we return the NaN y */
6765 xx
= scm_i_big2dbl (x
);
6766 yy
= SCM_REAL_VALUE (y
);
6767 return (xx
> yy
? scm_from_double (xx
) : y
);
6769 else if (SCM_FRACTIONP (y
))
6774 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6776 else if (SCM_REALP (x
))
6778 if (SCM_I_INUMP (y
))
6780 scm_t_inum yy
= SCM_I_INUM (y
);
6781 double xxd
= SCM_REAL_VALUE (x
);
6785 return scm_from_double (yyd
);
6786 /* If x is a NaN, then "==" is false and we return the NaN */
6787 else if (SCM_LIKELY (!(xxd
== yyd
)))
6789 /* Handle signed zeroes properly */
6795 else if (SCM_BIGP (y
))
6800 else if (SCM_REALP (y
))
6802 double xx
= SCM_REAL_VALUE (x
);
6803 double yy
= SCM_REAL_VALUE (y
);
6805 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6808 else if (SCM_LIKELY (xx
< yy
))
6810 /* If neither (xx > yy) nor (xx < yy), then
6811 either they're equal or one is a NaN */
6812 else if (SCM_UNLIKELY (isnan (xx
)))
6813 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6814 else if (SCM_UNLIKELY (isnan (yy
)))
6815 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6816 /* xx == yy, but handle signed zeroes properly */
6817 else if (double_is_non_negative_zero (yy
))
6822 else if (SCM_FRACTIONP (y
))
6824 double yy
= scm_i_fraction2double (y
);
6825 double xx
= SCM_REAL_VALUE (x
);
6826 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6829 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6831 else if (SCM_FRACTIONP (x
))
6833 if (SCM_I_INUMP (y
))
6837 else if (SCM_BIGP (y
))
6841 else if (SCM_REALP (y
))
6843 double xx
= scm_i_fraction2double (x
);
6844 /* if y==NaN then ">" is false, so we return the NaN y */
6845 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6847 else if (SCM_FRACTIONP (y
))
6852 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6855 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6859 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6860 (SCM x
, SCM y
, SCM rest
),
6861 "Return the minimum of all parameter values.")
6862 #define FUNC_NAME s_scm_i_min
6864 while (!scm_is_null (rest
))
6865 { x
= scm_min (x
, y
);
6867 rest
= scm_cdr (rest
);
6869 return scm_min (x
, y
);
6873 #define s_min s_scm_i_min
6874 #define g_min g_scm_i_min
6877 scm_min (SCM x
, SCM y
)
6882 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
6883 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6886 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
6889 if (SCM_I_INUMP (x
))
6891 scm_t_inum xx
= SCM_I_INUM (x
);
6892 if (SCM_I_INUMP (y
))
6894 scm_t_inum yy
= SCM_I_INUM (y
);
6895 return (xx
< yy
) ? x
: y
;
6897 else if (SCM_BIGP (y
))
6899 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6900 scm_remember_upto_here_1 (y
);
6901 return (sgn
< 0) ? y
: x
;
6903 else if (SCM_REALP (y
))
6906 /* if y==NaN then "<" is false and we return NaN */
6907 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6909 else if (SCM_FRACTIONP (y
))
6912 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6915 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6917 else if (SCM_BIGP (x
))
6919 if (SCM_I_INUMP (y
))
6921 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6922 scm_remember_upto_here_1 (x
);
6923 return (sgn
< 0) ? x
: y
;
6925 else if (SCM_BIGP (y
))
6927 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6928 scm_remember_upto_here_2 (x
, y
);
6929 return (cmp
> 0) ? y
: x
;
6931 else if (SCM_REALP (y
))
6933 /* if y==NaN then xx<yy is false, so we return the NaN y */
6936 xx
= scm_i_big2dbl (x
);
6937 yy
= SCM_REAL_VALUE (y
);
6938 return (xx
< yy
? scm_from_double (xx
) : y
);
6940 else if (SCM_FRACTIONP (y
))
6945 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6947 else if (SCM_REALP (x
))
6949 if (SCM_I_INUMP (y
))
6951 double z
= SCM_I_INUM (y
);
6952 /* if x==NaN then "<" is false and we return NaN */
6953 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
6955 else if (SCM_BIGP (y
))
6960 else if (SCM_REALP (y
))
6962 double xx
= SCM_REAL_VALUE (x
);
6963 double yy
= SCM_REAL_VALUE (y
);
6965 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
6968 else if (SCM_LIKELY (xx
> yy
))
6970 /* If neither (xx < yy) nor (xx > yy), then
6971 either they're equal or one is a NaN */
6972 else if (SCM_UNLIKELY (isnan (xx
)))
6973 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
6974 else if (SCM_UNLIKELY (isnan (yy
)))
6975 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
6976 /* xx == yy, but handle signed zeroes properly */
6977 else if (double_is_non_negative_zero (xx
))
6982 else if (SCM_FRACTIONP (y
))
6984 double yy
= scm_i_fraction2double (y
);
6985 double xx
= SCM_REAL_VALUE (x
);
6986 return (yy
< xx
) ? scm_from_double (yy
) : x
;
6989 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6991 else if (SCM_FRACTIONP (x
))
6993 if (SCM_I_INUMP (y
))
6997 else if (SCM_BIGP (y
))
7001 else if (SCM_REALP (y
))
7003 double xx
= scm_i_fraction2double (x
);
7004 /* if y==NaN then "<" is false, so we return the NaN y */
7005 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7007 else if (SCM_FRACTIONP (y
))
7012 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7015 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7019 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7020 (SCM x
, SCM y
, SCM rest
),
7021 "Return the sum of all parameter values. Return 0 if called without\n"
7023 #define FUNC_NAME s_scm_i_sum
7025 while (!scm_is_null (rest
))
7026 { x
= scm_sum (x
, y
);
7028 rest
= scm_cdr (rest
);
7030 return scm_sum (x
, y
);
7034 #define s_sum s_scm_i_sum
7035 #define g_sum g_scm_i_sum
7038 scm_sum (SCM x
, SCM y
)
7040 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7042 if (SCM_NUMBERP (x
)) return x
;
7043 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7044 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7047 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7049 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7051 scm_t_inum xx
= SCM_I_INUM (x
);
7052 scm_t_inum yy
= SCM_I_INUM (y
);
7053 scm_t_inum z
= xx
+ yy
;
7054 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7056 else if (SCM_BIGP (y
))
7061 else if (SCM_REALP (y
))
7063 scm_t_inum xx
= SCM_I_INUM (x
);
7064 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7066 else if (SCM_COMPLEXP (y
))
7068 scm_t_inum xx
= SCM_I_INUM (x
);
7069 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7070 SCM_COMPLEX_IMAG (y
));
7072 else if (SCM_FRACTIONP (y
))
7073 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7074 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7075 SCM_FRACTION_DENOMINATOR (y
));
7077 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7078 } else if (SCM_BIGP (x
))
7080 if (SCM_I_INUMP (y
))
7085 inum
= SCM_I_INUM (y
);
7088 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7091 SCM result
= scm_i_mkbig ();
7092 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7093 scm_remember_upto_here_1 (x
);
7094 /* we know the result will have to be a bignum */
7097 return scm_i_normbig (result
);
7101 SCM result
= scm_i_mkbig ();
7102 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7103 scm_remember_upto_here_1 (x
);
7104 /* we know the result will have to be a bignum */
7107 return scm_i_normbig (result
);
7110 else if (SCM_BIGP (y
))
7112 SCM result
= scm_i_mkbig ();
7113 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7114 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7115 mpz_add (SCM_I_BIG_MPZ (result
),
7118 scm_remember_upto_here_2 (x
, y
);
7119 /* we know the result will have to be a bignum */
7122 return scm_i_normbig (result
);
7124 else if (SCM_REALP (y
))
7126 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7127 scm_remember_upto_here_1 (x
);
7128 return scm_from_double (result
);
7130 else if (SCM_COMPLEXP (y
))
7132 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7133 + SCM_COMPLEX_REAL (y
));
7134 scm_remember_upto_here_1 (x
);
7135 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7137 else if (SCM_FRACTIONP (y
))
7138 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7139 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7140 SCM_FRACTION_DENOMINATOR (y
));
7142 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7144 else if (SCM_REALP (x
))
7146 if (SCM_I_INUMP (y
))
7147 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7148 else if (SCM_BIGP (y
))
7150 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7151 scm_remember_upto_here_1 (y
);
7152 return scm_from_double (result
);
7154 else if (SCM_REALP (y
))
7155 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7156 else if (SCM_COMPLEXP (y
))
7157 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7158 SCM_COMPLEX_IMAG (y
));
7159 else if (SCM_FRACTIONP (y
))
7160 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7162 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7164 else if (SCM_COMPLEXP (x
))
7166 if (SCM_I_INUMP (y
))
7167 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7168 SCM_COMPLEX_IMAG (x
));
7169 else if (SCM_BIGP (y
))
7171 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7172 + SCM_COMPLEX_REAL (x
));
7173 scm_remember_upto_here_1 (y
);
7174 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7176 else if (SCM_REALP (y
))
7177 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7178 SCM_COMPLEX_IMAG (x
));
7179 else if (SCM_COMPLEXP (y
))
7180 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7181 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7182 else if (SCM_FRACTIONP (y
))
7183 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7184 SCM_COMPLEX_IMAG (x
));
7186 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7188 else if (SCM_FRACTIONP (x
))
7190 if (SCM_I_INUMP (y
))
7191 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7192 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7193 SCM_FRACTION_DENOMINATOR (x
));
7194 else if (SCM_BIGP (y
))
7195 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7196 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7197 SCM_FRACTION_DENOMINATOR (x
));
7198 else if (SCM_REALP (y
))
7199 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7200 else if (SCM_COMPLEXP (y
))
7201 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7202 SCM_COMPLEX_IMAG (y
));
7203 else if (SCM_FRACTIONP (y
))
7204 /* a/b + c/d = (ad + bc) / bd */
7205 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7206 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7207 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7209 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7212 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7216 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7218 "Return @math{@var{x}+1}.")
7219 #define FUNC_NAME s_scm_oneplus
7221 return scm_sum (x
, SCM_INUM1
);
7226 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7227 (SCM x
, SCM y
, SCM rest
),
7228 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7229 "the sum of all but the first argument are subtracted from the first\n"
7231 #define FUNC_NAME s_scm_i_difference
7233 while (!scm_is_null (rest
))
7234 { x
= scm_difference (x
, y
);
7236 rest
= scm_cdr (rest
);
7238 return scm_difference (x
, y
);
7242 #define s_difference s_scm_i_difference
7243 #define g_difference g_scm_i_difference
7246 scm_difference (SCM x
, SCM y
)
7247 #define FUNC_NAME s_difference
7249 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7252 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7254 if (SCM_I_INUMP (x
))
7256 scm_t_inum xx
= -SCM_I_INUM (x
);
7257 if (SCM_FIXABLE (xx
))
7258 return SCM_I_MAKINUM (xx
);
7260 return scm_i_inum2big (xx
);
7262 else if (SCM_BIGP (x
))
7263 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7264 bignum, but negating that gives a fixnum. */
7265 return scm_i_normbig (scm_i_clonebig (x
, 0));
7266 else if (SCM_REALP (x
))
7267 return scm_from_double (-SCM_REAL_VALUE (x
));
7268 else if (SCM_COMPLEXP (x
))
7269 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7270 -SCM_COMPLEX_IMAG (x
));
7271 else if (SCM_FRACTIONP (x
))
7272 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7273 SCM_FRACTION_DENOMINATOR (x
));
7275 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7278 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7280 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7282 scm_t_inum xx
= SCM_I_INUM (x
);
7283 scm_t_inum yy
= SCM_I_INUM (y
);
7284 scm_t_inum z
= xx
- yy
;
7285 if (SCM_FIXABLE (z
))
7286 return SCM_I_MAKINUM (z
);
7288 return scm_i_inum2big (z
);
7290 else if (SCM_BIGP (y
))
7292 /* inum-x - big-y */
7293 scm_t_inum xx
= SCM_I_INUM (x
);
7297 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7298 bignum, but negating that gives a fixnum. */
7299 return scm_i_normbig (scm_i_clonebig (y
, 0));
7303 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7304 SCM result
= scm_i_mkbig ();
7307 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7310 /* x - y == -(y + -x) */
7311 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7312 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7314 scm_remember_upto_here_1 (y
);
7316 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7317 /* we know the result will have to be a bignum */
7320 return scm_i_normbig (result
);
7323 else if (SCM_REALP (y
))
7325 scm_t_inum xx
= SCM_I_INUM (x
);
7328 * We need to handle x == exact 0
7329 * specially because R6RS states that:
7330 * (- 0.0) ==> -0.0 and
7331 * (- 0.0 0.0) ==> 0.0
7332 * and the scheme compiler changes
7333 * (- 0.0) into (- 0 0.0)
7334 * So we need to treat (- 0 0.0) like (- 0.0).
7335 * At the C level, (-x) is different than (0.0 - x).
7336 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7339 return scm_from_double (- SCM_REAL_VALUE (y
));
7341 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7343 else if (SCM_COMPLEXP (y
))
7345 scm_t_inum xx
= SCM_I_INUM (x
);
7347 /* We need to handle x == exact 0 specially.
7348 See the comment above (for SCM_REALP (y)) */
7350 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7351 - SCM_COMPLEX_IMAG (y
));
7353 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7354 - SCM_COMPLEX_IMAG (y
));
7356 else if (SCM_FRACTIONP (y
))
7357 /* a - b/c = (ac - b) / c */
7358 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7359 SCM_FRACTION_NUMERATOR (y
)),
7360 SCM_FRACTION_DENOMINATOR (y
));
7362 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7364 else if (SCM_BIGP (x
))
7366 if (SCM_I_INUMP (y
))
7368 /* big-x - inum-y */
7369 scm_t_inum yy
= SCM_I_INUM (y
);
7370 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7372 scm_remember_upto_here_1 (x
);
7374 return (SCM_FIXABLE (-yy
) ?
7375 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7378 SCM result
= scm_i_mkbig ();
7381 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7383 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7384 scm_remember_upto_here_1 (x
);
7386 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7387 /* we know the result will have to be a bignum */
7390 return scm_i_normbig (result
);
7393 else if (SCM_BIGP (y
))
7395 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7396 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7397 SCM result
= scm_i_mkbig ();
7398 mpz_sub (SCM_I_BIG_MPZ (result
),
7401 scm_remember_upto_here_2 (x
, y
);
7402 /* we know the result will have to be a bignum */
7403 if ((sgn_x
== 1) && (sgn_y
== -1))
7405 if ((sgn_x
== -1) && (sgn_y
== 1))
7407 return scm_i_normbig (result
);
7409 else if (SCM_REALP (y
))
7411 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7412 scm_remember_upto_here_1 (x
);
7413 return scm_from_double (result
);
7415 else if (SCM_COMPLEXP (y
))
7417 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7418 - SCM_COMPLEX_REAL (y
));
7419 scm_remember_upto_here_1 (x
);
7420 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7422 else if (SCM_FRACTIONP (y
))
7423 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7424 SCM_FRACTION_NUMERATOR (y
)),
7425 SCM_FRACTION_DENOMINATOR (y
));
7426 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7428 else if (SCM_REALP (x
))
7430 if (SCM_I_INUMP (y
))
7431 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7432 else if (SCM_BIGP (y
))
7434 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7435 scm_remember_upto_here_1 (x
);
7436 return scm_from_double (result
);
7438 else if (SCM_REALP (y
))
7439 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7440 else if (SCM_COMPLEXP (y
))
7441 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7442 -SCM_COMPLEX_IMAG (y
));
7443 else if (SCM_FRACTIONP (y
))
7444 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7446 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7448 else if (SCM_COMPLEXP (x
))
7450 if (SCM_I_INUMP (y
))
7451 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7452 SCM_COMPLEX_IMAG (x
));
7453 else if (SCM_BIGP (y
))
7455 double real_part
= (SCM_COMPLEX_REAL (x
)
7456 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7457 scm_remember_upto_here_1 (x
);
7458 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7460 else if (SCM_REALP (y
))
7461 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7462 SCM_COMPLEX_IMAG (x
));
7463 else if (SCM_COMPLEXP (y
))
7464 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7465 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7466 else if (SCM_FRACTIONP (y
))
7467 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7468 SCM_COMPLEX_IMAG (x
));
7470 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7472 else if (SCM_FRACTIONP (x
))
7474 if (SCM_I_INUMP (y
))
7475 /* a/b - c = (a - cb) / b */
7476 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7477 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7478 SCM_FRACTION_DENOMINATOR (x
));
7479 else if (SCM_BIGP (y
))
7480 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7481 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7482 SCM_FRACTION_DENOMINATOR (x
));
7483 else if (SCM_REALP (y
))
7484 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7485 else if (SCM_COMPLEXP (y
))
7486 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7487 -SCM_COMPLEX_IMAG (y
));
7488 else if (SCM_FRACTIONP (y
))
7489 /* a/b - c/d = (ad - bc) / bd */
7490 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7491 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7492 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7494 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7497 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7502 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7504 "Return @math{@var{x}-1}.")
7505 #define FUNC_NAME s_scm_oneminus
7507 return scm_difference (x
, SCM_INUM1
);
7512 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7513 (SCM x
, SCM y
, SCM rest
),
7514 "Return the product of all arguments. If called without arguments,\n"
7516 #define FUNC_NAME s_scm_i_product
7518 while (!scm_is_null (rest
))
7519 { x
= scm_product (x
, y
);
7521 rest
= scm_cdr (rest
);
7523 return scm_product (x
, y
);
7527 #define s_product s_scm_i_product
7528 #define g_product g_scm_i_product
7531 scm_product (SCM x
, SCM y
)
7533 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7536 return SCM_I_MAKINUM (1L);
7537 else if (SCM_NUMBERP (x
))
7540 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7543 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7548 xx
= SCM_I_INUM (x
);
7553 /* exact1 is the universal multiplicative identity */
7557 /* exact0 times a fixnum is exact0: optimize this case */
7558 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7560 /* if the other argument is inexact, the result is inexact,
7561 and we must do the multiplication in order to handle
7562 infinities and NaNs properly. */
7563 else if (SCM_REALP (y
))
7564 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7565 else if (SCM_COMPLEXP (y
))
7566 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7567 0.0 * SCM_COMPLEX_IMAG (y
));
7568 /* we've already handled inexact numbers,
7569 so y must be exact, and we return exact0 */
7570 else if (SCM_NUMP (y
))
7573 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7577 * This case is important for more than just optimization.
7578 * It handles the case of negating
7579 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7580 * which is a bignum that must be changed back into a fixnum.
7581 * Failure to do so will cause the following to return #f:
7582 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7584 return scm_difference(y
, SCM_UNDEFINED
);
7588 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7590 scm_t_inum yy
= SCM_I_INUM (y
);
7591 scm_t_inum kk
= xx
* yy
;
7592 SCM k
= SCM_I_MAKINUM (kk
);
7593 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7597 SCM result
= scm_i_inum2big (xx
);
7598 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7599 return scm_i_normbig (result
);
7602 else if (SCM_BIGP (y
))
7604 SCM result
= scm_i_mkbig ();
7605 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7606 scm_remember_upto_here_1 (y
);
7609 else if (SCM_REALP (y
))
7610 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7611 else if (SCM_COMPLEXP (y
))
7612 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7613 xx
* SCM_COMPLEX_IMAG (y
));
7614 else if (SCM_FRACTIONP (y
))
7615 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7616 SCM_FRACTION_DENOMINATOR (y
));
7618 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7620 else if (SCM_BIGP (x
))
7622 if (SCM_I_INUMP (y
))
7627 else if (SCM_BIGP (y
))
7629 SCM result
= scm_i_mkbig ();
7630 mpz_mul (SCM_I_BIG_MPZ (result
),
7633 scm_remember_upto_here_2 (x
, y
);
7636 else if (SCM_REALP (y
))
7638 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7639 scm_remember_upto_here_1 (x
);
7640 return scm_from_double (result
);
7642 else if (SCM_COMPLEXP (y
))
7644 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7645 scm_remember_upto_here_1 (x
);
7646 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7647 z
* SCM_COMPLEX_IMAG (y
));
7649 else if (SCM_FRACTIONP (y
))
7650 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7651 SCM_FRACTION_DENOMINATOR (y
));
7653 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7655 else if (SCM_REALP (x
))
7657 if (SCM_I_INUMP (y
))
7662 else if (SCM_BIGP (y
))
7664 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7665 scm_remember_upto_here_1 (y
);
7666 return scm_from_double (result
);
7668 else if (SCM_REALP (y
))
7669 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7670 else if (SCM_COMPLEXP (y
))
7671 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7672 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7673 else if (SCM_FRACTIONP (y
))
7674 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7676 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7678 else if (SCM_COMPLEXP (x
))
7680 if (SCM_I_INUMP (y
))
7685 else if (SCM_BIGP (y
))
7687 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7688 scm_remember_upto_here_1 (y
);
7689 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7690 z
* SCM_COMPLEX_IMAG (x
));
7692 else if (SCM_REALP (y
))
7693 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7694 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7695 else if (SCM_COMPLEXP (y
))
7697 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7698 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7699 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7700 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7702 else if (SCM_FRACTIONP (y
))
7704 double yy
= scm_i_fraction2double (y
);
7705 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7706 yy
* SCM_COMPLEX_IMAG (x
));
7709 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7711 else if (SCM_FRACTIONP (x
))
7713 if (SCM_I_INUMP (y
))
7714 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7715 SCM_FRACTION_DENOMINATOR (x
));
7716 else if (SCM_BIGP (y
))
7717 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7718 SCM_FRACTION_DENOMINATOR (x
));
7719 else if (SCM_REALP (y
))
7720 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7721 else if (SCM_COMPLEXP (y
))
7723 double xx
= scm_i_fraction2double (x
);
7724 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7725 xx
* SCM_COMPLEX_IMAG (y
));
7727 else if (SCM_FRACTIONP (y
))
7728 /* a/b * c/d = ac / bd */
7729 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7730 SCM_FRACTION_NUMERATOR (y
)),
7731 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7732 SCM_FRACTION_DENOMINATOR (y
)));
7734 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7737 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7740 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7741 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7742 #define ALLOW_DIVIDE_BY_ZERO
7743 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7746 /* The code below for complex division is adapted from the GNU
7747 libstdc++, which adapted it from f2c's libF77, and is subject to
7750 /****************************************************************
7751 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7753 Permission to use, copy, modify, and distribute this software
7754 and its documentation for any purpose and without fee is hereby
7755 granted, provided that the above copyright notice appear in all
7756 copies and that both that the copyright notice and this
7757 permission notice and warranty disclaimer appear in supporting
7758 documentation, and that the names of AT&T Bell Laboratories or
7759 Bellcore or any of their entities not be used in advertising or
7760 publicity pertaining to distribution of the software without
7761 specific, written prior permission.
7763 AT&T and Bellcore disclaim all warranties with regard to this
7764 software, including all implied warranties of merchantability
7765 and fitness. In no event shall AT&T or Bellcore be liable for
7766 any special, indirect or consequential damages or any damages
7767 whatsoever resulting from loss of use, data or profits, whether
7768 in an action of contract, negligence or other tortious action,
7769 arising out of or in connection with the use or performance of
7771 ****************************************************************/
7773 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7774 (SCM x
, SCM y
, SCM rest
),
7775 "Divide the first argument by the product of the remaining\n"
7776 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7778 #define FUNC_NAME s_scm_i_divide
7780 while (!scm_is_null (rest
))
7781 { x
= scm_divide (x
, y
);
7783 rest
= scm_cdr (rest
);
7785 return scm_divide (x
, y
);
7789 #define s_divide s_scm_i_divide
7790 #define g_divide g_scm_i_divide
7793 do_divide (SCM x
, SCM y
, int inexact
)
7794 #define FUNC_NAME s_divide
7798 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7801 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7802 else if (SCM_I_INUMP (x
))
7804 scm_t_inum xx
= SCM_I_INUM (x
);
7805 if (xx
== 1 || xx
== -1)
7807 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7809 scm_num_overflow (s_divide
);
7814 return scm_from_double (1.0 / (double) xx
);
7815 else return scm_i_make_ratio (SCM_INUM1
, x
);
7818 else if (SCM_BIGP (x
))
7821 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7822 else return scm_i_make_ratio (SCM_INUM1
, x
);
7824 else if (SCM_REALP (x
))
7826 double xx
= SCM_REAL_VALUE (x
);
7827 #ifndef ALLOW_DIVIDE_BY_ZERO
7829 scm_num_overflow (s_divide
);
7832 return scm_from_double (1.0 / xx
);
7834 else if (SCM_COMPLEXP (x
))
7836 double r
= SCM_COMPLEX_REAL (x
);
7837 double i
= SCM_COMPLEX_IMAG (x
);
7838 if (fabs(r
) <= fabs(i
))
7841 double d
= i
* (1.0 + t
* t
);
7842 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7847 double d
= r
* (1.0 + t
* t
);
7848 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7851 else if (SCM_FRACTIONP (x
))
7852 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7853 SCM_FRACTION_NUMERATOR (x
));
7855 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7858 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7860 scm_t_inum xx
= SCM_I_INUM (x
);
7861 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7863 scm_t_inum yy
= SCM_I_INUM (y
);
7866 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7867 scm_num_overflow (s_divide
);
7869 return scm_from_double ((double) xx
/ (double) yy
);
7872 else if (xx
% yy
!= 0)
7875 return scm_from_double ((double) xx
/ (double) yy
);
7876 else return scm_i_make_ratio (x
, y
);
7880 scm_t_inum z
= xx
/ yy
;
7881 if (SCM_FIXABLE (z
))
7882 return SCM_I_MAKINUM (z
);
7884 return scm_i_inum2big (z
);
7887 else if (SCM_BIGP (y
))
7890 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7891 else return scm_i_make_ratio (x
, y
);
7893 else if (SCM_REALP (y
))
7895 double yy
= SCM_REAL_VALUE (y
);
7896 #ifndef ALLOW_DIVIDE_BY_ZERO
7898 scm_num_overflow (s_divide
);
7901 return scm_from_double ((double) xx
/ yy
);
7903 else if (SCM_COMPLEXP (y
))
7906 complex_div
: /* y _must_ be a complex number */
7908 double r
= SCM_COMPLEX_REAL (y
);
7909 double i
= SCM_COMPLEX_IMAG (y
);
7910 if (fabs(r
) <= fabs(i
))
7913 double d
= i
* (1.0 + t
* t
);
7914 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7919 double d
= r
* (1.0 + t
* t
);
7920 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7924 else if (SCM_FRACTIONP (y
))
7925 /* a / b/c = ac / b */
7926 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7927 SCM_FRACTION_NUMERATOR (y
));
7929 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7931 else if (SCM_BIGP (x
))
7933 if (SCM_I_INUMP (y
))
7935 scm_t_inum yy
= SCM_I_INUM (y
);
7938 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7939 scm_num_overflow (s_divide
);
7941 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7942 scm_remember_upto_here_1 (x
);
7943 return (sgn
== 0) ? scm_nan () : scm_inf ();
7950 /* FIXME: HMM, what are the relative performance issues here?
7951 We need to test. Is it faster on average to test
7952 divisible_p, then perform whichever operation, or is it
7953 faster to perform the integer div opportunistically and
7954 switch to real if there's a remainder? For now we take the
7955 middle ground: test, then if divisible, use the faster div
7958 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
7959 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
7963 SCM result
= scm_i_mkbig ();
7964 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
7965 scm_remember_upto_here_1 (x
);
7967 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7968 return scm_i_normbig (result
);
7973 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
7974 else return scm_i_make_ratio (x
, y
);
7978 else if (SCM_BIGP (y
))
7983 /* It's easily possible for the ratio x/y to fit a double
7984 but one or both x and y be too big to fit a double,
7985 hence the use of mpq_get_d rather than converting and
7988 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
7989 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
7990 return scm_from_double (mpq_get_d (q
));
7994 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
7998 SCM result
= scm_i_mkbig ();
7999 mpz_divexact (SCM_I_BIG_MPZ (result
),
8002 scm_remember_upto_here_2 (x
, y
);
8003 return scm_i_normbig (result
);
8006 return scm_i_make_ratio (x
, y
);
8009 else if (SCM_REALP (y
))
8011 double yy
= SCM_REAL_VALUE (y
);
8012 #ifndef ALLOW_DIVIDE_BY_ZERO
8014 scm_num_overflow (s_divide
);
8017 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8019 else if (SCM_COMPLEXP (y
))
8021 a
= scm_i_big2dbl (x
);
8024 else if (SCM_FRACTIONP (y
))
8025 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8026 SCM_FRACTION_NUMERATOR (y
));
8028 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8030 else if (SCM_REALP (x
))
8032 double rx
= SCM_REAL_VALUE (x
);
8033 if (SCM_I_INUMP (y
))
8035 scm_t_inum yy
= SCM_I_INUM (y
);
8036 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8038 scm_num_overflow (s_divide
);
8041 return scm_from_double (rx
/ (double) yy
);
8043 else if (SCM_BIGP (y
))
8045 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8046 scm_remember_upto_here_1 (y
);
8047 return scm_from_double (rx
/ dby
);
8049 else if (SCM_REALP (y
))
8051 double yy
= SCM_REAL_VALUE (y
);
8052 #ifndef ALLOW_DIVIDE_BY_ZERO
8054 scm_num_overflow (s_divide
);
8057 return scm_from_double (rx
/ yy
);
8059 else if (SCM_COMPLEXP (y
))
8064 else if (SCM_FRACTIONP (y
))
8065 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8067 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8069 else if (SCM_COMPLEXP (x
))
8071 double rx
= SCM_COMPLEX_REAL (x
);
8072 double ix
= SCM_COMPLEX_IMAG (x
);
8073 if (SCM_I_INUMP (y
))
8075 scm_t_inum yy
= SCM_I_INUM (y
);
8076 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8078 scm_num_overflow (s_divide
);
8083 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8086 else if (SCM_BIGP (y
))
8088 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8089 scm_remember_upto_here_1 (y
);
8090 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8092 else if (SCM_REALP (y
))
8094 double yy
= SCM_REAL_VALUE (y
);
8095 #ifndef ALLOW_DIVIDE_BY_ZERO
8097 scm_num_overflow (s_divide
);
8100 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8102 else if (SCM_COMPLEXP (y
))
8104 double ry
= SCM_COMPLEX_REAL (y
);
8105 double iy
= SCM_COMPLEX_IMAG (y
);
8106 if (fabs(ry
) <= fabs(iy
))
8109 double d
= iy
* (1.0 + t
* t
);
8110 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8115 double d
= ry
* (1.0 + t
* t
);
8116 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8119 else if (SCM_FRACTIONP (y
))
8121 double yy
= scm_i_fraction2double (y
);
8122 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8125 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8127 else if (SCM_FRACTIONP (x
))
8129 if (SCM_I_INUMP (y
))
8131 scm_t_inum yy
= SCM_I_INUM (y
);
8132 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8134 scm_num_overflow (s_divide
);
8137 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8138 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8140 else if (SCM_BIGP (y
))
8142 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8143 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8145 else if (SCM_REALP (y
))
8147 double yy
= SCM_REAL_VALUE (y
);
8148 #ifndef ALLOW_DIVIDE_BY_ZERO
8150 scm_num_overflow (s_divide
);
8153 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8155 else if (SCM_COMPLEXP (y
))
8157 a
= scm_i_fraction2double (x
);
8160 else if (SCM_FRACTIONP (y
))
8161 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8162 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8164 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8167 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8171 scm_divide (SCM x
, SCM y
)
8173 return do_divide (x
, y
, 0);
8176 static SCM
scm_divide2real (SCM x
, SCM y
)
8178 return do_divide (x
, y
, 1);
8184 scm_c_truncate (double x
)
8189 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8190 half-way case (ie. when x is an integer plus 0.5) going upwards.
8191 Then half-way cases are identified and adjusted down if the
8192 round-upwards didn't give the desired even integer.
8194 "plus_half == result" identifies a half-way case. If plus_half, which is
8195 x + 0.5, is an integer then x must be an integer plus 0.5.
8197 An odd "result" value is identified with result/2 != floor(result/2).
8198 This is done with plus_half, since that value is ready for use sooner in
8199 a pipelined cpu, and we're already requiring plus_half == result.
8201 Note however that we need to be careful when x is big and already an
8202 integer. In that case "x+0.5" may round to an adjacent integer, causing
8203 us to return such a value, incorrectly. For instance if the hardware is
8204 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8205 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8206 returned. Or if the hardware is in round-upwards mode, then other bigger
8207 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8208 representable value, 2^128+2^76 (or whatever), again incorrect.
8210 These bad roundings of x+0.5 are avoided by testing at the start whether
8211 x is already an integer. If it is then clearly that's the desired result
8212 already. And if it's not then the exponent must be small enough to allow
8213 an 0.5 to be represented, and hence added without a bad rounding. */
8216 scm_c_round (double x
)
8218 double plus_half
, result
;
8223 plus_half
= x
+ 0.5;
8224 result
= floor (plus_half
);
8225 /* Adjust so that the rounding is towards even. */
8226 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8231 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8233 "Round the number @var{x} towards zero.")
8234 #define FUNC_NAME s_scm_truncate_number
8236 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8238 else if (SCM_REALP (x
))
8239 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8240 else if (SCM_FRACTIONP (x
))
8241 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8242 SCM_FRACTION_DENOMINATOR (x
));
8244 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8245 s_scm_truncate_number
);
8249 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8251 "Round the number @var{x} towards the nearest integer. "
8252 "When it is exactly halfway between two integers, "
8253 "round towards the even one.")
8254 #define FUNC_NAME s_scm_round_number
8256 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8258 else if (SCM_REALP (x
))
8259 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8260 else if (SCM_FRACTIONP (x
))
8261 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8262 SCM_FRACTION_DENOMINATOR (x
));
8264 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8265 s_scm_round_number
);
8269 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8271 "Round the number @var{x} towards minus infinity.")
8272 #define FUNC_NAME s_scm_floor
8274 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8276 else if (SCM_REALP (x
))
8277 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8278 else if (SCM_FRACTIONP (x
))
8279 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8280 SCM_FRACTION_DENOMINATOR (x
));
8282 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8286 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8288 "Round the number @var{x} towards infinity.")
8289 #define FUNC_NAME s_scm_ceiling
8291 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8293 else if (SCM_REALP (x
))
8294 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8295 else if (SCM_FRACTIONP (x
))
8296 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8297 SCM_FRACTION_DENOMINATOR (x
));
8299 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8303 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8305 "Return @var{x} raised to the power of @var{y}.")
8306 #define FUNC_NAME s_scm_expt
8308 if (scm_is_integer (y
))
8310 if (scm_is_true (scm_exact_p (y
)))
8311 return scm_integer_expt (x
, y
);
8314 /* Here we handle the case where the exponent is an inexact
8315 integer. We make the exponent exact in order to use
8316 scm_integer_expt, and thus avoid the spurious imaginary
8317 parts that may result from round-off errors in the general
8318 e^(y log x) method below (for example when squaring a large
8319 negative number). In this case, we must return an inexact
8320 result for correctness. We also make the base inexact so
8321 that scm_integer_expt will use fast inexact arithmetic
8322 internally. Note that making the base inexact is not
8323 sufficient to guarantee an inexact result, because
8324 scm_integer_expt will return an exact 1 when the exponent
8325 is 0, even if the base is inexact. */
8326 return scm_exact_to_inexact
8327 (scm_integer_expt (scm_exact_to_inexact (x
),
8328 scm_inexact_to_exact (y
)));
8331 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8333 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8335 else if (scm_is_complex (x
) && scm_is_complex (y
))
8336 return scm_exp (scm_product (scm_log (x
), y
));
8337 else if (scm_is_complex (x
))
8338 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8340 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8344 /* sin/cos/tan/asin/acos/atan
8345 sinh/cosh/tanh/asinh/acosh/atanh
8346 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8347 Written by Jerry D. Hedden, (C) FSF.
8348 See the file `COPYING' for terms applying to this program. */
8350 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8352 "Compute the sine of @var{z}.")
8353 #define FUNC_NAME s_scm_sin
8355 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8356 return z
; /* sin(exact0) = exact0 */
8357 else if (scm_is_real (z
))
8358 return scm_from_double (sin (scm_to_double (z
)));
8359 else if (SCM_COMPLEXP (z
))
8361 x
= SCM_COMPLEX_REAL (z
);
8362 y
= SCM_COMPLEX_IMAG (z
);
8363 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8364 cos (x
) * sinh (y
));
8367 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8371 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8373 "Compute the cosine of @var{z}.")
8374 #define FUNC_NAME s_scm_cos
8376 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8377 return SCM_INUM1
; /* cos(exact0) = exact1 */
8378 else if (scm_is_real (z
))
8379 return scm_from_double (cos (scm_to_double (z
)));
8380 else if (SCM_COMPLEXP (z
))
8382 x
= SCM_COMPLEX_REAL (z
);
8383 y
= SCM_COMPLEX_IMAG (z
);
8384 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8385 -sin (x
) * sinh (y
));
8388 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8392 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8394 "Compute the tangent of @var{z}.")
8395 #define FUNC_NAME s_scm_tan
8397 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8398 return z
; /* tan(exact0) = exact0 */
8399 else if (scm_is_real (z
))
8400 return scm_from_double (tan (scm_to_double (z
)));
8401 else if (SCM_COMPLEXP (z
))
8403 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8404 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8405 w
= cos (x
) + cosh (y
);
8406 #ifndef ALLOW_DIVIDE_BY_ZERO
8408 scm_num_overflow (s_scm_tan
);
8410 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8413 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8417 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8419 "Compute the hyperbolic sine of @var{z}.")
8420 #define FUNC_NAME s_scm_sinh
8422 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8423 return z
; /* sinh(exact0) = exact0 */
8424 else if (scm_is_real (z
))
8425 return scm_from_double (sinh (scm_to_double (z
)));
8426 else if (SCM_COMPLEXP (z
))
8428 x
= SCM_COMPLEX_REAL (z
);
8429 y
= SCM_COMPLEX_IMAG (z
);
8430 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8431 cosh (x
) * sin (y
));
8434 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8438 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8440 "Compute the hyperbolic cosine of @var{z}.")
8441 #define FUNC_NAME s_scm_cosh
8443 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8444 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8445 else if (scm_is_real (z
))
8446 return scm_from_double (cosh (scm_to_double (z
)));
8447 else if (SCM_COMPLEXP (z
))
8449 x
= SCM_COMPLEX_REAL (z
);
8450 y
= SCM_COMPLEX_IMAG (z
);
8451 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8452 sinh (x
) * sin (y
));
8455 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8459 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8461 "Compute the hyperbolic tangent of @var{z}.")
8462 #define FUNC_NAME s_scm_tanh
8464 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8465 return z
; /* tanh(exact0) = exact0 */
8466 else if (scm_is_real (z
))
8467 return scm_from_double (tanh (scm_to_double (z
)));
8468 else if (SCM_COMPLEXP (z
))
8470 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8471 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8472 w
= cosh (x
) + cos (y
);
8473 #ifndef ALLOW_DIVIDE_BY_ZERO
8475 scm_num_overflow (s_scm_tanh
);
8477 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8480 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8484 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8486 "Compute the arc sine of @var{z}.")
8487 #define FUNC_NAME s_scm_asin
8489 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8490 return z
; /* asin(exact0) = exact0 */
8491 else if (scm_is_real (z
))
8493 double w
= scm_to_double (z
);
8494 if (w
>= -1.0 && w
<= 1.0)
8495 return scm_from_double (asin (w
));
8497 return scm_product (scm_c_make_rectangular (0, -1),
8498 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8500 else if (SCM_COMPLEXP (z
))
8502 x
= SCM_COMPLEX_REAL (z
);
8503 y
= SCM_COMPLEX_IMAG (z
);
8504 return scm_product (scm_c_make_rectangular (0, -1),
8505 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8508 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8512 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8514 "Compute the arc cosine of @var{z}.")
8515 #define FUNC_NAME s_scm_acos
8517 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8518 return SCM_INUM0
; /* acos(exact1) = exact0 */
8519 else if (scm_is_real (z
))
8521 double w
= scm_to_double (z
);
8522 if (w
>= -1.0 && w
<= 1.0)
8523 return scm_from_double (acos (w
));
8525 return scm_sum (scm_from_double (acos (0.0)),
8526 scm_product (scm_c_make_rectangular (0, 1),
8527 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8529 else if (SCM_COMPLEXP (z
))
8531 x
= SCM_COMPLEX_REAL (z
);
8532 y
= SCM_COMPLEX_IMAG (z
);
8533 return scm_sum (scm_from_double (acos (0.0)),
8534 scm_product (scm_c_make_rectangular (0, 1),
8535 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8538 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8542 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8544 "With one argument, compute the arc tangent of @var{z}.\n"
8545 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8546 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8547 #define FUNC_NAME s_scm_atan
8551 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8552 return z
; /* atan(exact0) = exact0 */
8553 else if (scm_is_real (z
))
8554 return scm_from_double (atan (scm_to_double (z
)));
8555 else if (SCM_COMPLEXP (z
))
8558 v
= SCM_COMPLEX_REAL (z
);
8559 w
= SCM_COMPLEX_IMAG (z
);
8560 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8561 scm_c_make_rectangular (v
, w
+ 1.0))),
8562 scm_c_make_rectangular (0, 2));
8565 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8567 else if (scm_is_real (z
))
8569 if (scm_is_real (y
))
8570 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8572 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8575 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8579 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8581 "Compute the inverse hyperbolic sine of @var{z}.")
8582 #define FUNC_NAME s_scm_sys_asinh
8584 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8585 return z
; /* asinh(exact0) = exact0 */
8586 else if (scm_is_real (z
))
8587 return scm_from_double (asinh (scm_to_double (z
)));
8588 else if (scm_is_number (z
))
8589 return scm_log (scm_sum (z
,
8590 scm_sqrt (scm_sum (scm_product (z
, z
),
8593 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8597 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8599 "Compute the inverse hyperbolic cosine of @var{z}.")
8600 #define FUNC_NAME s_scm_sys_acosh
8602 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8603 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8604 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8605 return scm_from_double (acosh (scm_to_double (z
)));
8606 else if (scm_is_number (z
))
8607 return scm_log (scm_sum (z
,
8608 scm_sqrt (scm_difference (scm_product (z
, z
),
8611 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8615 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8617 "Compute the inverse hyperbolic tangent of @var{z}.")
8618 #define FUNC_NAME s_scm_sys_atanh
8620 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8621 return z
; /* atanh(exact0) = exact0 */
8622 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8623 return scm_from_double (atanh (scm_to_double (z
)));
8624 else if (scm_is_number (z
))
8625 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8626 scm_difference (SCM_INUM1
, z
))),
8629 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8634 scm_c_make_rectangular (double re
, double im
)
8638 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8640 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8641 SCM_COMPLEX_REAL (z
) = re
;
8642 SCM_COMPLEX_IMAG (z
) = im
;
8646 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8647 (SCM real_part
, SCM imaginary_part
),
8648 "Return a complex number constructed of the given @var{real-part} "
8649 "and @var{imaginary-part} parts.")
8650 #define FUNC_NAME s_scm_make_rectangular
8652 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8653 SCM_ARG1
, FUNC_NAME
, "real");
8654 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8655 SCM_ARG2
, FUNC_NAME
, "real");
8657 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8658 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8661 return scm_c_make_rectangular (scm_to_double (real_part
),
8662 scm_to_double (imaginary_part
));
8667 scm_c_make_polar (double mag
, double ang
)
8671 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8672 use it on Glibc-based systems that have it (it's a GNU extension). See
8673 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8675 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8676 sincos (ang
, &s
, &c
);
8682 /* If s and c are NaNs, this indicates that the angle is a NaN,
8683 infinite, or perhaps simply too large to determine its value
8684 mod 2*pi. However, we know something that the floating-point
8685 implementation doesn't know: We know that s and c are finite.
8686 Therefore, if the magnitude is zero, return a complex zero.
8688 The reason we check for the NaNs instead of using this case
8689 whenever mag == 0.0 is because when the angle is known, we'd
8690 like to return the correct kind of non-real complex zero:
8691 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8692 on which quadrant the angle is in.
8694 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8695 return scm_c_make_rectangular (0.0, 0.0);
8697 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8700 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8702 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8703 #define FUNC_NAME s_scm_make_polar
8705 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8706 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8708 /* If mag is exact0, return exact0 */
8709 if (scm_is_eq (mag
, SCM_INUM0
))
8711 /* Return a real if ang is exact0 */
8712 else if (scm_is_eq (ang
, SCM_INUM0
))
8715 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8720 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8722 "Return the real part of the number @var{z}.")
8723 #define FUNC_NAME s_scm_real_part
8725 if (SCM_COMPLEXP (z
))
8726 return scm_from_double (SCM_COMPLEX_REAL (z
));
8727 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8730 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8735 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8737 "Return the imaginary part of the number @var{z}.")
8738 #define FUNC_NAME s_scm_imag_part
8740 if (SCM_COMPLEXP (z
))
8741 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8742 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8745 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8749 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8751 "Return the numerator of the number @var{z}.")
8752 #define FUNC_NAME s_scm_numerator
8754 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8756 else if (SCM_FRACTIONP (z
))
8757 return SCM_FRACTION_NUMERATOR (z
);
8758 else if (SCM_REALP (z
))
8759 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8761 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8766 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8768 "Return the denominator of the number @var{z}.")
8769 #define FUNC_NAME s_scm_denominator
8771 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8773 else if (SCM_FRACTIONP (z
))
8774 return SCM_FRACTION_DENOMINATOR (z
);
8775 else if (SCM_REALP (z
))
8776 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8778 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8783 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8785 "Return the magnitude of the number @var{z}. This is the same as\n"
8786 "@code{abs} for real arguments, but also allows complex numbers.")
8787 #define FUNC_NAME s_scm_magnitude
8789 if (SCM_I_INUMP (z
))
8791 scm_t_inum zz
= SCM_I_INUM (z
);
8794 else if (SCM_POSFIXABLE (-zz
))
8795 return SCM_I_MAKINUM (-zz
);
8797 return scm_i_inum2big (-zz
);
8799 else if (SCM_BIGP (z
))
8801 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8802 scm_remember_upto_here_1 (z
);
8804 return scm_i_clonebig (z
, 0);
8808 else if (SCM_REALP (z
))
8809 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8810 else if (SCM_COMPLEXP (z
))
8811 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8812 else if (SCM_FRACTIONP (z
))
8814 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8816 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8817 SCM_FRACTION_DENOMINATOR (z
));
8820 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8825 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8827 "Return the angle of the complex number @var{z}.")
8828 #define FUNC_NAME s_scm_angle
8830 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8831 flo0 to save allocating a new flonum with scm_from_double each time.
8832 But if atan2 follows the floating point rounding mode, then the value
8833 is not a constant. Maybe it'd be close enough though. */
8834 if (SCM_I_INUMP (z
))
8836 if (SCM_I_INUM (z
) >= 0)
8839 return scm_from_double (atan2 (0.0, -1.0));
8841 else if (SCM_BIGP (z
))
8843 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8844 scm_remember_upto_here_1 (z
);
8846 return scm_from_double (atan2 (0.0, -1.0));
8850 else if (SCM_REALP (z
))
8852 if (SCM_REAL_VALUE (z
) >= 0)
8855 return scm_from_double (atan2 (0.0, -1.0));
8857 else if (SCM_COMPLEXP (z
))
8858 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8859 else if (SCM_FRACTIONP (z
))
8861 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8863 else return scm_from_double (atan2 (0.0, -1.0));
8866 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8871 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8873 "Convert the number @var{z} to its inexact representation.\n")
8874 #define FUNC_NAME s_scm_exact_to_inexact
8876 if (SCM_I_INUMP (z
))
8877 return scm_from_double ((double) SCM_I_INUM (z
));
8878 else if (SCM_BIGP (z
))
8879 return scm_from_double (scm_i_big2dbl (z
));
8880 else if (SCM_FRACTIONP (z
))
8881 return scm_from_double (scm_i_fraction2double (z
));
8882 else if (SCM_INEXACTP (z
))
8885 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
8890 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8892 "Return an exact number that is numerically closest to @var{z}.")
8893 #define FUNC_NAME s_scm_inexact_to_exact
8895 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8902 val
= SCM_REAL_VALUE (z
);
8903 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8904 val
= SCM_COMPLEX_REAL (z
);
8906 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
8908 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8909 SCM_OUT_OF_RANGE (1, z
);
8916 mpq_set_d (frac
, val
);
8917 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8918 scm_i_mpz2num (mpq_denref (frac
)));
8920 /* When scm_i_make_ratio throws, we leak the memory allocated
8930 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8932 "Returns the @emph{simplest} rational number differing\n"
8933 "from @var{x} by no more than @var{eps}.\n"
8935 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8936 "exact result when both its arguments are exact. Thus, you might need\n"
8937 "to use @code{inexact->exact} on the arguments.\n"
8940 "(rationalize (inexact->exact 1.2) 1/100)\n"
8943 #define FUNC_NAME s_scm_rationalize
8945 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
8946 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
8947 eps
= scm_abs (eps
);
8948 if (scm_is_false (scm_positive_p (eps
)))
8950 /* eps is either zero or a NaN */
8951 if (scm_is_true (scm_nan_p (eps
)))
8953 else if (SCM_INEXACTP (eps
))
8954 return scm_exact_to_inexact (x
);
8958 else if (scm_is_false (scm_finite_p (eps
)))
8960 if (scm_is_true (scm_finite_p (x
)))
8965 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
8967 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
8968 scm_ceiling (scm_difference (x
, eps
)))))
8970 /* There's an integer within range; we want the one closest to zero */
8971 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
8973 /* zero is within range */
8974 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
8979 else if (scm_is_true (scm_positive_p (x
)))
8980 return scm_ceiling (scm_difference (x
, eps
));
8982 return scm_floor (scm_sum (x
, eps
));
8986 /* Use continued fractions to find closest ratio. All
8987 arithmetic is done with exact numbers.
8990 SCM ex
= scm_inexact_to_exact (x
);
8991 SCM int_part
= scm_floor (ex
);
8993 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
8994 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
8998 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
8999 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9001 /* We stop after a million iterations just to be absolutely sure
9002 that we don't go into an infinite loop. The process normally
9003 converges after less than a dozen iterations.
9006 while (++i
< 1000000)
9008 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9009 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9010 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9012 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9013 eps
))) /* abs(x-a/b) <= eps */
9015 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9016 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9017 return scm_exact_to_inexact (res
);
9021 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9023 tt
= scm_floor (rx
); /* tt = floor (rx) */
9029 scm_num_overflow (s_scm_rationalize
);
9034 /* conversion functions */
9037 scm_is_integer (SCM val
)
9039 return scm_is_true (scm_integer_p (val
));
9043 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9045 if (SCM_I_INUMP (val
))
9047 scm_t_signed_bits n
= SCM_I_INUM (val
);
9048 return n
>= min
&& n
<= max
;
9050 else if (SCM_BIGP (val
))
9052 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9054 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9056 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9058 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9059 return n
>= min
&& n
<= max
;
9069 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9070 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9073 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9074 SCM_I_BIG_MPZ (val
));
9076 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9088 return n
>= min
&& n
<= max
;
9096 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9098 if (SCM_I_INUMP (val
))
9100 scm_t_signed_bits n
= SCM_I_INUM (val
);
9101 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9103 else if (SCM_BIGP (val
))
9105 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9107 else if (max
<= ULONG_MAX
)
9109 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9111 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9112 return n
>= min
&& n
<= max
;
9122 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9125 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9126 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9129 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9130 SCM_I_BIG_MPZ (val
));
9132 return n
>= min
&& n
<= max
;
9140 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9142 scm_error (scm_out_of_range_key
,
9144 "Value out of range ~S to ~S: ~S",
9145 scm_list_3 (min
, max
, bad_val
),
9146 scm_list_1 (bad_val
));
9149 #define TYPE scm_t_intmax
9150 #define TYPE_MIN min
9151 #define TYPE_MAX max
9152 #define SIZEOF_TYPE 0
9153 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9154 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9155 #include "libguile/conv-integer.i.c"
9157 #define TYPE scm_t_uintmax
9158 #define TYPE_MIN min
9159 #define TYPE_MAX max
9160 #define SIZEOF_TYPE 0
9161 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9162 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9163 #include "libguile/conv-uinteger.i.c"
9165 #define TYPE scm_t_int8
9166 #define TYPE_MIN SCM_T_INT8_MIN
9167 #define TYPE_MAX SCM_T_INT8_MAX
9168 #define SIZEOF_TYPE 1
9169 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9170 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9171 #include "libguile/conv-integer.i.c"
9173 #define TYPE scm_t_uint8
9175 #define TYPE_MAX SCM_T_UINT8_MAX
9176 #define SIZEOF_TYPE 1
9177 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9178 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9179 #include "libguile/conv-uinteger.i.c"
9181 #define TYPE scm_t_int16
9182 #define TYPE_MIN SCM_T_INT16_MIN
9183 #define TYPE_MAX SCM_T_INT16_MAX
9184 #define SIZEOF_TYPE 2
9185 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9186 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9187 #include "libguile/conv-integer.i.c"
9189 #define TYPE scm_t_uint16
9191 #define TYPE_MAX SCM_T_UINT16_MAX
9192 #define SIZEOF_TYPE 2
9193 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9194 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9195 #include "libguile/conv-uinteger.i.c"
9197 #define TYPE scm_t_int32
9198 #define TYPE_MIN SCM_T_INT32_MIN
9199 #define TYPE_MAX SCM_T_INT32_MAX
9200 #define SIZEOF_TYPE 4
9201 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9202 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9203 #include "libguile/conv-integer.i.c"
9205 #define TYPE scm_t_uint32
9207 #define TYPE_MAX SCM_T_UINT32_MAX
9208 #define SIZEOF_TYPE 4
9209 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9210 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9211 #include "libguile/conv-uinteger.i.c"
9213 #define TYPE scm_t_wchar
9214 #define TYPE_MIN (scm_t_int32)-1
9215 #define TYPE_MAX (scm_t_int32)0x10ffff
9216 #define SIZEOF_TYPE 4
9217 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9218 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9219 #include "libguile/conv-integer.i.c"
9221 #define TYPE scm_t_int64
9222 #define TYPE_MIN SCM_T_INT64_MIN
9223 #define TYPE_MAX SCM_T_INT64_MAX
9224 #define SIZEOF_TYPE 8
9225 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9226 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9227 #include "libguile/conv-integer.i.c"
9229 #define TYPE scm_t_uint64
9231 #define TYPE_MAX SCM_T_UINT64_MAX
9232 #define SIZEOF_TYPE 8
9233 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9234 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9235 #include "libguile/conv-uinteger.i.c"
9238 scm_to_mpz (SCM val
, mpz_t rop
)
9240 if (SCM_I_INUMP (val
))
9241 mpz_set_si (rop
, SCM_I_INUM (val
));
9242 else if (SCM_BIGP (val
))
9243 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9245 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9249 scm_from_mpz (mpz_t val
)
9251 return scm_i_mpz2num (val
);
9255 scm_is_real (SCM val
)
9257 return scm_is_true (scm_real_p (val
));
9261 scm_is_rational (SCM val
)
9263 return scm_is_true (scm_rational_p (val
));
9267 scm_to_double (SCM val
)
9269 if (SCM_I_INUMP (val
))
9270 return SCM_I_INUM (val
);
9271 else if (SCM_BIGP (val
))
9272 return scm_i_big2dbl (val
);
9273 else if (SCM_FRACTIONP (val
))
9274 return scm_i_fraction2double (val
);
9275 else if (SCM_REALP (val
))
9276 return SCM_REAL_VALUE (val
);
9278 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9282 scm_from_double (double val
)
9286 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9288 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9289 SCM_REAL_VALUE (z
) = val
;
9294 #if SCM_ENABLE_DEPRECATED == 1
9297 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9299 scm_c_issue_deprecation_warning
9300 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9304 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9308 scm_out_of_range (NULL
, num
);
9311 return scm_to_double (num
);
9315 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9317 scm_c_issue_deprecation_warning
9318 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9322 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9326 scm_out_of_range (NULL
, num
);
9329 return scm_to_double (num
);
9335 scm_is_complex (SCM val
)
9337 return scm_is_true (scm_complex_p (val
));
9341 scm_c_real_part (SCM z
)
9343 if (SCM_COMPLEXP (z
))
9344 return SCM_COMPLEX_REAL (z
);
9347 /* Use the scm_real_part to get proper error checking and
9350 return scm_to_double (scm_real_part (z
));
9355 scm_c_imag_part (SCM z
)
9357 if (SCM_COMPLEXP (z
))
9358 return SCM_COMPLEX_IMAG (z
);
9361 /* Use the scm_imag_part to get proper error checking and
9362 dispatching. The result will almost always be 0.0, but not
9365 return scm_to_double (scm_imag_part (z
));
9370 scm_c_magnitude (SCM z
)
9372 return scm_to_double (scm_magnitude (z
));
9378 return scm_to_double (scm_angle (z
));
9382 scm_is_number (SCM z
)
9384 return scm_is_true (scm_number_p (z
));
9388 /* Returns log(x * 2^shift) */
9390 log_of_shifted_double (double x
, long shift
)
9392 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9394 if (x
> 0.0 || double_is_non_negative_zero (x
))
9395 return scm_from_double (ans
);
9397 return scm_c_make_rectangular (ans
, M_PI
);
9400 /* Returns log(n), for exact integer n of integer-length size */
9402 log_of_exact_integer_with_size (SCM n
, long size
)
9404 long shift
= size
- 2 * scm_dblprec
[0];
9407 return log_of_shifted_double
9408 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9411 return log_of_shifted_double (scm_to_double (n
), 0);
9414 /* Returns log(n), for exact integer n */
9416 log_of_exact_integer (SCM n
)
9418 return log_of_exact_integer_with_size
9419 (n
, scm_to_long (scm_integer_length (n
)));
9422 /* Returns log(n/d), for exact non-zero integers n and d */
9424 log_of_fraction (SCM n
, SCM d
)
9426 long n_size
= scm_to_long (scm_integer_length (n
));
9427 long d_size
= scm_to_long (scm_integer_length (d
));
9429 if (abs (n_size
- d_size
) > 1)
9430 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9431 log_of_exact_integer_with_size (d
, d_size
)));
9432 else if (scm_is_false (scm_negative_p (n
)))
9433 return scm_from_double
9434 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9436 return scm_c_make_rectangular
9437 (log1p (scm_to_double (scm_divide2real
9438 (scm_difference (scm_abs (n
), d
),
9444 /* In the following functions we dispatch to the real-arg funcs like log()
9445 when we know the arg is real, instead of just handing everything to
9446 clog() for instance. This is in case clog() doesn't optimize for a
9447 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9448 well use it to go straight to the applicable C func. */
9450 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9452 "Return the natural logarithm of @var{z}.")
9453 #define FUNC_NAME s_scm_log
9455 if (SCM_COMPLEXP (z
))
9457 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9458 && defined (SCM_COMPLEX_VALUE)
9459 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9461 double re
= SCM_COMPLEX_REAL (z
);
9462 double im
= SCM_COMPLEX_IMAG (z
);
9463 return scm_c_make_rectangular (log (hypot (re
, im
)),
9467 else if (SCM_REALP (z
))
9468 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9469 else if (SCM_I_INUMP (z
))
9471 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9472 if (scm_is_eq (z
, SCM_INUM0
))
9473 scm_num_overflow (s_scm_log
);
9475 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9477 else if (SCM_BIGP (z
))
9478 return log_of_exact_integer (z
);
9479 else if (SCM_FRACTIONP (z
))
9480 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9481 SCM_FRACTION_DENOMINATOR (z
));
9483 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9488 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9490 "Return the base 10 logarithm of @var{z}.")
9491 #define FUNC_NAME s_scm_log10
9493 if (SCM_COMPLEXP (z
))
9495 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9496 clog() and a multiply by M_LOG10E, rather than the fallback
9497 log10+hypot+atan2.) */
9498 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9499 && defined SCM_COMPLEX_VALUE
9500 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9502 double re
= SCM_COMPLEX_REAL (z
);
9503 double im
= SCM_COMPLEX_IMAG (z
);
9504 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9505 M_LOG10E
* atan2 (im
, re
));
9508 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9510 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9511 if (scm_is_eq (z
, SCM_INUM0
))
9512 scm_num_overflow (s_scm_log10
);
9515 double re
= scm_to_double (z
);
9516 double l
= log10 (fabs (re
));
9517 if (re
> 0.0 || double_is_non_negative_zero (re
))
9518 return scm_from_double (l
);
9520 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9523 else if (SCM_BIGP (z
))
9524 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9525 else if (SCM_FRACTIONP (z
))
9526 return scm_product (flo_log10e
,
9527 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9528 SCM_FRACTION_DENOMINATOR (z
)));
9530 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9535 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9537 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9538 "base of natural logarithms (2.71828@dots{}).")
9539 #define FUNC_NAME s_scm_exp
9541 if (SCM_COMPLEXP (z
))
9543 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9544 && defined (SCM_COMPLEX_VALUE)
9545 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9547 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9548 SCM_COMPLEX_IMAG (z
));
9551 else if (SCM_NUMBERP (z
))
9553 /* When z is a negative bignum the conversion to double overflows,
9554 giving -infinity, but that's ok, the exp is still 0.0. */
9555 return scm_from_double (exp (scm_to_double (z
)));
9558 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9563 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9565 "Return two exact non-negative integers @var{s} and @var{r}\n"
9566 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9567 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9568 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9571 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9573 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9577 scm_exact_integer_sqrt (k
, &s
, &r
);
9578 return scm_values (scm_list_2 (s
, r
));
9583 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9585 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9587 scm_t_inum kk
= SCM_I_INUM (k
);
9591 if (SCM_LIKELY (kk
> 0))
9596 uu
= (ss
+ kk
/ss
) / 2;
9598 *sp
= SCM_I_MAKINUM (ss
);
9599 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9601 else if (SCM_LIKELY (kk
== 0))
9602 *sp
= *rp
= SCM_INUM0
;
9604 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9605 "exact non-negative integer");
9607 else if (SCM_LIKELY (SCM_BIGP (k
)))
9611 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9612 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9613 "exact non-negative integer");
9616 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9617 scm_remember_upto_here_1 (k
);
9618 *sp
= scm_i_normbig (s
);
9619 *rp
= scm_i_normbig (r
);
9622 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9623 "exact non-negative integer");
9627 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9629 "Return the square root of @var{z}. Of the two possible roots\n"
9630 "(positive and negative), the one with positive real part\n"
9631 "is returned, or if that's zero then a positive imaginary part.\n"
9635 "(sqrt 9.0) @result{} 3.0\n"
9636 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9637 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9638 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9640 #define FUNC_NAME s_scm_sqrt
9642 if (SCM_COMPLEXP (z
))
9644 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9645 && defined SCM_COMPLEX_VALUE
9646 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9648 double re
= SCM_COMPLEX_REAL (z
);
9649 double im
= SCM_COMPLEX_IMAG (z
);
9650 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9651 0.5 * atan2 (im
, re
));
9654 else if (SCM_NUMBERP (z
))
9656 double xx
= scm_to_double (z
);
9658 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9660 return scm_from_double (sqrt (xx
));
9663 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9674 mpz_init_set_si (z_negative_one
, -1);
9676 /* It may be possible to tune the performance of some algorithms by using
9677 * the following constants to avoid the creation of bignums. Please, before
9678 * using these values, remember the two rules of program optimization:
9679 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9680 scm_c_define ("most-positive-fixnum",
9681 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9682 scm_c_define ("most-negative-fixnum",
9683 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9685 scm_add_feature ("complex");
9686 scm_add_feature ("inexact");
9687 flo0
= scm_from_double (0.0);
9688 flo_log10e
= scm_from_double (M_LOG10E
);
9690 /* determine floating point precision */
9691 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9693 init_dblprec(&scm_dblprec
[i
-2],i
);
9694 init_fx_radix(fx_per_radix
[i
-2],i
);
9697 /* hard code precision for base 10 if the preprocessor tells us to... */
9698 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9701 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9702 #include "libguile/numbers.x"