1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 /* General assumptions:
25 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
26 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
27 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
28 * XXX What about infinities? They are equal to their own floor! -mhw
29 * All objects satisfying SCM_FRACTIONP are never an integer.
34 - see if special casing bignums and reals in integer-exponent when
35 possible (to use mpz_pow and mpf_pow_ui) is faster.
37 - look in to better short-circuiting of common cases in
38 integer-expt and elsewhere.
40 - see if direct mpz operations can help in ash and elsewhere.
59 #include "libguile/_scm.h"
60 #include "libguile/feature.h"
61 #include "libguile/ports.h"
62 #include "libguile/root.h"
63 #include "libguile/smob.h"
64 #include "libguile/strings.h"
65 #include "libguile/bdw-gc.h"
67 #include "libguile/validate.h"
68 #include "libguile/numbers.h"
69 #include "libguile/deprecation.h"
71 #include "libguile/eq.h"
73 /* values per glibc, if not already defined */
75 #define M_LOG10E 0.43429448190325182765
78 #define M_LN2 0.69314718055994530942
81 #define M_PI 3.14159265358979323846
84 typedef scm_t_signed_bits scm_t_inum
;
85 #define scm_from_inum(x) (scm_from_signed_integer (x))
87 /* Tests to see if a C double is neither infinite nor a NaN.
88 TODO: if it's available, use C99's isfinite(x) instead */
89 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
91 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
92 of the infinity, but other platforms return a boolean only. */
93 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
94 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
99 Wonder if this might be faster for some of our code? A switch on
100 the numtag would jump directly to the right case, and the
101 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
103 #define SCM_I_NUMTAG_NOTNUM 0
104 #define SCM_I_NUMTAG_INUM 1
105 #define SCM_I_NUMTAG_BIG scm_tc16_big
106 #define SCM_I_NUMTAG_REAL scm_tc16_real
107 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
108 #define SCM_I_NUMTAG(x) \
109 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
110 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
111 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
112 : SCM_I_NUMTAG_NOTNUM)))
114 /* the macro above will not work as is with fractions */
117 /* Default to 1, because as we used to hard-code `free' as the
118 deallocator, we know that overriding these functions with
119 instrumented `malloc' / `free' is OK. */
120 int scm_install_gmp_memory_functions
= 1;
122 static SCM exactly_one_half
;
123 static SCM flo_log10e
;
125 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
127 /* FLOBUFLEN is the maximum number of characters neccessary for the
128 * printed or scm_string representation of an inexact number.
130 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
133 #if !defined (HAVE_ASINH)
134 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
136 #if !defined (HAVE_ACOSH)
137 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
139 #if !defined (HAVE_ATANH)
140 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
143 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
144 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
145 in March 2006), mpz_cmp_d now handles infinities properly. */
147 #define xmpz_cmp_d(z, d) \
148 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
150 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
154 #if defined (GUILE_I)
155 #if defined HAVE_COMPLEX_DOUBLE
157 /* For an SCM object Z which is a complex number (ie. satisfies
158 SCM_COMPLEXP), return its value as a C level "complex double". */
159 #define SCM_COMPLEX_VALUE(z) \
160 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
162 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
164 /* Convert a C "complex double" to an SCM value. */
166 scm_from_complex_double (complex double z
)
168 return scm_c_make_rectangular (creal (z
), cimag (z
));
171 #endif /* HAVE_COMPLEX_DOUBLE */
176 static mpz_t z_negative_one
;
180 /* Clear the `mpz_t' embedded in bignum PTR. */
182 finalize_bignum (void *ptr
, void *data
)
186 bignum
= PTR2SCM (ptr
);
187 mpz_clear (SCM_I_BIG_MPZ (bignum
));
190 /* The next three functions (custom_libgmp_*) are passed to
191 mp_set_memory_functions (in GMP) so that memory used by the digits
192 themselves is known to the garbage collector. This is needed so
193 that GC will be run at appropriate times. Otherwise, a program which
194 creates many large bignums would malloc a huge amount of memory
195 before the GC runs. */
197 custom_gmp_malloc (size_t alloc_size
)
199 return scm_malloc (alloc_size
);
203 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
205 return scm_realloc (old_ptr
, new_size
);
209 custom_gmp_free (void *ptr
, size_t size
)
215 /* Return a new uninitialized bignum. */
221 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
222 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
226 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
235 /* Return a newly created bignum. */
236 SCM z
= make_bignum ();
237 mpz_init (SCM_I_BIG_MPZ (z
));
242 scm_i_inum2big (scm_t_inum x
)
244 /* Return a newly created bignum initialized to X. */
245 SCM z
= make_bignum ();
246 #if SIZEOF_VOID_P == SIZEOF_LONG
247 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
249 /* Note that in this case, you'll also have to check all mpz_*_ui and
250 mpz_*_si invocations in Guile. */
251 #error creation of mpz not implemented for this inum size
257 scm_i_long2big (long x
)
259 /* Return a newly created bignum initialized to X. */
260 SCM z
= make_bignum ();
261 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
266 scm_i_ulong2big (unsigned long x
)
268 /* Return a newly created bignum initialized to X. */
269 SCM z
= make_bignum ();
270 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
275 scm_i_clonebig (SCM src_big
, int same_sign_p
)
277 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
278 SCM z
= make_bignum ();
279 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
281 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
286 scm_i_bigcmp (SCM x
, SCM y
)
288 /* Return neg if x < y, pos if x > y, and 0 if x == y */
289 /* presume we already know x and y are bignums */
290 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
291 scm_remember_upto_here_2 (x
, y
);
296 scm_i_dbl2big (double d
)
298 /* results are only defined if d is an integer */
299 SCM z
= make_bignum ();
300 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
304 /* Convert a integer in double representation to a SCM number. */
307 scm_i_dbl2num (double u
)
309 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
310 powers of 2, so there's no rounding when making "double" values
311 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
312 get rounded on a 64-bit machine, hence the "+1".
314 The use of floor() to force to an integer value ensures we get a
315 "numerically closest" value without depending on how a
316 double->long cast or how mpz_set_d will round. For reference,
317 double->long probably follows the hardware rounding mode,
318 mpz_set_d truncates towards zero. */
320 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
321 representable as a double? */
323 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
324 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
325 return SCM_I_MAKINUM ((scm_t_inum
) u
);
327 return scm_i_dbl2big (u
);
330 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
331 with R5RS exact->inexact.
333 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
334 (ie. truncate towards zero), then adjust to get the closest double by
335 examining the next lower bit and adding 1 (to the absolute value) if
338 Bignums exactly half way between representable doubles are rounded to the
339 next higher absolute value (ie. away from zero). This seems like an
340 adequate interpretation of R5RS "numerically closest", and it's easier
341 and faster than a full "nearest-even" style.
343 The bit test must be done on the absolute value of the mpz_t, which means
344 we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
345 negatives as twos complement.
347 In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
348 following the hardware rounding mode, but applied to the absolute
349 value of the mpz_t operand. This is not what we want so we put the
350 high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
351 (released in March 2006) mpz_get_d now always truncates towards zero.
353 ENHANCE-ME: The temporary init+clear to force the rounding in GMP
354 before 4.2 is a slowdown. It'd be faster to pick out the relevant
355 high bits with mpz_getlimbn. */
358 scm_i_big2dbl (SCM b
)
363 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
367 /* For GMP earlier than 4.2, force truncation towards zero */
369 /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
370 _not_ the number of bits, so this code will break badly on a
371 system with non-binary doubles. */
374 if (bits
> DBL_MANT_DIG
)
376 size_t shift
= bits
- DBL_MANT_DIG
;
377 mpz_init2 (tmp
, DBL_MANT_DIG
);
378 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
379 result
= ldexp (mpz_get_d (tmp
), shift
);
384 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
388 /* GMP 4.2 or later */
389 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
392 if (bits
> DBL_MANT_DIG
)
394 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
395 /* test bit number "pos" in absolute value */
396 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
397 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
399 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
403 scm_remember_upto_here_1 (b
);
408 scm_i_normbig (SCM b
)
410 /* convert a big back to a fixnum if it'll fit */
411 /* presume b is a bignum */
412 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
414 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
415 if (SCM_FIXABLE (val
))
416 b
= SCM_I_MAKINUM (val
);
421 static SCM_C_INLINE_KEYWORD SCM
422 scm_i_mpz2num (mpz_t b
)
424 /* convert a mpz number to a SCM number. */
425 if (mpz_fits_slong_p (b
))
427 scm_t_inum val
= mpz_get_si (b
);
428 if (SCM_FIXABLE (val
))
429 return SCM_I_MAKINUM (val
);
433 SCM z
= make_bignum ();
434 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
439 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
440 static SCM
scm_divide2real (SCM x
, SCM y
);
443 scm_i_make_ratio (SCM numerator
, SCM denominator
)
444 #define FUNC_NAME "make-ratio"
446 /* First make sure the arguments are proper.
448 if (SCM_I_INUMP (denominator
))
450 if (scm_is_eq (denominator
, SCM_INUM0
))
451 scm_num_overflow ("make-ratio");
452 if (scm_is_eq (denominator
, SCM_INUM1
))
457 if (!(SCM_BIGP(denominator
)))
458 SCM_WRONG_TYPE_ARG (2, denominator
);
460 if (!SCM_I_INUMP (numerator
) && !SCM_BIGP (numerator
))
461 SCM_WRONG_TYPE_ARG (1, numerator
);
463 /* Then flip signs so that the denominator is positive.
465 if (scm_is_true (scm_negative_p (denominator
)))
467 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
468 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
471 /* Now consider for each of the four fixnum/bignum combinations
472 whether the rational number is really an integer.
474 if (SCM_I_INUMP (numerator
))
476 scm_t_inum x
= SCM_I_INUM (numerator
);
477 if (scm_is_eq (numerator
, SCM_INUM0
))
479 if (SCM_I_INUMP (denominator
))
482 y
= SCM_I_INUM (denominator
);
486 return SCM_I_MAKINUM (x
/ y
);
490 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
491 of that value for the denominator, as a bignum. Apart from
492 that case, abs(bignum) > abs(inum) so inum/bignum is not an
494 if (x
== SCM_MOST_NEGATIVE_FIXNUM
495 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
496 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
497 return SCM_I_MAKINUM(-1);
500 else if (SCM_BIGP (numerator
))
502 if (SCM_I_INUMP (denominator
))
504 scm_t_inum yy
= SCM_I_INUM (denominator
);
505 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
506 return scm_divide (numerator
, denominator
);
510 if (scm_is_eq (numerator
, denominator
))
512 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
513 SCM_I_BIG_MPZ (denominator
)))
514 return scm_divide(numerator
, denominator
);
518 /* No, it's a proper fraction.
521 SCM divisor
= scm_gcd (numerator
, denominator
);
522 if (!(scm_is_eq (divisor
, SCM_INUM1
)))
524 numerator
= scm_divide (numerator
, divisor
);
525 denominator
= scm_divide (denominator
, divisor
);
528 return scm_double_cell (scm_tc16_fraction
,
529 SCM_UNPACK (numerator
),
530 SCM_UNPACK (denominator
), 0);
536 scm_i_fraction2double (SCM z
)
538 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
539 SCM_FRACTION_DENOMINATOR (z
)));
543 double_is_non_negative_zero (double x
)
545 static double zero
= 0.0;
547 return !memcmp (&x
, &zero
, sizeof(double));
550 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
552 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
554 #define FUNC_NAME s_scm_exact_p
556 if (SCM_INEXACTP (x
))
558 else if (SCM_NUMBERP (x
))
561 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
566 scm_is_exact (SCM val
)
568 return scm_is_true (scm_exact_p (val
));
571 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
573 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
575 #define FUNC_NAME s_scm_inexact_p
577 if (SCM_INEXACTP (x
))
579 else if (SCM_NUMBERP (x
))
582 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
587 scm_is_inexact (SCM val
)
589 return scm_is_true (scm_inexact_p (val
));
592 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
594 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
596 #define FUNC_NAME s_scm_odd_p
600 scm_t_inum val
= SCM_I_INUM (n
);
601 return scm_from_bool ((val
& 1L) != 0);
603 else if (SCM_BIGP (n
))
605 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
606 scm_remember_upto_here_1 (n
);
607 return scm_from_bool (odd_p
);
609 else if (SCM_REALP (n
))
611 double val
= SCM_REAL_VALUE (n
);
612 if (DOUBLE_IS_FINITE (val
))
614 double rem
= fabs (fmod (val
, 2.0));
621 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
626 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
628 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
630 #define FUNC_NAME s_scm_even_p
634 scm_t_inum val
= SCM_I_INUM (n
);
635 return scm_from_bool ((val
& 1L) == 0);
637 else if (SCM_BIGP (n
))
639 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
640 scm_remember_upto_here_1 (n
);
641 return scm_from_bool (even_p
);
643 else if (SCM_REALP (n
))
645 double val
= SCM_REAL_VALUE (n
);
646 if (DOUBLE_IS_FINITE (val
))
648 double rem
= fabs (fmod (val
, 2.0));
655 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
659 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
661 "Return @code{#t} if the real number @var{x} is neither\n"
662 "infinite nor a NaN, @code{#f} otherwise.")
663 #define FUNC_NAME s_scm_finite_p
666 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
667 else if (scm_is_real (x
))
670 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
674 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
676 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
677 "@samp{-inf.0}. Otherwise return @code{#f}.")
678 #define FUNC_NAME s_scm_inf_p
681 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
682 else if (scm_is_real (x
))
685 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
689 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
691 "Return @code{#t} if the real number @var{x} is a NaN,\n"
692 "or @code{#f} otherwise.")
693 #define FUNC_NAME s_scm_nan_p
696 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
697 else if (scm_is_real (x
))
700 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
704 /* Guile's idea of infinity. */
705 static double guile_Inf
;
707 /* Guile's idea of not a number. */
708 static double guile_NaN
;
711 guile_ieee_init (void)
713 /* Some version of gcc on some old version of Linux used to crash when
714 trying to make Inf and NaN. */
717 /* C99 INFINITY, when available.
718 FIXME: The standard allows for INFINITY to be something that overflows
719 at compile time. We ought to have a configure test to check for that
720 before trying to use it. (But in practice we believe this is not a
721 problem on any system guile is likely to target.) */
722 guile_Inf
= INFINITY
;
723 #elif defined HAVE_DINFINITY
725 extern unsigned int DINFINITY
[2];
726 guile_Inf
= (*((double *) (DINFINITY
)));
733 if (guile_Inf
== tmp
)
740 /* C99 NAN, when available */
742 #elif defined HAVE_DQNAN
745 extern unsigned int DQNAN
[2];
746 guile_NaN
= (*((double *)(DQNAN
)));
749 guile_NaN
= guile_Inf
/ guile_Inf
;
753 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
756 #define FUNC_NAME s_scm_inf
758 static int initialized
= 0;
764 return scm_from_double (guile_Inf
);
768 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
771 #define FUNC_NAME s_scm_nan
773 static int initialized
= 0;
779 return scm_from_double (guile_NaN
);
784 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
786 "Return the absolute value of @var{x}.")
787 #define FUNC_NAME s_scm_abs
791 scm_t_inum xx
= SCM_I_INUM (x
);
794 else if (SCM_POSFIXABLE (-xx
))
795 return SCM_I_MAKINUM (-xx
);
797 return scm_i_inum2big (-xx
);
799 else if (SCM_LIKELY (SCM_REALP (x
)))
801 double xx
= SCM_REAL_VALUE (x
);
802 /* If x is a NaN then xx<0 is false so we return x unchanged */
804 return scm_from_double (-xx
);
805 /* Handle signed zeroes properly */
806 else if (SCM_UNLIKELY (xx
== 0.0))
811 else if (SCM_BIGP (x
))
813 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
815 return scm_i_clonebig (x
, 0);
819 else if (SCM_FRACTIONP (x
))
821 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
823 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
824 SCM_FRACTION_DENOMINATOR (x
));
827 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
832 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
834 "Return the quotient of the numbers @var{x} and @var{y}.")
835 #define FUNC_NAME s_scm_quotient
837 if (SCM_LIKELY (scm_is_integer (x
)))
839 if (SCM_LIKELY (scm_is_integer (y
)))
840 return scm_truncate_quotient (x
, y
);
842 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
845 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
849 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
851 "Return the remainder of the numbers @var{x} and @var{y}.\n"
853 "(remainder 13 4) @result{} 1\n"
854 "(remainder -13 4) @result{} -1\n"
856 #define FUNC_NAME s_scm_remainder
858 if (SCM_LIKELY (scm_is_integer (x
)))
860 if (SCM_LIKELY (scm_is_integer (y
)))
861 return scm_truncate_remainder (x
, y
);
863 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
866 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
871 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
873 "Return the modulo of the numbers @var{x} and @var{y}.\n"
875 "(modulo 13 4) @result{} 1\n"
876 "(modulo -13 4) @result{} 3\n"
878 #define FUNC_NAME s_scm_modulo
880 if (SCM_LIKELY (scm_is_integer (x
)))
882 if (SCM_LIKELY (scm_is_integer (y
)))
883 return scm_floor_remainder (x
, y
);
885 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
888 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
892 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
893 two-valued functions. It is called from primitive generics that take
894 two arguments and return two values, when the core procedure is
895 unable to handle the given argument types. If there are GOOPS
896 methods for this primitive generic, it dispatches to GOOPS and, if
897 successful, expects two values to be returned, which are placed in
898 *rp1 and *rp2. If there are no GOOPS methods, it throws a
899 wrong-type-arg exception.
901 FIXME: This obviously belongs somewhere else, but until we decide on
902 the right API, it is here as a static function, because it is needed
903 by the *_divide functions below.
906 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
907 const char *subr
, SCM
*rp1
, SCM
*rp2
)
910 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
912 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
915 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
917 "Return the integer @var{q} such that\n"
918 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
919 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
921 "(euclidean-quotient 123 10) @result{} 12\n"
922 "(euclidean-quotient 123 -10) @result{} -12\n"
923 "(euclidean-quotient -123 10) @result{} -13\n"
924 "(euclidean-quotient -123 -10) @result{} 13\n"
925 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
926 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
928 #define FUNC_NAME s_scm_euclidean_quotient
930 if (scm_is_false (scm_negative_p (y
)))
931 return scm_floor_quotient (x
, y
);
933 return scm_ceiling_quotient (x
, y
);
937 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
939 "Return the real number @var{r} such that\n"
940 "@math{0 <= @var{r} < abs(@var{y})} and\n"
941 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
942 "for some integer @var{q}.\n"
944 "(euclidean-remainder 123 10) @result{} 3\n"
945 "(euclidean-remainder 123 -10) @result{} 3\n"
946 "(euclidean-remainder -123 10) @result{} 7\n"
947 "(euclidean-remainder -123 -10) @result{} 7\n"
948 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
949 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
951 #define FUNC_NAME s_scm_euclidean_remainder
953 if (scm_is_false (scm_negative_p (y
)))
954 return scm_floor_remainder (x
, y
);
956 return scm_ceiling_remainder (x
, y
);
960 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
962 "Return the integer @var{q} and the real number @var{r}\n"
963 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
964 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
966 "(euclidean/ 123 10) @result{} 12 and 3\n"
967 "(euclidean/ 123 -10) @result{} -12 and 3\n"
968 "(euclidean/ -123 10) @result{} -13 and 7\n"
969 "(euclidean/ -123 -10) @result{} 13 and 7\n"
970 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
971 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
973 #define FUNC_NAME s_scm_i_euclidean_divide
975 if (scm_is_false (scm_negative_p (y
)))
976 return scm_i_floor_divide (x
, y
);
978 return scm_i_ceiling_divide (x
, y
);
983 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
985 if (scm_is_false (scm_negative_p (y
)))
986 return scm_floor_divide (x
, y
, qp
, rp
);
988 return scm_ceiling_divide (x
, y
, qp
, rp
);
991 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
992 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
994 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
996 "Return the floor of @math{@var{x} / @var{y}}.\n"
998 "(floor-quotient 123 10) @result{} 12\n"
999 "(floor-quotient 123 -10) @result{} -13\n"
1000 "(floor-quotient -123 10) @result{} -13\n"
1001 "(floor-quotient -123 -10) @result{} 12\n"
1002 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1003 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1005 #define FUNC_NAME s_scm_floor_quotient
1007 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1009 scm_t_inum xx
= SCM_I_INUM (x
);
1010 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1012 scm_t_inum yy
= SCM_I_INUM (y
);
1013 scm_t_inum xx1
= xx
;
1015 if (SCM_LIKELY (yy
> 0))
1017 if (SCM_UNLIKELY (xx
< 0))
1020 else if (SCM_UNLIKELY (yy
== 0))
1021 scm_num_overflow (s_scm_floor_quotient
);
1025 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1026 return SCM_I_MAKINUM (qq
);
1028 return scm_i_inum2big (qq
);
1030 else if (SCM_BIGP (y
))
1032 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1033 scm_remember_upto_here_1 (y
);
1035 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1037 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1039 else if (SCM_REALP (y
))
1040 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1041 else if (SCM_FRACTIONP (y
))
1042 return scm_i_exact_rational_floor_quotient (x
, y
);
1044 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1045 s_scm_floor_quotient
);
1047 else if (SCM_BIGP (x
))
1049 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1051 scm_t_inum yy
= SCM_I_INUM (y
);
1052 if (SCM_UNLIKELY (yy
== 0))
1053 scm_num_overflow (s_scm_floor_quotient
);
1054 else if (SCM_UNLIKELY (yy
== 1))
1058 SCM q
= scm_i_mkbig ();
1060 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1063 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1064 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1066 scm_remember_upto_here_1 (x
);
1067 return scm_i_normbig (q
);
1070 else if (SCM_BIGP (y
))
1072 SCM q
= scm_i_mkbig ();
1073 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1076 scm_remember_upto_here_2 (x
, y
);
1077 return scm_i_normbig (q
);
1079 else if (SCM_REALP (y
))
1080 return scm_i_inexact_floor_quotient
1081 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1082 else if (SCM_FRACTIONP (y
))
1083 return scm_i_exact_rational_floor_quotient (x
, y
);
1085 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1086 s_scm_floor_quotient
);
1088 else if (SCM_REALP (x
))
1090 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1091 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1092 return scm_i_inexact_floor_quotient
1093 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1095 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1096 s_scm_floor_quotient
);
1098 else if (SCM_FRACTIONP (x
))
1101 return scm_i_inexact_floor_quotient
1102 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1103 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1104 return scm_i_exact_rational_floor_quotient (x
, y
);
1106 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1107 s_scm_floor_quotient
);
1110 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1111 s_scm_floor_quotient
);
1116 scm_i_inexact_floor_quotient (double x
, double y
)
1118 if (SCM_UNLIKELY (y
== 0))
1119 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1121 return scm_from_double (floor (x
/ y
));
1125 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1127 return scm_floor_quotient
1128 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1129 scm_product (scm_numerator (y
), scm_denominator (x
)));
1132 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1133 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1135 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1137 "Return the real number @var{r} such that\n"
1138 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1139 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1141 "(floor-remainder 123 10) @result{} 3\n"
1142 "(floor-remainder 123 -10) @result{} -7\n"
1143 "(floor-remainder -123 10) @result{} 7\n"
1144 "(floor-remainder -123 -10) @result{} -3\n"
1145 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1146 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1148 #define FUNC_NAME s_scm_floor_remainder
1150 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1152 scm_t_inum xx
= SCM_I_INUM (x
);
1153 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1155 scm_t_inum yy
= SCM_I_INUM (y
);
1156 if (SCM_UNLIKELY (yy
== 0))
1157 scm_num_overflow (s_scm_floor_remainder
);
1160 scm_t_inum rr
= xx
% yy
;
1161 int needs_adjustment
;
1163 if (SCM_LIKELY (yy
> 0))
1164 needs_adjustment
= (rr
< 0);
1166 needs_adjustment
= (rr
> 0);
1168 if (needs_adjustment
)
1170 return SCM_I_MAKINUM (rr
);
1173 else if (SCM_BIGP (y
))
1175 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1176 scm_remember_upto_here_1 (y
);
1181 SCM r
= scm_i_mkbig ();
1182 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1183 scm_remember_upto_here_1 (y
);
1184 return scm_i_normbig (r
);
1193 SCM r
= scm_i_mkbig ();
1194 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1195 scm_remember_upto_here_1 (y
);
1196 return scm_i_normbig (r
);
1199 else if (SCM_REALP (y
))
1200 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1201 else if (SCM_FRACTIONP (y
))
1202 return scm_i_exact_rational_floor_remainder (x
, y
);
1204 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1205 s_scm_floor_remainder
);
1207 else if (SCM_BIGP (x
))
1209 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1211 scm_t_inum yy
= SCM_I_INUM (y
);
1212 if (SCM_UNLIKELY (yy
== 0))
1213 scm_num_overflow (s_scm_floor_remainder
);
1218 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1220 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1221 scm_remember_upto_here_1 (x
);
1222 return SCM_I_MAKINUM (rr
);
1225 else if (SCM_BIGP (y
))
1227 SCM r
= scm_i_mkbig ();
1228 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1231 scm_remember_upto_here_2 (x
, y
);
1232 return scm_i_normbig (r
);
1234 else if (SCM_REALP (y
))
1235 return scm_i_inexact_floor_remainder
1236 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1237 else if (SCM_FRACTIONP (y
))
1238 return scm_i_exact_rational_floor_remainder (x
, y
);
1240 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1241 s_scm_floor_remainder
);
1243 else if (SCM_REALP (x
))
1245 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1246 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1247 return scm_i_inexact_floor_remainder
1248 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1250 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1251 s_scm_floor_remainder
);
1253 else if (SCM_FRACTIONP (x
))
1256 return scm_i_inexact_floor_remainder
1257 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1258 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1259 return scm_i_exact_rational_floor_remainder (x
, y
);
1261 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1262 s_scm_floor_remainder
);
1265 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1266 s_scm_floor_remainder
);
1271 scm_i_inexact_floor_remainder (double x
, double y
)
1273 /* Although it would be more efficient to use fmod here, we can't
1274 because it would in some cases produce results inconsistent with
1275 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1276 close). In particular, when x is very close to a multiple of y,
1277 then r might be either 0.0 or y, but those two cases must
1278 correspond to different choices of q. If r = 0.0 then q must be
1279 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1280 and remainder chooses the other, it would be bad. */
1281 if (SCM_UNLIKELY (y
== 0))
1282 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1284 return scm_from_double (x
- y
* floor (x
/ y
));
1288 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1290 SCM xd
= scm_denominator (x
);
1291 SCM yd
= scm_denominator (y
);
1292 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1293 scm_product (scm_numerator (y
), xd
));
1294 return scm_divide (r1
, scm_product (xd
, yd
));
1298 static void scm_i_inexact_floor_divide (double x
, double y
,
1300 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1303 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1305 "Return the integer @var{q} and the real number @var{r}\n"
1306 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1307 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1309 "(floor/ 123 10) @result{} 12 and 3\n"
1310 "(floor/ 123 -10) @result{} -13 and -7\n"
1311 "(floor/ -123 10) @result{} -13 and 7\n"
1312 "(floor/ -123 -10) @result{} 12 and -3\n"
1313 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1314 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1316 #define FUNC_NAME s_scm_i_floor_divide
1320 scm_floor_divide(x
, y
, &q
, &r
);
1321 return scm_values (scm_list_2 (q
, r
));
1325 #define s_scm_floor_divide s_scm_i_floor_divide
1326 #define g_scm_floor_divide g_scm_i_floor_divide
1329 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1331 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1333 scm_t_inum xx
= SCM_I_INUM (x
);
1334 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1336 scm_t_inum yy
= SCM_I_INUM (y
);
1337 if (SCM_UNLIKELY (yy
== 0))
1338 scm_num_overflow (s_scm_floor_divide
);
1341 scm_t_inum qq
= xx
/ yy
;
1342 scm_t_inum rr
= xx
% yy
;
1343 int needs_adjustment
;
1345 if (SCM_LIKELY (yy
> 0))
1346 needs_adjustment
= (rr
< 0);
1348 needs_adjustment
= (rr
> 0);
1350 if (needs_adjustment
)
1356 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1357 *qp
= SCM_I_MAKINUM (qq
);
1359 *qp
= scm_i_inum2big (qq
);
1360 *rp
= SCM_I_MAKINUM (rr
);
1364 else if (SCM_BIGP (y
))
1366 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1367 scm_remember_upto_here_1 (y
);
1372 SCM r
= scm_i_mkbig ();
1373 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1374 scm_remember_upto_here_1 (y
);
1375 *qp
= SCM_I_MAKINUM (-1);
1376 *rp
= scm_i_normbig (r
);
1391 SCM r
= scm_i_mkbig ();
1392 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1393 scm_remember_upto_here_1 (y
);
1394 *qp
= SCM_I_MAKINUM (-1);
1395 *rp
= scm_i_normbig (r
);
1399 else if (SCM_REALP (y
))
1400 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1401 else if (SCM_FRACTIONP (y
))
1402 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1404 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1405 s_scm_floor_divide
, qp
, rp
);
1407 else if (SCM_BIGP (x
))
1409 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1411 scm_t_inum yy
= SCM_I_INUM (y
);
1412 if (SCM_UNLIKELY (yy
== 0))
1413 scm_num_overflow (s_scm_floor_divide
);
1416 SCM q
= scm_i_mkbig ();
1417 SCM r
= scm_i_mkbig ();
1419 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1420 SCM_I_BIG_MPZ (x
), yy
);
1423 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1424 SCM_I_BIG_MPZ (x
), -yy
);
1425 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1427 scm_remember_upto_here_1 (x
);
1428 *qp
= scm_i_normbig (q
);
1429 *rp
= scm_i_normbig (r
);
1433 else if (SCM_BIGP (y
))
1435 SCM q
= scm_i_mkbig ();
1436 SCM r
= scm_i_mkbig ();
1437 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1438 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1439 scm_remember_upto_here_2 (x
, y
);
1440 *qp
= scm_i_normbig (q
);
1441 *rp
= scm_i_normbig (r
);
1444 else if (SCM_REALP (y
))
1445 return scm_i_inexact_floor_divide
1446 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1447 else if (SCM_FRACTIONP (y
))
1448 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1450 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1451 s_scm_floor_divide
, qp
, rp
);
1453 else if (SCM_REALP (x
))
1455 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1456 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1457 return scm_i_inexact_floor_divide
1458 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1460 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1461 s_scm_floor_divide
, qp
, rp
);
1463 else if (SCM_FRACTIONP (x
))
1466 return scm_i_inexact_floor_divide
1467 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1468 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1469 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1471 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1472 s_scm_floor_divide
, qp
, rp
);
1475 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1476 s_scm_floor_divide
, qp
, rp
);
1480 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1482 if (SCM_UNLIKELY (y
== 0))
1483 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1486 double q
= floor (x
/ y
);
1487 double r
= x
- q
* y
;
1488 *qp
= scm_from_double (q
);
1489 *rp
= scm_from_double (r
);
1494 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1497 SCM xd
= scm_denominator (x
);
1498 SCM yd
= scm_denominator (y
);
1500 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1501 scm_product (scm_numerator (y
), xd
),
1503 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1506 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1507 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1509 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1511 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1513 "(ceiling-quotient 123 10) @result{} 13\n"
1514 "(ceiling-quotient 123 -10) @result{} -12\n"
1515 "(ceiling-quotient -123 10) @result{} -12\n"
1516 "(ceiling-quotient -123 -10) @result{} 13\n"
1517 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1518 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1520 #define FUNC_NAME s_scm_ceiling_quotient
1522 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1524 scm_t_inum xx
= SCM_I_INUM (x
);
1525 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1527 scm_t_inum yy
= SCM_I_INUM (y
);
1528 if (SCM_UNLIKELY (yy
== 0))
1529 scm_num_overflow (s_scm_ceiling_quotient
);
1532 scm_t_inum xx1
= xx
;
1534 if (SCM_LIKELY (yy
> 0))
1536 if (SCM_LIKELY (xx
>= 0))
1542 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1543 return SCM_I_MAKINUM (qq
);
1545 return scm_i_inum2big (qq
);
1548 else if (SCM_BIGP (y
))
1550 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1551 scm_remember_upto_here_1 (y
);
1552 if (SCM_LIKELY (sign
> 0))
1554 if (SCM_LIKELY (xx
> 0))
1556 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1557 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1558 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1560 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1561 scm_remember_upto_here_1 (y
);
1562 return SCM_I_MAKINUM (-1);
1572 else if (SCM_REALP (y
))
1573 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1574 else if (SCM_FRACTIONP (y
))
1575 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1577 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1578 s_scm_ceiling_quotient
);
1580 else if (SCM_BIGP (x
))
1582 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1584 scm_t_inum yy
= SCM_I_INUM (y
);
1585 if (SCM_UNLIKELY (yy
== 0))
1586 scm_num_overflow (s_scm_ceiling_quotient
);
1587 else if (SCM_UNLIKELY (yy
== 1))
1591 SCM q
= scm_i_mkbig ();
1593 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1596 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1597 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1599 scm_remember_upto_here_1 (x
);
1600 return scm_i_normbig (q
);
1603 else if (SCM_BIGP (y
))
1605 SCM q
= scm_i_mkbig ();
1606 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1609 scm_remember_upto_here_2 (x
, y
);
1610 return scm_i_normbig (q
);
1612 else if (SCM_REALP (y
))
1613 return scm_i_inexact_ceiling_quotient
1614 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1615 else if (SCM_FRACTIONP (y
))
1616 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1618 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1619 s_scm_ceiling_quotient
);
1621 else if (SCM_REALP (x
))
1623 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1624 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1625 return scm_i_inexact_ceiling_quotient
1626 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1628 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1629 s_scm_ceiling_quotient
);
1631 else if (SCM_FRACTIONP (x
))
1634 return scm_i_inexact_ceiling_quotient
1635 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1636 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1637 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1639 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1640 s_scm_ceiling_quotient
);
1643 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1644 s_scm_ceiling_quotient
);
1649 scm_i_inexact_ceiling_quotient (double x
, double y
)
1651 if (SCM_UNLIKELY (y
== 0))
1652 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1654 return scm_from_double (ceil (x
/ y
));
1658 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1660 return scm_ceiling_quotient
1661 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1662 scm_product (scm_numerator (y
), scm_denominator (x
)));
1665 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1666 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1668 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1670 "Return the real number @var{r} such that\n"
1671 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1672 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1674 "(ceiling-remainder 123 10) @result{} -7\n"
1675 "(ceiling-remainder 123 -10) @result{} 3\n"
1676 "(ceiling-remainder -123 10) @result{} -3\n"
1677 "(ceiling-remainder -123 -10) @result{} 7\n"
1678 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1679 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1681 #define FUNC_NAME s_scm_ceiling_remainder
1683 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1685 scm_t_inum xx
= SCM_I_INUM (x
);
1686 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1688 scm_t_inum yy
= SCM_I_INUM (y
);
1689 if (SCM_UNLIKELY (yy
== 0))
1690 scm_num_overflow (s_scm_ceiling_remainder
);
1693 scm_t_inum rr
= xx
% yy
;
1694 int needs_adjustment
;
1696 if (SCM_LIKELY (yy
> 0))
1697 needs_adjustment
= (rr
> 0);
1699 needs_adjustment
= (rr
< 0);
1701 if (needs_adjustment
)
1703 return SCM_I_MAKINUM (rr
);
1706 else if (SCM_BIGP (y
))
1708 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1709 scm_remember_upto_here_1 (y
);
1710 if (SCM_LIKELY (sign
> 0))
1712 if (SCM_LIKELY (xx
> 0))
1714 SCM r
= scm_i_mkbig ();
1715 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1716 scm_remember_upto_here_1 (y
);
1717 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1718 return scm_i_normbig (r
);
1720 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1721 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1722 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1724 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1725 scm_remember_upto_here_1 (y
);
1735 SCM r
= scm_i_mkbig ();
1736 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1737 scm_remember_upto_here_1 (y
);
1738 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1739 return scm_i_normbig (r
);
1742 else if (SCM_REALP (y
))
1743 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1744 else if (SCM_FRACTIONP (y
))
1745 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1747 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1748 s_scm_ceiling_remainder
);
1750 else if (SCM_BIGP (x
))
1752 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1754 scm_t_inum yy
= SCM_I_INUM (y
);
1755 if (SCM_UNLIKELY (yy
== 0))
1756 scm_num_overflow (s_scm_ceiling_remainder
);
1761 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1763 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1764 scm_remember_upto_here_1 (x
);
1765 return SCM_I_MAKINUM (rr
);
1768 else if (SCM_BIGP (y
))
1770 SCM r
= scm_i_mkbig ();
1771 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1774 scm_remember_upto_here_2 (x
, y
);
1775 return scm_i_normbig (r
);
1777 else if (SCM_REALP (y
))
1778 return scm_i_inexact_ceiling_remainder
1779 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1780 else if (SCM_FRACTIONP (y
))
1781 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1783 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1784 s_scm_ceiling_remainder
);
1786 else if (SCM_REALP (x
))
1788 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1789 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1790 return scm_i_inexact_ceiling_remainder
1791 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1793 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1794 s_scm_ceiling_remainder
);
1796 else if (SCM_FRACTIONP (x
))
1799 return scm_i_inexact_ceiling_remainder
1800 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1801 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1802 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1804 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1805 s_scm_ceiling_remainder
);
1808 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1809 s_scm_ceiling_remainder
);
1814 scm_i_inexact_ceiling_remainder (double x
, double y
)
1816 /* Although it would be more efficient to use fmod here, we can't
1817 because it would in some cases produce results inconsistent with
1818 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1819 close). In particular, when x is very close to a multiple of y,
1820 then r might be either 0.0 or -y, but those two cases must
1821 correspond to different choices of q. If r = 0.0 then q must be
1822 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1823 and remainder chooses the other, it would be bad. */
1824 if (SCM_UNLIKELY (y
== 0))
1825 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1827 return scm_from_double (x
- y
* ceil (x
/ y
));
1831 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1833 SCM xd
= scm_denominator (x
);
1834 SCM yd
= scm_denominator (y
);
1835 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1836 scm_product (scm_numerator (y
), xd
));
1837 return scm_divide (r1
, scm_product (xd
, yd
));
1840 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1842 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1845 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1847 "Return the integer @var{q} and the real number @var{r}\n"
1848 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1849 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1851 "(ceiling/ 123 10) @result{} 13 and -7\n"
1852 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1853 "(ceiling/ -123 10) @result{} -12 and -3\n"
1854 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1855 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1856 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1858 #define FUNC_NAME s_scm_i_ceiling_divide
1862 scm_ceiling_divide(x
, y
, &q
, &r
);
1863 return scm_values (scm_list_2 (q
, r
));
1867 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1868 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1871 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1873 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1875 scm_t_inum xx
= SCM_I_INUM (x
);
1876 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1878 scm_t_inum yy
= SCM_I_INUM (y
);
1879 if (SCM_UNLIKELY (yy
== 0))
1880 scm_num_overflow (s_scm_ceiling_divide
);
1883 scm_t_inum qq
= xx
/ yy
;
1884 scm_t_inum rr
= xx
% yy
;
1885 int needs_adjustment
;
1887 if (SCM_LIKELY (yy
> 0))
1888 needs_adjustment
= (rr
> 0);
1890 needs_adjustment
= (rr
< 0);
1892 if (needs_adjustment
)
1897 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1898 *qp
= SCM_I_MAKINUM (qq
);
1900 *qp
= scm_i_inum2big (qq
);
1901 *rp
= SCM_I_MAKINUM (rr
);
1905 else if (SCM_BIGP (y
))
1907 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1908 scm_remember_upto_here_1 (y
);
1909 if (SCM_LIKELY (sign
> 0))
1911 if (SCM_LIKELY (xx
> 0))
1913 SCM r
= scm_i_mkbig ();
1914 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1915 scm_remember_upto_here_1 (y
);
1916 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1918 *rp
= scm_i_normbig (r
);
1920 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1921 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1922 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1924 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1925 scm_remember_upto_here_1 (y
);
1926 *qp
= SCM_I_MAKINUM (-1);
1942 SCM r
= scm_i_mkbig ();
1943 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1944 scm_remember_upto_here_1 (y
);
1945 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1947 *rp
= scm_i_normbig (r
);
1951 else if (SCM_REALP (y
))
1952 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1953 else if (SCM_FRACTIONP (y
))
1954 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1956 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1957 s_scm_ceiling_divide
, qp
, rp
);
1959 else if (SCM_BIGP (x
))
1961 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1963 scm_t_inum yy
= SCM_I_INUM (y
);
1964 if (SCM_UNLIKELY (yy
== 0))
1965 scm_num_overflow (s_scm_ceiling_divide
);
1968 SCM q
= scm_i_mkbig ();
1969 SCM r
= scm_i_mkbig ();
1971 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1972 SCM_I_BIG_MPZ (x
), yy
);
1975 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1976 SCM_I_BIG_MPZ (x
), -yy
);
1977 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1979 scm_remember_upto_here_1 (x
);
1980 *qp
= scm_i_normbig (q
);
1981 *rp
= scm_i_normbig (r
);
1985 else if (SCM_BIGP (y
))
1987 SCM q
= scm_i_mkbig ();
1988 SCM r
= scm_i_mkbig ();
1989 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1990 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1991 scm_remember_upto_here_2 (x
, y
);
1992 *qp
= scm_i_normbig (q
);
1993 *rp
= scm_i_normbig (r
);
1996 else if (SCM_REALP (y
))
1997 return scm_i_inexact_ceiling_divide
1998 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1999 else if (SCM_FRACTIONP (y
))
2000 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2002 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2003 s_scm_ceiling_divide
, qp
, rp
);
2005 else if (SCM_REALP (x
))
2007 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2008 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2009 return scm_i_inexact_ceiling_divide
2010 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2012 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2013 s_scm_ceiling_divide
, qp
, rp
);
2015 else if (SCM_FRACTIONP (x
))
2018 return scm_i_inexact_ceiling_divide
2019 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2020 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2021 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2023 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2024 s_scm_ceiling_divide
, qp
, rp
);
2027 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2028 s_scm_ceiling_divide
, qp
, rp
);
2032 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2034 if (SCM_UNLIKELY (y
== 0))
2035 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2038 double q
= ceil (x
/ y
);
2039 double r
= x
- q
* y
;
2040 *qp
= scm_from_double (q
);
2041 *rp
= scm_from_double (r
);
2046 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2049 SCM xd
= scm_denominator (x
);
2050 SCM yd
= scm_denominator (y
);
2052 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2053 scm_product (scm_numerator (y
), xd
),
2055 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2058 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2059 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2061 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2063 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2065 "(truncate-quotient 123 10) @result{} 12\n"
2066 "(truncate-quotient 123 -10) @result{} -12\n"
2067 "(truncate-quotient -123 10) @result{} -12\n"
2068 "(truncate-quotient -123 -10) @result{} 12\n"
2069 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2070 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2072 #define FUNC_NAME s_scm_truncate_quotient
2074 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2076 scm_t_inum xx
= SCM_I_INUM (x
);
2077 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2079 scm_t_inum yy
= SCM_I_INUM (y
);
2080 if (SCM_UNLIKELY (yy
== 0))
2081 scm_num_overflow (s_scm_truncate_quotient
);
2084 scm_t_inum qq
= xx
/ yy
;
2085 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2086 return SCM_I_MAKINUM (qq
);
2088 return scm_i_inum2big (qq
);
2091 else if (SCM_BIGP (y
))
2093 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2094 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2095 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2097 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2098 scm_remember_upto_here_1 (y
);
2099 return SCM_I_MAKINUM (-1);
2104 else if (SCM_REALP (y
))
2105 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2106 else if (SCM_FRACTIONP (y
))
2107 return scm_i_exact_rational_truncate_quotient (x
, y
);
2109 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2110 s_scm_truncate_quotient
);
2112 else if (SCM_BIGP (x
))
2114 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2116 scm_t_inum yy
= SCM_I_INUM (y
);
2117 if (SCM_UNLIKELY (yy
== 0))
2118 scm_num_overflow (s_scm_truncate_quotient
);
2119 else if (SCM_UNLIKELY (yy
== 1))
2123 SCM q
= scm_i_mkbig ();
2125 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2128 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2129 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2131 scm_remember_upto_here_1 (x
);
2132 return scm_i_normbig (q
);
2135 else if (SCM_BIGP (y
))
2137 SCM q
= scm_i_mkbig ();
2138 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2141 scm_remember_upto_here_2 (x
, y
);
2142 return scm_i_normbig (q
);
2144 else if (SCM_REALP (y
))
2145 return scm_i_inexact_truncate_quotient
2146 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2147 else if (SCM_FRACTIONP (y
))
2148 return scm_i_exact_rational_truncate_quotient (x
, y
);
2150 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2151 s_scm_truncate_quotient
);
2153 else if (SCM_REALP (x
))
2155 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2156 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2157 return scm_i_inexact_truncate_quotient
2158 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2160 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2161 s_scm_truncate_quotient
);
2163 else if (SCM_FRACTIONP (x
))
2166 return scm_i_inexact_truncate_quotient
2167 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2168 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2169 return scm_i_exact_rational_truncate_quotient (x
, y
);
2171 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2172 s_scm_truncate_quotient
);
2175 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2176 s_scm_truncate_quotient
);
2181 scm_i_inexact_truncate_quotient (double x
, double y
)
2183 if (SCM_UNLIKELY (y
== 0))
2184 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2186 return scm_from_double (trunc (x
/ y
));
2190 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2192 return scm_truncate_quotient
2193 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2194 scm_product (scm_numerator (y
), scm_denominator (x
)));
2197 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2198 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2200 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2202 "Return the real number @var{r} such that\n"
2203 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2204 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2206 "(truncate-remainder 123 10) @result{} 3\n"
2207 "(truncate-remainder 123 -10) @result{} 3\n"
2208 "(truncate-remainder -123 10) @result{} -3\n"
2209 "(truncate-remainder -123 -10) @result{} -3\n"
2210 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2211 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2213 #define FUNC_NAME s_scm_truncate_remainder
2215 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2217 scm_t_inum xx
= SCM_I_INUM (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
);
2224 return SCM_I_MAKINUM (xx
% yy
);
2226 else if (SCM_BIGP (y
))
2228 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2229 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2230 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2232 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2233 scm_remember_upto_here_1 (y
);
2239 else if (SCM_REALP (y
))
2240 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2241 else if (SCM_FRACTIONP (y
))
2242 return scm_i_exact_rational_truncate_remainder (x
, y
);
2244 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2245 s_scm_truncate_remainder
);
2247 else if (SCM_BIGP (x
))
2249 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2251 scm_t_inum yy
= SCM_I_INUM (y
);
2252 if (SCM_UNLIKELY (yy
== 0))
2253 scm_num_overflow (s_scm_truncate_remainder
);
2256 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2257 (yy
> 0) ? yy
: -yy
)
2258 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2259 scm_remember_upto_here_1 (x
);
2260 return SCM_I_MAKINUM (rr
);
2263 else if (SCM_BIGP (y
))
2265 SCM r
= scm_i_mkbig ();
2266 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2269 scm_remember_upto_here_2 (x
, y
);
2270 return scm_i_normbig (r
);
2272 else if (SCM_REALP (y
))
2273 return scm_i_inexact_truncate_remainder
2274 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2275 else if (SCM_FRACTIONP (y
))
2276 return scm_i_exact_rational_truncate_remainder (x
, y
);
2278 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2279 s_scm_truncate_remainder
);
2281 else if (SCM_REALP (x
))
2283 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2284 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2285 return scm_i_inexact_truncate_remainder
2286 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2288 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2289 s_scm_truncate_remainder
);
2291 else if (SCM_FRACTIONP (x
))
2294 return scm_i_inexact_truncate_remainder
2295 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2296 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2297 return scm_i_exact_rational_truncate_remainder (x
, y
);
2299 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2300 s_scm_truncate_remainder
);
2303 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2304 s_scm_truncate_remainder
);
2309 scm_i_inexact_truncate_remainder (double x
, double y
)
2311 /* Although it would be more efficient to use fmod here, we can't
2312 because it would in some cases produce results inconsistent with
2313 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2314 close). In particular, when x is very close to a multiple of y,
2315 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2316 correspond to different choices of q. If quotient chooses one and
2317 remainder chooses the other, it would be bad. */
2318 if (SCM_UNLIKELY (y
== 0))
2319 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2321 return scm_from_double (x
- y
* trunc (x
/ y
));
2325 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2327 SCM xd
= scm_denominator (x
);
2328 SCM yd
= scm_denominator (y
);
2329 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2330 scm_product (scm_numerator (y
), xd
));
2331 return scm_divide (r1
, scm_product (xd
, yd
));
2335 static void scm_i_inexact_truncate_divide (double x
, double y
,
2337 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2340 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2342 "Return the integer @var{q} and the real number @var{r}\n"
2343 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2344 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2346 "(truncate/ 123 10) @result{} 12 and 3\n"
2347 "(truncate/ 123 -10) @result{} -12 and 3\n"
2348 "(truncate/ -123 10) @result{} -12 and -3\n"
2349 "(truncate/ -123 -10) @result{} 12 and -3\n"
2350 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2351 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2353 #define FUNC_NAME s_scm_i_truncate_divide
2357 scm_truncate_divide(x
, y
, &q
, &r
);
2358 return scm_values (scm_list_2 (q
, r
));
2362 #define s_scm_truncate_divide s_scm_i_truncate_divide
2363 #define g_scm_truncate_divide g_scm_i_truncate_divide
2366 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2368 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2370 scm_t_inum xx
= SCM_I_INUM (x
);
2371 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2373 scm_t_inum yy
= SCM_I_INUM (y
);
2374 if (SCM_UNLIKELY (yy
== 0))
2375 scm_num_overflow (s_scm_truncate_divide
);
2378 scm_t_inum qq
= xx
/ yy
;
2379 scm_t_inum rr
= xx
% yy
;
2380 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2381 *qp
= SCM_I_MAKINUM (qq
);
2383 *qp
= scm_i_inum2big (qq
);
2384 *rp
= SCM_I_MAKINUM (rr
);
2388 else if (SCM_BIGP (y
))
2390 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2391 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2392 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2394 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2395 scm_remember_upto_here_1 (y
);
2396 *qp
= SCM_I_MAKINUM (-1);
2406 else if (SCM_REALP (y
))
2407 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2408 else if (SCM_FRACTIONP (y
))
2409 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2411 return two_valued_wta_dispatch_2
2412 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2413 s_scm_truncate_divide
, qp
, rp
);
2415 else if (SCM_BIGP (x
))
2417 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2419 scm_t_inum yy
= SCM_I_INUM (y
);
2420 if (SCM_UNLIKELY (yy
== 0))
2421 scm_num_overflow (s_scm_truncate_divide
);
2424 SCM q
= scm_i_mkbig ();
2427 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2428 SCM_I_BIG_MPZ (x
), yy
);
2431 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2432 SCM_I_BIG_MPZ (x
), -yy
);
2433 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2435 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2436 scm_remember_upto_here_1 (x
);
2437 *qp
= scm_i_normbig (q
);
2438 *rp
= SCM_I_MAKINUM (rr
);
2442 else if (SCM_BIGP (y
))
2444 SCM q
= scm_i_mkbig ();
2445 SCM r
= scm_i_mkbig ();
2446 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2447 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2448 scm_remember_upto_here_2 (x
, y
);
2449 *qp
= scm_i_normbig (q
);
2450 *rp
= scm_i_normbig (r
);
2452 else if (SCM_REALP (y
))
2453 return scm_i_inexact_truncate_divide
2454 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2455 else if (SCM_FRACTIONP (y
))
2456 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2458 return two_valued_wta_dispatch_2
2459 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2460 s_scm_truncate_divide
, qp
, rp
);
2462 else if (SCM_REALP (x
))
2464 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2465 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2466 return scm_i_inexact_truncate_divide
2467 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2469 return two_valued_wta_dispatch_2
2470 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2471 s_scm_truncate_divide
, qp
, rp
);
2473 else if (SCM_FRACTIONP (x
))
2476 return scm_i_inexact_truncate_divide
2477 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2478 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2479 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2481 return two_valued_wta_dispatch_2
2482 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2483 s_scm_truncate_divide
, qp
, rp
);
2486 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2487 s_scm_truncate_divide
, qp
, rp
);
2491 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2493 if (SCM_UNLIKELY (y
== 0))
2494 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2497 double q
= trunc (x
/ y
);
2498 double r
= x
- q
* y
;
2499 *qp
= scm_from_double (q
);
2500 *rp
= scm_from_double (r
);
2505 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2508 SCM xd
= scm_denominator (x
);
2509 SCM yd
= scm_denominator (y
);
2511 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2512 scm_product (scm_numerator (y
), xd
),
2514 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2517 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2518 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2519 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2521 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2523 "Return the integer @var{q} such that\n"
2524 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2525 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2527 "(centered-quotient 123 10) @result{} 12\n"
2528 "(centered-quotient 123 -10) @result{} -12\n"
2529 "(centered-quotient -123 10) @result{} -12\n"
2530 "(centered-quotient -123 -10) @result{} 12\n"
2531 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2532 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2534 #define FUNC_NAME s_scm_centered_quotient
2536 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2538 scm_t_inum xx
= SCM_I_INUM (x
);
2539 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2541 scm_t_inum yy
= SCM_I_INUM (y
);
2542 if (SCM_UNLIKELY (yy
== 0))
2543 scm_num_overflow (s_scm_centered_quotient
);
2546 scm_t_inum qq
= xx
/ yy
;
2547 scm_t_inum rr
= xx
% yy
;
2548 if (SCM_LIKELY (xx
> 0))
2550 if (SCM_LIKELY (yy
> 0))
2552 if (rr
>= (yy
+ 1) / 2)
2557 if (rr
>= (1 - yy
) / 2)
2563 if (SCM_LIKELY (yy
> 0))
2574 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2575 return SCM_I_MAKINUM (qq
);
2577 return scm_i_inum2big (qq
);
2580 else if (SCM_BIGP (y
))
2582 /* Pass a denormalized bignum version of x (even though it
2583 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2584 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2586 else if (SCM_REALP (y
))
2587 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2588 else if (SCM_FRACTIONP (y
))
2589 return scm_i_exact_rational_centered_quotient (x
, y
);
2591 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2592 s_scm_centered_quotient
);
2594 else if (SCM_BIGP (x
))
2596 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2598 scm_t_inum yy
= SCM_I_INUM (y
);
2599 if (SCM_UNLIKELY (yy
== 0))
2600 scm_num_overflow (s_scm_centered_quotient
);
2601 else if (SCM_UNLIKELY (yy
== 1))
2605 SCM q
= scm_i_mkbig ();
2607 /* Arrange for rr to initially be non-positive,
2608 because that simplifies the test to see
2609 if it is within the needed bounds. */
2612 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2613 SCM_I_BIG_MPZ (x
), yy
);
2614 scm_remember_upto_here_1 (x
);
2616 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2617 SCM_I_BIG_MPZ (q
), 1);
2621 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2622 SCM_I_BIG_MPZ (x
), -yy
);
2623 scm_remember_upto_here_1 (x
);
2624 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2626 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2627 SCM_I_BIG_MPZ (q
), 1);
2629 return scm_i_normbig (q
);
2632 else if (SCM_BIGP (y
))
2633 return scm_i_bigint_centered_quotient (x
, y
);
2634 else if (SCM_REALP (y
))
2635 return scm_i_inexact_centered_quotient
2636 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2637 else if (SCM_FRACTIONP (y
))
2638 return scm_i_exact_rational_centered_quotient (x
, y
);
2640 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2641 s_scm_centered_quotient
);
2643 else if (SCM_REALP (x
))
2645 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2646 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2647 return scm_i_inexact_centered_quotient
2648 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2650 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2651 s_scm_centered_quotient
);
2653 else if (SCM_FRACTIONP (x
))
2656 return scm_i_inexact_centered_quotient
2657 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2658 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2659 return scm_i_exact_rational_centered_quotient (x
, y
);
2661 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2662 s_scm_centered_quotient
);
2665 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2666 s_scm_centered_quotient
);
2671 scm_i_inexact_centered_quotient (double x
, double y
)
2673 if (SCM_LIKELY (y
> 0))
2674 return scm_from_double (floor (x
/y
+ 0.5));
2675 else if (SCM_LIKELY (y
< 0))
2676 return scm_from_double (ceil (x
/y
- 0.5));
2678 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2683 /* Assumes that both x and y are bigints, though
2684 x might be able to fit into a fixnum. */
2686 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2690 /* Note that x might be small enough to fit into a
2691 fixnum, so we must not let it escape into the wild */
2695 /* min_r will eventually become -abs(y)/2 */
2696 min_r
= scm_i_mkbig ();
2697 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2698 SCM_I_BIG_MPZ (y
), 1);
2700 /* Arrange for rr to initially be non-positive,
2701 because that simplifies the test to see
2702 if it is within the needed bounds. */
2703 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2705 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2706 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2707 scm_remember_upto_here_2 (x
, y
);
2708 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2709 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2710 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2711 SCM_I_BIG_MPZ (q
), 1);
2715 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2716 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2717 scm_remember_upto_here_2 (x
, y
);
2718 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2719 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2720 SCM_I_BIG_MPZ (q
), 1);
2722 scm_remember_upto_here_2 (r
, min_r
);
2723 return scm_i_normbig (q
);
2727 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2729 return scm_centered_quotient
2730 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2731 scm_product (scm_numerator (y
), scm_denominator (x
)));
2734 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2735 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2736 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2738 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2740 "Return the real number @var{r} such that\n"
2741 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2742 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2743 "for some integer @var{q}.\n"
2745 "(centered-remainder 123 10) @result{} 3\n"
2746 "(centered-remainder 123 -10) @result{} 3\n"
2747 "(centered-remainder -123 10) @result{} -3\n"
2748 "(centered-remainder -123 -10) @result{} -3\n"
2749 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2750 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2752 #define FUNC_NAME s_scm_centered_remainder
2754 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2756 scm_t_inum xx
= SCM_I_INUM (x
);
2757 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2759 scm_t_inum yy
= SCM_I_INUM (y
);
2760 if (SCM_UNLIKELY (yy
== 0))
2761 scm_num_overflow (s_scm_centered_remainder
);
2764 scm_t_inum rr
= xx
% yy
;
2765 if (SCM_LIKELY (xx
> 0))
2767 if (SCM_LIKELY (yy
> 0))
2769 if (rr
>= (yy
+ 1) / 2)
2774 if (rr
>= (1 - yy
) / 2)
2780 if (SCM_LIKELY (yy
> 0))
2791 return SCM_I_MAKINUM (rr
);
2794 else if (SCM_BIGP (y
))
2796 /* Pass a denormalized bignum version of x (even though it
2797 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2798 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2800 else if (SCM_REALP (y
))
2801 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2802 else if (SCM_FRACTIONP (y
))
2803 return scm_i_exact_rational_centered_remainder (x
, y
);
2805 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2806 s_scm_centered_remainder
);
2808 else if (SCM_BIGP (x
))
2810 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2812 scm_t_inum yy
= SCM_I_INUM (y
);
2813 if (SCM_UNLIKELY (yy
== 0))
2814 scm_num_overflow (s_scm_centered_remainder
);
2818 /* Arrange for rr to initially be non-positive,
2819 because that simplifies the test to see
2820 if it is within the needed bounds. */
2823 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2824 scm_remember_upto_here_1 (x
);
2830 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2831 scm_remember_upto_here_1 (x
);
2835 return SCM_I_MAKINUM (rr
);
2838 else if (SCM_BIGP (y
))
2839 return scm_i_bigint_centered_remainder (x
, y
);
2840 else if (SCM_REALP (y
))
2841 return scm_i_inexact_centered_remainder
2842 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2843 else if (SCM_FRACTIONP (y
))
2844 return scm_i_exact_rational_centered_remainder (x
, y
);
2846 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2847 s_scm_centered_remainder
);
2849 else if (SCM_REALP (x
))
2851 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2852 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2853 return scm_i_inexact_centered_remainder
2854 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2856 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2857 s_scm_centered_remainder
);
2859 else if (SCM_FRACTIONP (x
))
2862 return scm_i_inexact_centered_remainder
2863 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2864 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2865 return scm_i_exact_rational_centered_remainder (x
, y
);
2867 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2868 s_scm_centered_remainder
);
2871 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2872 s_scm_centered_remainder
);
2877 scm_i_inexact_centered_remainder (double x
, double y
)
2881 /* Although it would be more efficient to use fmod here, we can't
2882 because it would in some cases produce results inconsistent with
2883 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2884 close). In particular, when x-y/2 is very close to a multiple of
2885 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2886 two cases must correspond to different choices of q. If quotient
2887 chooses one and remainder chooses the other, it would be bad. */
2888 if (SCM_LIKELY (y
> 0))
2889 q
= floor (x
/y
+ 0.5);
2890 else if (SCM_LIKELY (y
< 0))
2891 q
= ceil (x
/y
- 0.5);
2893 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2896 return scm_from_double (x
- q
* y
);
2899 /* Assumes that both x and y are bigints, though
2900 x might be able to fit into a fixnum. */
2902 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2906 /* Note that x might be small enough to fit into a
2907 fixnum, so we must not let it escape into the wild */
2910 /* min_r will eventually become -abs(y)/2 */
2911 min_r
= scm_i_mkbig ();
2912 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2913 SCM_I_BIG_MPZ (y
), 1);
2915 /* Arrange for rr to initially be non-positive,
2916 because that simplifies the test to see
2917 if it is within the needed bounds. */
2918 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2920 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2921 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2922 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2923 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2924 mpz_add (SCM_I_BIG_MPZ (r
),
2930 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2931 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2932 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2933 mpz_sub (SCM_I_BIG_MPZ (r
),
2937 scm_remember_upto_here_2 (x
, y
);
2938 return scm_i_normbig (r
);
2942 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2944 SCM xd
= scm_denominator (x
);
2945 SCM yd
= scm_denominator (y
);
2946 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2947 scm_product (scm_numerator (y
), xd
));
2948 return scm_divide (r1
, scm_product (xd
, yd
));
2952 static void scm_i_inexact_centered_divide (double x
, double y
,
2954 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2955 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2958 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2960 "Return the integer @var{q} and the real number @var{r}\n"
2961 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2962 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2964 "(centered/ 123 10) @result{} 12 and 3\n"
2965 "(centered/ 123 -10) @result{} -12 and 3\n"
2966 "(centered/ -123 10) @result{} -12 and -3\n"
2967 "(centered/ -123 -10) @result{} 12 and -3\n"
2968 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2969 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2971 #define FUNC_NAME s_scm_i_centered_divide
2975 scm_centered_divide(x
, y
, &q
, &r
);
2976 return scm_values (scm_list_2 (q
, r
));
2980 #define s_scm_centered_divide s_scm_i_centered_divide
2981 #define g_scm_centered_divide g_scm_i_centered_divide
2984 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2986 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2988 scm_t_inum xx
= SCM_I_INUM (x
);
2989 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2991 scm_t_inum yy
= SCM_I_INUM (y
);
2992 if (SCM_UNLIKELY (yy
== 0))
2993 scm_num_overflow (s_scm_centered_divide
);
2996 scm_t_inum qq
= xx
/ yy
;
2997 scm_t_inum rr
= xx
% yy
;
2998 if (SCM_LIKELY (xx
> 0))
3000 if (SCM_LIKELY (yy
> 0))
3002 if (rr
>= (yy
+ 1) / 2)
3007 if (rr
>= (1 - yy
) / 2)
3013 if (SCM_LIKELY (yy
> 0))
3024 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3025 *qp
= SCM_I_MAKINUM (qq
);
3027 *qp
= scm_i_inum2big (qq
);
3028 *rp
= SCM_I_MAKINUM (rr
);
3032 else if (SCM_BIGP (y
))
3034 /* Pass a denormalized bignum version of x (even though it
3035 can fit in a fixnum) to scm_i_bigint_centered_divide */
3036 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3038 else if (SCM_REALP (y
))
3039 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3040 else if (SCM_FRACTIONP (y
))
3041 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3043 return two_valued_wta_dispatch_2
3044 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3045 s_scm_centered_divide
, qp
, rp
);
3047 else if (SCM_BIGP (x
))
3049 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3051 scm_t_inum yy
= SCM_I_INUM (y
);
3052 if (SCM_UNLIKELY (yy
== 0))
3053 scm_num_overflow (s_scm_centered_divide
);
3056 SCM q
= scm_i_mkbig ();
3058 /* Arrange for rr to initially be non-positive,
3059 because that simplifies the test to see
3060 if it is within the needed bounds. */
3063 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3064 SCM_I_BIG_MPZ (x
), yy
);
3065 scm_remember_upto_here_1 (x
);
3068 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3069 SCM_I_BIG_MPZ (q
), 1);
3075 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3076 SCM_I_BIG_MPZ (x
), -yy
);
3077 scm_remember_upto_here_1 (x
);
3078 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3081 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3082 SCM_I_BIG_MPZ (q
), 1);
3086 *qp
= scm_i_normbig (q
);
3087 *rp
= SCM_I_MAKINUM (rr
);
3091 else if (SCM_BIGP (y
))
3092 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3093 else if (SCM_REALP (y
))
3094 return scm_i_inexact_centered_divide
3095 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3096 else if (SCM_FRACTIONP (y
))
3097 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3099 return two_valued_wta_dispatch_2
3100 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3101 s_scm_centered_divide
, qp
, rp
);
3103 else if (SCM_REALP (x
))
3105 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3106 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3107 return scm_i_inexact_centered_divide
3108 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3110 return two_valued_wta_dispatch_2
3111 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3112 s_scm_centered_divide
, qp
, rp
);
3114 else if (SCM_FRACTIONP (x
))
3117 return scm_i_inexact_centered_divide
3118 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3119 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3120 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3122 return two_valued_wta_dispatch_2
3123 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3124 s_scm_centered_divide
, qp
, rp
);
3127 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3128 s_scm_centered_divide
, qp
, rp
);
3132 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3136 if (SCM_LIKELY (y
> 0))
3137 q
= floor (x
/y
+ 0.5);
3138 else if (SCM_LIKELY (y
< 0))
3139 q
= ceil (x
/y
- 0.5);
3141 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3145 *qp
= scm_from_double (q
);
3146 *rp
= scm_from_double (r
);
3149 /* Assumes that both x and y are bigints, though
3150 x might be able to fit into a fixnum. */
3152 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3156 /* Note that x might be small enough to fit into a
3157 fixnum, so we must not let it escape into the wild */
3161 /* min_r will eventually become -abs(y/2) */
3162 min_r
= scm_i_mkbig ();
3163 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3164 SCM_I_BIG_MPZ (y
), 1);
3166 /* Arrange for rr to initially be non-positive,
3167 because that simplifies the test to see
3168 if it is within the needed bounds. */
3169 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3171 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3172 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3173 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3174 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3176 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3177 SCM_I_BIG_MPZ (q
), 1);
3178 mpz_add (SCM_I_BIG_MPZ (r
),
3185 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3186 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3187 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3189 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3190 SCM_I_BIG_MPZ (q
), 1);
3191 mpz_sub (SCM_I_BIG_MPZ (r
),
3196 scm_remember_upto_here_2 (x
, y
);
3197 *qp
= scm_i_normbig (q
);
3198 *rp
= scm_i_normbig (r
);
3202 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3205 SCM xd
= scm_denominator (x
);
3206 SCM yd
= scm_denominator (y
);
3208 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3209 scm_product (scm_numerator (y
), xd
),
3211 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3214 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3215 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3216 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3218 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3220 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3221 "with ties going to the nearest even integer.\n"
3223 "(round-quotient 123 10) @result{} 12\n"
3224 "(round-quotient 123 -10) @result{} -12\n"
3225 "(round-quotient -123 10) @result{} -12\n"
3226 "(round-quotient -123 -10) @result{} 12\n"
3227 "(round-quotient 125 10) @result{} 12\n"
3228 "(round-quotient 127 10) @result{} 13\n"
3229 "(round-quotient 135 10) @result{} 14\n"
3230 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3231 "(round-quotient 16/3 -10/7) @result{} -4\n"
3233 #define FUNC_NAME s_scm_round_quotient
3235 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3237 scm_t_inum xx
= SCM_I_INUM (x
);
3238 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3240 scm_t_inum yy
= SCM_I_INUM (y
);
3241 if (SCM_UNLIKELY (yy
== 0))
3242 scm_num_overflow (s_scm_round_quotient
);
3245 scm_t_inum qq
= xx
/ yy
;
3246 scm_t_inum rr
= xx
% yy
;
3248 scm_t_inum r2
= 2 * rr
;
3250 if (SCM_LIKELY (yy
< 0))
3270 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3271 return SCM_I_MAKINUM (qq
);
3273 return scm_i_inum2big (qq
);
3276 else if (SCM_BIGP (y
))
3278 /* Pass a denormalized bignum version of x (even though it
3279 can fit in a fixnum) to scm_i_bigint_round_quotient */
3280 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3282 else if (SCM_REALP (y
))
3283 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3284 else if (SCM_FRACTIONP (y
))
3285 return scm_i_exact_rational_round_quotient (x
, y
);
3287 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3288 s_scm_round_quotient
);
3290 else if (SCM_BIGP (x
))
3292 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3294 scm_t_inum yy
= SCM_I_INUM (y
);
3295 if (SCM_UNLIKELY (yy
== 0))
3296 scm_num_overflow (s_scm_round_quotient
);
3297 else if (SCM_UNLIKELY (yy
== 1))
3301 SCM q
= scm_i_mkbig ();
3303 int needs_adjustment
;
3307 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3308 SCM_I_BIG_MPZ (x
), yy
);
3309 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3310 needs_adjustment
= (2*rr
>= yy
);
3312 needs_adjustment
= (2*rr
> yy
);
3316 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3317 SCM_I_BIG_MPZ (x
), -yy
);
3318 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3319 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3320 needs_adjustment
= (2*rr
<= yy
);
3322 needs_adjustment
= (2*rr
< yy
);
3324 scm_remember_upto_here_1 (x
);
3325 if (needs_adjustment
)
3326 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3327 return scm_i_normbig (q
);
3330 else if (SCM_BIGP (y
))
3331 return scm_i_bigint_round_quotient (x
, y
);
3332 else if (SCM_REALP (y
))
3333 return scm_i_inexact_round_quotient
3334 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3335 else if (SCM_FRACTIONP (y
))
3336 return scm_i_exact_rational_round_quotient (x
, y
);
3338 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3339 s_scm_round_quotient
);
3341 else if (SCM_REALP (x
))
3343 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3344 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3345 return scm_i_inexact_round_quotient
3346 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3348 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3349 s_scm_round_quotient
);
3351 else if (SCM_FRACTIONP (x
))
3354 return scm_i_inexact_round_quotient
3355 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3356 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3357 return scm_i_exact_rational_round_quotient (x
, y
);
3359 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3360 s_scm_round_quotient
);
3363 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3364 s_scm_round_quotient
);
3369 scm_i_inexact_round_quotient (double x
, double y
)
3371 if (SCM_UNLIKELY (y
== 0))
3372 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3374 return scm_from_double (scm_c_round (x
/ y
));
3377 /* Assumes that both x and y are bigints, though
3378 x might be able to fit into a fixnum. */
3380 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3383 int cmp
, needs_adjustment
;
3385 /* Note that x might be small enough to fit into a
3386 fixnum, so we must not let it escape into the wild */
3389 r2
= scm_i_mkbig ();
3391 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3392 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3393 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3394 scm_remember_upto_here_2 (x
, r
);
3396 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3397 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3398 needs_adjustment
= (cmp
>= 0);
3400 needs_adjustment
= (cmp
> 0);
3401 scm_remember_upto_here_2 (r2
, y
);
3403 if (needs_adjustment
)
3404 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3406 return scm_i_normbig (q
);
3410 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3412 return scm_round_quotient
3413 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3414 scm_product (scm_numerator (y
), scm_denominator (x
)));
3417 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3418 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3419 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3421 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3423 "Return the real number @var{r} such that\n"
3424 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3425 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3426 "nearest integer, with ties going to the nearest\n"
3429 "(round-remainder 123 10) @result{} 3\n"
3430 "(round-remainder 123 -10) @result{} 3\n"
3431 "(round-remainder -123 10) @result{} -3\n"
3432 "(round-remainder -123 -10) @result{} -3\n"
3433 "(round-remainder 125 10) @result{} 5\n"
3434 "(round-remainder 127 10) @result{} -3\n"
3435 "(round-remainder 135 10) @result{} -5\n"
3436 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3437 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3439 #define FUNC_NAME s_scm_round_remainder
3441 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3443 scm_t_inum xx
= SCM_I_INUM (x
);
3444 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3446 scm_t_inum yy
= SCM_I_INUM (y
);
3447 if (SCM_UNLIKELY (yy
== 0))
3448 scm_num_overflow (s_scm_round_remainder
);
3451 scm_t_inum qq
= xx
/ yy
;
3452 scm_t_inum rr
= xx
% yy
;
3454 scm_t_inum r2
= 2 * rr
;
3456 if (SCM_LIKELY (yy
< 0))
3476 return SCM_I_MAKINUM (rr
);
3479 else if (SCM_BIGP (y
))
3481 /* Pass a denormalized bignum version of x (even though it
3482 can fit in a fixnum) to scm_i_bigint_round_remainder */
3483 return scm_i_bigint_round_remainder
3484 (scm_i_long2big (xx
), y
);
3486 else if (SCM_REALP (y
))
3487 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3488 else if (SCM_FRACTIONP (y
))
3489 return scm_i_exact_rational_round_remainder (x
, y
);
3491 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3492 s_scm_round_remainder
);
3494 else if (SCM_BIGP (x
))
3496 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3498 scm_t_inum yy
= SCM_I_INUM (y
);
3499 if (SCM_UNLIKELY (yy
== 0))
3500 scm_num_overflow (s_scm_round_remainder
);
3503 SCM q
= scm_i_mkbig ();
3505 int needs_adjustment
;
3509 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3510 SCM_I_BIG_MPZ (x
), yy
);
3511 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3512 needs_adjustment
= (2*rr
>= yy
);
3514 needs_adjustment
= (2*rr
> yy
);
3518 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3519 SCM_I_BIG_MPZ (x
), -yy
);
3520 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3521 needs_adjustment
= (2*rr
<= yy
);
3523 needs_adjustment
= (2*rr
< yy
);
3525 scm_remember_upto_here_2 (x
, q
);
3526 if (needs_adjustment
)
3528 return SCM_I_MAKINUM (rr
);
3531 else if (SCM_BIGP (y
))
3532 return scm_i_bigint_round_remainder (x
, y
);
3533 else if (SCM_REALP (y
))
3534 return scm_i_inexact_round_remainder
3535 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3536 else if (SCM_FRACTIONP (y
))
3537 return scm_i_exact_rational_round_remainder (x
, y
);
3539 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3540 s_scm_round_remainder
);
3542 else if (SCM_REALP (x
))
3544 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3545 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3546 return scm_i_inexact_round_remainder
3547 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3549 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3550 s_scm_round_remainder
);
3552 else if (SCM_FRACTIONP (x
))
3555 return scm_i_inexact_round_remainder
3556 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3557 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3558 return scm_i_exact_rational_round_remainder (x
, y
);
3560 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3561 s_scm_round_remainder
);
3564 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3565 s_scm_round_remainder
);
3570 scm_i_inexact_round_remainder (double x
, double y
)
3572 /* Although it would be more efficient to use fmod here, we can't
3573 because it would in some cases produce results inconsistent with
3574 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3575 close). In particular, when x-y/2 is very close to a multiple of
3576 y, then r might be either -abs(y/2) or abs(y/2), but those two
3577 cases must correspond to different choices of q. If quotient
3578 chooses one and remainder chooses the other, it would be bad. */
3580 if (SCM_UNLIKELY (y
== 0))
3581 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3584 double q
= scm_c_round (x
/ y
);
3585 return scm_from_double (x
- q
* y
);
3589 /* Assumes that both x and y are bigints, though
3590 x might be able to fit into a fixnum. */
3592 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3595 int cmp
, needs_adjustment
;
3597 /* Note that x might be small enough to fit into a
3598 fixnum, so we must not let it escape into the wild */
3601 r2
= scm_i_mkbig ();
3603 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3604 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3605 scm_remember_upto_here_1 (x
);
3606 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3608 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3609 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3610 needs_adjustment
= (cmp
>= 0);
3612 needs_adjustment
= (cmp
> 0);
3613 scm_remember_upto_here_2 (q
, r2
);
3615 if (needs_adjustment
)
3616 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3618 scm_remember_upto_here_1 (y
);
3619 return scm_i_normbig (r
);
3623 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3625 SCM xd
= scm_denominator (x
);
3626 SCM yd
= scm_denominator (y
);
3627 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3628 scm_product (scm_numerator (y
), xd
));
3629 return scm_divide (r1
, scm_product (xd
, yd
));
3633 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3634 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3635 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3637 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3639 "Return the integer @var{q} and the real number @var{r}\n"
3640 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3641 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3642 "nearest integer, with ties going to the nearest even integer.\n"
3644 "(round/ 123 10) @result{} 12 and 3\n"
3645 "(round/ 123 -10) @result{} -12 and 3\n"
3646 "(round/ -123 10) @result{} -12 and -3\n"
3647 "(round/ -123 -10) @result{} 12 and -3\n"
3648 "(round/ 125 10) @result{} 12 and 5\n"
3649 "(round/ 127 10) @result{} 13 and -3\n"
3650 "(round/ 135 10) @result{} 14 and -5\n"
3651 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3652 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3654 #define FUNC_NAME s_scm_i_round_divide
3658 scm_round_divide(x
, y
, &q
, &r
);
3659 return scm_values (scm_list_2 (q
, r
));
3663 #define s_scm_round_divide s_scm_i_round_divide
3664 #define g_scm_round_divide g_scm_i_round_divide
3667 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3669 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3671 scm_t_inum xx
= SCM_I_INUM (x
);
3672 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3674 scm_t_inum yy
= SCM_I_INUM (y
);
3675 if (SCM_UNLIKELY (yy
== 0))
3676 scm_num_overflow (s_scm_round_divide
);
3679 scm_t_inum qq
= xx
/ yy
;
3680 scm_t_inum rr
= xx
% yy
;
3682 scm_t_inum r2
= 2 * rr
;
3684 if (SCM_LIKELY (yy
< 0))
3704 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3705 *qp
= SCM_I_MAKINUM (qq
);
3707 *qp
= scm_i_inum2big (qq
);
3708 *rp
= SCM_I_MAKINUM (rr
);
3712 else if (SCM_BIGP (y
))
3714 /* Pass a denormalized bignum version of x (even though it
3715 can fit in a fixnum) to scm_i_bigint_round_divide */
3716 return scm_i_bigint_round_divide
3717 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3719 else if (SCM_REALP (y
))
3720 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3721 else if (SCM_FRACTIONP (y
))
3722 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3724 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3725 s_scm_round_divide
, qp
, rp
);
3727 else if (SCM_BIGP (x
))
3729 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3731 scm_t_inum yy
= SCM_I_INUM (y
);
3732 if (SCM_UNLIKELY (yy
== 0))
3733 scm_num_overflow (s_scm_round_divide
);
3736 SCM q
= scm_i_mkbig ();
3738 int needs_adjustment
;
3742 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3743 SCM_I_BIG_MPZ (x
), yy
);
3744 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3745 needs_adjustment
= (2*rr
>= yy
);
3747 needs_adjustment
= (2*rr
> yy
);
3751 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3752 SCM_I_BIG_MPZ (x
), -yy
);
3753 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3754 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3755 needs_adjustment
= (2*rr
<= yy
);
3757 needs_adjustment
= (2*rr
< yy
);
3759 scm_remember_upto_here_1 (x
);
3760 if (needs_adjustment
)
3762 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3765 *qp
= scm_i_normbig (q
);
3766 *rp
= SCM_I_MAKINUM (rr
);
3770 else if (SCM_BIGP (y
))
3771 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3772 else if (SCM_REALP (y
))
3773 return scm_i_inexact_round_divide
3774 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3775 else if (SCM_FRACTIONP (y
))
3776 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3778 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3779 s_scm_round_divide
, qp
, rp
);
3781 else if (SCM_REALP (x
))
3783 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3784 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3785 return scm_i_inexact_round_divide
3786 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3788 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3789 s_scm_round_divide
, qp
, rp
);
3791 else if (SCM_FRACTIONP (x
))
3794 return scm_i_inexact_round_divide
3795 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3796 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3797 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3799 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3800 s_scm_round_divide
, qp
, rp
);
3803 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3804 s_scm_round_divide
, qp
, rp
);
3808 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3810 if (SCM_UNLIKELY (y
== 0))
3811 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3814 double q
= scm_c_round (x
/ y
);
3815 double r
= x
- q
* y
;
3816 *qp
= scm_from_double (q
);
3817 *rp
= scm_from_double (r
);
3821 /* Assumes that both x and y are bigints, though
3822 x might be able to fit into a fixnum. */
3824 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3827 int cmp
, needs_adjustment
;
3829 /* Note that x might be small enough to fit into a
3830 fixnum, so we must not let it escape into the wild */
3833 r2
= scm_i_mkbig ();
3835 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3836 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3837 scm_remember_upto_here_1 (x
);
3838 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3840 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3841 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3842 needs_adjustment
= (cmp
>= 0);
3844 needs_adjustment
= (cmp
> 0);
3846 if (needs_adjustment
)
3848 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3849 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3852 scm_remember_upto_here_2 (r2
, y
);
3853 *qp
= scm_i_normbig (q
);
3854 *rp
= scm_i_normbig (r
);
3858 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3861 SCM xd
= scm_denominator (x
);
3862 SCM yd
= scm_denominator (y
);
3864 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3865 scm_product (scm_numerator (y
), xd
),
3867 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3871 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3872 (SCM x
, SCM y
, SCM rest
),
3873 "Return the greatest common divisor of all parameter values.\n"
3874 "If called without arguments, 0 is returned.")
3875 #define FUNC_NAME s_scm_i_gcd
3877 while (!scm_is_null (rest
))
3878 { x
= scm_gcd (x
, y
);
3880 rest
= scm_cdr (rest
);
3882 return scm_gcd (x
, y
);
3886 #define s_gcd s_scm_i_gcd
3887 #define g_gcd g_scm_i_gcd
3890 scm_gcd (SCM x
, SCM y
)
3892 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
3893 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3895 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3897 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3899 scm_t_inum xx
= SCM_I_INUM (x
);
3900 scm_t_inum yy
= SCM_I_INUM (y
);
3901 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3902 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3904 if (SCM_UNLIKELY (xx
== 0))
3906 else if (SCM_UNLIKELY (yy
== 0))
3911 /* Determine a common factor 2^k */
3912 while (((u
| v
) & 1) == 0)
3918 /* Now, any factor 2^n can be eliminated */
3920 while ((u
& 1) == 0)
3923 while ((v
& 1) == 0)
3925 /* Both u and v are now odd. Subtract the smaller one
3926 from the larger one to produce an even number, remove
3927 more factors of two, and repeat. */
3933 while ((u
& 1) == 0)
3939 while ((v
& 1) == 0)
3945 return (SCM_POSFIXABLE (result
)
3946 ? SCM_I_MAKINUM (result
)
3947 : scm_i_inum2big (result
));
3949 else if (SCM_BIGP (y
))
3955 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3957 else if (SCM_BIGP (x
))
3959 if (SCM_I_INUMP (y
))
3964 yy
= SCM_I_INUM (y
);
3969 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3970 scm_remember_upto_here_1 (x
);
3971 return (SCM_POSFIXABLE (result
)
3972 ? SCM_I_MAKINUM (result
)
3973 : scm_from_unsigned_integer (result
));
3975 else if (SCM_BIGP (y
))
3977 SCM result
= scm_i_mkbig ();
3978 mpz_gcd (SCM_I_BIG_MPZ (result
),
3981 scm_remember_upto_here_2 (x
, y
);
3982 return scm_i_normbig (result
);
3985 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3988 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3991 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3992 (SCM x
, SCM y
, SCM rest
),
3993 "Return the least common multiple of the arguments.\n"
3994 "If called without arguments, 1 is returned.")
3995 #define FUNC_NAME s_scm_i_lcm
3997 while (!scm_is_null (rest
))
3998 { x
= scm_lcm (x
, y
);
4000 rest
= scm_cdr (rest
);
4002 return scm_lcm (x
, y
);
4006 #define s_lcm s_scm_i_lcm
4007 #define g_lcm g_scm_i_lcm
4010 scm_lcm (SCM n1
, SCM n2
)
4012 if (SCM_UNBNDP (n2
))
4014 if (SCM_UNBNDP (n1
))
4015 return SCM_I_MAKINUM (1L);
4016 n2
= SCM_I_MAKINUM (1L);
4019 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
4020 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4021 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
4022 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
4024 if (SCM_I_INUMP (n1
))
4026 if (SCM_I_INUMP (n2
))
4028 SCM d
= scm_gcd (n1
, n2
);
4029 if (scm_is_eq (d
, SCM_INUM0
))
4032 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4036 /* inum n1, big n2 */
4039 SCM result
= scm_i_mkbig ();
4040 scm_t_inum nn1
= SCM_I_INUM (n1
);
4041 if (nn1
== 0) return SCM_INUM0
;
4042 if (nn1
< 0) nn1
= - nn1
;
4043 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4044 scm_remember_upto_here_1 (n2
);
4052 if (SCM_I_INUMP (n2
))
4059 SCM result
= scm_i_mkbig ();
4060 mpz_lcm(SCM_I_BIG_MPZ (result
),
4062 SCM_I_BIG_MPZ (n2
));
4063 scm_remember_upto_here_2(n1
, n2
);
4064 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4070 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4075 + + + x (map digit:logand X Y)
4076 + - + x (map digit:logand X (lognot (+ -1 Y)))
4077 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4078 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4083 + + + (map digit:logior X Y)
4084 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4085 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4086 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4091 + + + (map digit:logxor X Y)
4092 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4093 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4094 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4099 + + (any digit:logand X Y)
4100 + - (any digit:logand X (lognot (+ -1 Y)))
4101 - + (any digit:logand (lognot (+ -1 X)) Y)
4106 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4107 (SCM x
, SCM y
, SCM rest
),
4108 "Return the bitwise AND of the integer arguments.\n\n"
4110 "(logand) @result{} -1\n"
4111 "(logand 7) @result{} 7\n"
4112 "(logand #b111 #b011 #b001) @result{} 1\n"
4114 #define FUNC_NAME s_scm_i_logand
4116 while (!scm_is_null (rest
))
4117 { x
= scm_logand (x
, y
);
4119 rest
= scm_cdr (rest
);
4121 return scm_logand (x
, y
);
4125 #define s_scm_logand s_scm_i_logand
4127 SCM
scm_logand (SCM n1
, SCM n2
)
4128 #define FUNC_NAME s_scm_logand
4132 if (SCM_UNBNDP (n2
))
4134 if (SCM_UNBNDP (n1
))
4135 return SCM_I_MAKINUM (-1);
4136 else if (!SCM_NUMBERP (n1
))
4137 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4138 else if (SCM_NUMBERP (n1
))
4141 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4144 if (SCM_I_INUMP (n1
))
4146 nn1
= SCM_I_INUM (n1
);
4147 if (SCM_I_INUMP (n2
))
4149 scm_t_inum nn2
= SCM_I_INUM (n2
);
4150 return SCM_I_MAKINUM (nn1
& nn2
);
4152 else if SCM_BIGP (n2
)
4158 SCM result_z
= scm_i_mkbig ();
4160 mpz_init_set_si (nn1_z
, nn1
);
4161 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4162 scm_remember_upto_here_1 (n2
);
4164 return scm_i_normbig (result_z
);
4168 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4170 else if (SCM_BIGP (n1
))
4172 if (SCM_I_INUMP (n2
))
4175 nn1
= SCM_I_INUM (n1
);
4178 else if (SCM_BIGP (n2
))
4180 SCM result_z
= scm_i_mkbig ();
4181 mpz_and (SCM_I_BIG_MPZ (result_z
),
4183 SCM_I_BIG_MPZ (n2
));
4184 scm_remember_upto_here_2 (n1
, n2
);
4185 return scm_i_normbig (result_z
);
4188 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4191 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4196 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4197 (SCM x
, SCM y
, SCM rest
),
4198 "Return the bitwise OR of the integer arguments.\n\n"
4200 "(logior) @result{} 0\n"
4201 "(logior 7) @result{} 7\n"
4202 "(logior #b000 #b001 #b011) @result{} 3\n"
4204 #define FUNC_NAME s_scm_i_logior
4206 while (!scm_is_null (rest
))
4207 { x
= scm_logior (x
, y
);
4209 rest
= scm_cdr (rest
);
4211 return scm_logior (x
, y
);
4215 #define s_scm_logior s_scm_i_logior
4217 SCM
scm_logior (SCM n1
, SCM n2
)
4218 #define FUNC_NAME s_scm_logior
4222 if (SCM_UNBNDP (n2
))
4224 if (SCM_UNBNDP (n1
))
4226 else if (SCM_NUMBERP (n1
))
4229 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4232 if (SCM_I_INUMP (n1
))
4234 nn1
= SCM_I_INUM (n1
);
4235 if (SCM_I_INUMP (n2
))
4237 long nn2
= SCM_I_INUM (n2
);
4238 return SCM_I_MAKINUM (nn1
| nn2
);
4240 else if (SCM_BIGP (n2
))
4246 SCM result_z
= scm_i_mkbig ();
4248 mpz_init_set_si (nn1_z
, nn1
);
4249 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4250 scm_remember_upto_here_1 (n2
);
4252 return scm_i_normbig (result_z
);
4256 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4258 else if (SCM_BIGP (n1
))
4260 if (SCM_I_INUMP (n2
))
4263 nn1
= SCM_I_INUM (n1
);
4266 else if (SCM_BIGP (n2
))
4268 SCM result_z
= scm_i_mkbig ();
4269 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4271 SCM_I_BIG_MPZ (n2
));
4272 scm_remember_upto_here_2 (n1
, n2
);
4273 return scm_i_normbig (result_z
);
4276 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4279 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4284 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4285 (SCM x
, SCM y
, SCM rest
),
4286 "Return the bitwise XOR of the integer arguments. A bit is\n"
4287 "set in the result if it is set in an odd number of arguments.\n"
4289 "(logxor) @result{} 0\n"
4290 "(logxor 7) @result{} 7\n"
4291 "(logxor #b000 #b001 #b011) @result{} 2\n"
4292 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4294 #define FUNC_NAME s_scm_i_logxor
4296 while (!scm_is_null (rest
))
4297 { x
= scm_logxor (x
, y
);
4299 rest
= scm_cdr (rest
);
4301 return scm_logxor (x
, y
);
4305 #define s_scm_logxor s_scm_i_logxor
4307 SCM
scm_logxor (SCM n1
, SCM n2
)
4308 #define FUNC_NAME s_scm_logxor
4312 if (SCM_UNBNDP (n2
))
4314 if (SCM_UNBNDP (n1
))
4316 else if (SCM_NUMBERP (n1
))
4319 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4322 if (SCM_I_INUMP (n1
))
4324 nn1
= SCM_I_INUM (n1
);
4325 if (SCM_I_INUMP (n2
))
4327 scm_t_inum nn2
= SCM_I_INUM (n2
);
4328 return SCM_I_MAKINUM (nn1
^ nn2
);
4330 else if (SCM_BIGP (n2
))
4334 SCM result_z
= scm_i_mkbig ();
4336 mpz_init_set_si (nn1_z
, nn1
);
4337 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4338 scm_remember_upto_here_1 (n2
);
4340 return scm_i_normbig (result_z
);
4344 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4346 else if (SCM_BIGP (n1
))
4348 if (SCM_I_INUMP (n2
))
4351 nn1
= SCM_I_INUM (n1
);
4354 else if (SCM_BIGP (n2
))
4356 SCM result_z
= scm_i_mkbig ();
4357 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4359 SCM_I_BIG_MPZ (n2
));
4360 scm_remember_upto_here_2 (n1
, n2
);
4361 return scm_i_normbig (result_z
);
4364 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4367 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4372 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4374 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4375 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4376 "without actually calculating the @code{logand}, just testing\n"
4380 "(logtest #b0100 #b1011) @result{} #f\n"
4381 "(logtest #b0100 #b0111) @result{} #t\n"
4383 #define FUNC_NAME s_scm_logtest
4387 if (SCM_I_INUMP (j
))
4389 nj
= SCM_I_INUM (j
);
4390 if (SCM_I_INUMP (k
))
4392 scm_t_inum nk
= SCM_I_INUM (k
);
4393 return scm_from_bool (nj
& nk
);
4395 else if (SCM_BIGP (k
))
4403 mpz_init_set_si (nj_z
, nj
);
4404 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4405 scm_remember_upto_here_1 (k
);
4406 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4412 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4414 else if (SCM_BIGP (j
))
4416 if (SCM_I_INUMP (k
))
4419 nj
= SCM_I_INUM (j
);
4422 else if (SCM_BIGP (k
))
4426 mpz_init (result_z
);
4430 scm_remember_upto_here_2 (j
, k
);
4431 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4432 mpz_clear (result_z
);
4436 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4439 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4444 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4446 "Test whether bit number @var{index} in @var{j} is set.\n"
4447 "@var{index} starts from 0 for the least significant bit.\n"
4450 "(logbit? 0 #b1101) @result{} #t\n"
4451 "(logbit? 1 #b1101) @result{} #f\n"
4452 "(logbit? 2 #b1101) @result{} #t\n"
4453 "(logbit? 3 #b1101) @result{} #t\n"
4454 "(logbit? 4 #b1101) @result{} #f\n"
4456 #define FUNC_NAME s_scm_logbit_p
4458 unsigned long int iindex
;
4459 iindex
= scm_to_ulong (index
);
4461 if (SCM_I_INUMP (j
))
4463 /* bits above what's in an inum follow the sign bit */
4464 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4465 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4467 else if (SCM_BIGP (j
))
4469 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4470 scm_remember_upto_here_1 (j
);
4471 return scm_from_bool (val
);
4474 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4479 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4481 "Return the integer which is the ones-complement of the integer\n"
4485 "(number->string (lognot #b10000000) 2)\n"
4486 " @result{} \"-10000001\"\n"
4487 "(number->string (lognot #b0) 2)\n"
4488 " @result{} \"-1\"\n"
4490 #define FUNC_NAME s_scm_lognot
4492 if (SCM_I_INUMP (n
)) {
4493 /* No overflow here, just need to toggle all the bits making up the inum.
4494 Enhancement: No need to strip the tag and add it back, could just xor
4495 a block of 1 bits, if that worked with the various debug versions of
4497 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4499 } else if (SCM_BIGP (n
)) {
4500 SCM result
= scm_i_mkbig ();
4501 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4502 scm_remember_upto_here_1 (n
);
4506 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4511 /* returns 0 if IN is not an integer. OUT must already be
4514 coerce_to_big (SCM in
, mpz_t out
)
4517 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4518 else if (SCM_I_INUMP (in
))
4519 mpz_set_si (out
, SCM_I_INUM (in
));
4526 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4527 (SCM n
, SCM k
, SCM m
),
4528 "Return @var{n} raised to the integer exponent\n"
4529 "@var{k}, modulo @var{m}.\n"
4532 "(modulo-expt 2 3 5)\n"
4535 #define FUNC_NAME s_scm_modulo_expt
4541 /* There are two classes of error we might encounter --
4542 1) Math errors, which we'll report by calling scm_num_overflow,
4544 2) wrong-type errors, which of course we'll report by calling
4546 We don't report those errors immediately, however; instead we do
4547 some cleanup first. These variables tell us which error (if
4548 any) we should report after cleaning up.
4550 int report_overflow
= 0;
4552 int position_of_wrong_type
= 0;
4553 SCM value_of_wrong_type
= SCM_INUM0
;
4555 SCM result
= SCM_UNDEFINED
;
4561 if (scm_is_eq (m
, SCM_INUM0
))
4563 report_overflow
= 1;
4567 if (!coerce_to_big (n
, n_tmp
))
4569 value_of_wrong_type
= n
;
4570 position_of_wrong_type
= 1;
4574 if (!coerce_to_big (k
, k_tmp
))
4576 value_of_wrong_type
= k
;
4577 position_of_wrong_type
= 2;
4581 if (!coerce_to_big (m
, m_tmp
))
4583 value_of_wrong_type
= m
;
4584 position_of_wrong_type
= 3;
4588 /* if the exponent K is negative, and we simply call mpz_powm, we
4589 will get a divide-by-zero exception when an inverse 1/n mod m
4590 doesn't exist (or is not unique). Since exceptions are hard to
4591 handle, we'll attempt the inversion "by hand" -- that way, we get
4592 a simple failure code, which is easy to handle. */
4594 if (-1 == mpz_sgn (k_tmp
))
4596 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4598 report_overflow
= 1;
4601 mpz_neg (k_tmp
, k_tmp
);
4604 result
= scm_i_mkbig ();
4605 mpz_powm (SCM_I_BIG_MPZ (result
),
4610 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4611 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4618 if (report_overflow
)
4619 scm_num_overflow (FUNC_NAME
);
4621 if (position_of_wrong_type
)
4622 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4623 value_of_wrong_type
);
4625 return scm_i_normbig (result
);
4629 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4631 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4632 "exact integer, @var{n} can be any number.\n"
4634 "Negative @var{k} is supported, and results in\n"
4635 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4636 "@math{@var{n}^0} is 1, as usual, and that\n"
4637 "includes @math{0^0} is 1.\n"
4640 "(integer-expt 2 5) @result{} 32\n"
4641 "(integer-expt -3 3) @result{} -27\n"
4642 "(integer-expt 5 -3) @result{} 1/125\n"
4643 "(integer-expt 0 0) @result{} 1\n"
4645 #define FUNC_NAME s_scm_integer_expt
4648 SCM z_i2
= SCM_BOOL_F
;
4650 SCM acc
= SCM_I_MAKINUM (1L);
4652 /* Specifically refrain from checking the type of the first argument.
4653 This allows us to exponentiate any object that can be multiplied.
4654 If we must raise to a negative power, we must also be able to
4655 take its reciprocal. */
4656 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4657 SCM_WRONG_TYPE_ARG (2, k
);
4659 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4660 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4661 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4662 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4663 /* The next check is necessary only because R6RS specifies different
4664 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4665 we simply skip this case and move on. */
4666 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4668 /* k cannot be 0 at this point, because we
4669 have already checked for that case above */
4670 if (scm_is_true (scm_positive_p (k
)))
4672 else /* return NaN for (0 ^ k) for negative k per R6RS */
4676 if (SCM_I_INUMP (k
))
4677 i2
= SCM_I_INUM (k
);
4678 else if (SCM_BIGP (k
))
4680 z_i2
= scm_i_clonebig (k
, 1);
4681 scm_remember_upto_here_1 (k
);
4685 SCM_WRONG_TYPE_ARG (2, k
);
4689 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4691 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4692 n
= scm_divide (n
, SCM_UNDEFINED
);
4696 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4700 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4702 return scm_product (acc
, n
);
4704 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4705 acc
= scm_product (acc
, n
);
4706 n
= scm_product (n
, n
);
4707 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4715 n
= scm_divide (n
, SCM_UNDEFINED
);
4722 return scm_product (acc
, n
);
4724 acc
= scm_product (acc
, n
);
4725 n
= scm_product (n
, n
);
4732 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4734 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4735 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4737 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4738 "@var{cnt} is negative it's a division, rounded towards negative\n"
4739 "infinity. (Note that this is not the same rounding as\n"
4740 "@code{quotient} does.)\n"
4742 "With @var{n} viewed as an infinite precision twos complement,\n"
4743 "@code{ash} means a left shift introducing zero bits, or a right\n"
4744 "shift dropping bits.\n"
4747 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4748 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4750 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4751 "(ash -23 -2) @result{} -6\n"
4753 #define FUNC_NAME s_scm_ash
4756 bits_to_shift
= scm_to_long (cnt
);
4758 if (SCM_I_INUMP (n
))
4760 scm_t_inum nn
= SCM_I_INUM (n
);
4762 if (bits_to_shift
> 0)
4764 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4765 overflow a non-zero fixnum. For smaller shifts we check the
4766 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4767 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4768 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4774 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4776 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4779 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4783 SCM result
= scm_i_inum2big (nn
);
4784 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4791 bits_to_shift
= -bits_to_shift
;
4792 if (bits_to_shift
>= SCM_LONG_BIT
)
4793 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4795 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4799 else if (SCM_BIGP (n
))
4803 if (bits_to_shift
== 0)
4806 result
= scm_i_mkbig ();
4807 if (bits_to_shift
>= 0)
4809 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4815 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4816 we have to allocate a bignum even if the result is going to be a
4818 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4820 return scm_i_normbig (result
);
4826 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4832 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4833 (SCM n
, SCM start
, SCM end
),
4834 "Return the integer composed of the @var{start} (inclusive)\n"
4835 "through @var{end} (exclusive) bits of @var{n}. The\n"
4836 "@var{start}th bit becomes the 0-th bit in the result.\n"
4839 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4840 " @result{} \"1010\"\n"
4841 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4842 " @result{} \"10110\"\n"
4844 #define FUNC_NAME s_scm_bit_extract
4846 unsigned long int istart
, iend
, bits
;
4847 istart
= scm_to_ulong (start
);
4848 iend
= scm_to_ulong (end
);
4849 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4851 /* how many bits to keep */
4852 bits
= iend
- istart
;
4854 if (SCM_I_INUMP (n
))
4856 scm_t_inum in
= SCM_I_INUM (n
);
4858 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4859 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4860 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4862 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4864 /* Since we emulate two's complement encoded numbers, this
4865 * special case requires us to produce a result that has
4866 * more bits than can be stored in a fixnum.
4868 SCM result
= scm_i_inum2big (in
);
4869 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4874 /* mask down to requisite bits */
4875 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4876 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4878 else if (SCM_BIGP (n
))
4883 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4887 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4888 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4889 such bits into a ulong. */
4890 result
= scm_i_mkbig ();
4891 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4892 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4893 result
= scm_i_normbig (result
);
4895 scm_remember_upto_here_1 (n
);
4899 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4904 static const char scm_logtab
[] = {
4905 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4908 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4910 "Return the number of bits in integer @var{n}. If integer is\n"
4911 "positive, the 1-bits in its binary representation are counted.\n"
4912 "If negative, the 0-bits in its two's-complement binary\n"
4913 "representation are counted. If 0, 0 is returned.\n"
4916 "(logcount #b10101010)\n"
4923 #define FUNC_NAME s_scm_logcount
4925 if (SCM_I_INUMP (n
))
4927 unsigned long c
= 0;
4928 scm_t_inum nn
= SCM_I_INUM (n
);
4933 c
+= scm_logtab
[15 & nn
];
4936 return SCM_I_MAKINUM (c
);
4938 else if (SCM_BIGP (n
))
4940 unsigned long count
;
4941 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4942 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4944 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4945 scm_remember_upto_here_1 (n
);
4946 return SCM_I_MAKINUM (count
);
4949 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4954 static const char scm_ilentab
[] = {
4955 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4959 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4961 "Return the number of bits necessary to represent @var{n}.\n"
4964 "(integer-length #b10101010)\n"
4966 "(integer-length 0)\n"
4968 "(integer-length #b1111)\n"
4971 #define FUNC_NAME s_scm_integer_length
4973 if (SCM_I_INUMP (n
))
4975 unsigned long c
= 0;
4977 scm_t_inum nn
= SCM_I_INUM (n
);
4983 l
= scm_ilentab
[15 & nn
];
4986 return SCM_I_MAKINUM (c
- 4 + l
);
4988 else if (SCM_BIGP (n
))
4990 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4991 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4992 1 too big, so check for that and adjust. */
4993 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4994 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4995 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4996 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4998 scm_remember_upto_here_1 (n
);
4999 return SCM_I_MAKINUM (size
);
5002 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5006 /*** NUMBERS -> STRINGS ***/
5007 #define SCM_MAX_DBL_PREC 60
5008 #define SCM_MAX_DBL_RADIX 36
5010 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
5011 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
5012 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
5015 void init_dblprec(int *prec
, int radix
) {
5016 /* determine floating point precision by adding successively
5017 smaller increments to 1.0 until it is considered == 1.0 */
5018 double f
= ((double)1.0)/radix
;
5019 double fsum
= 1.0 + f
;
5024 if (++(*prec
) > SCM_MAX_DBL_PREC
)
5036 void init_fx_radix(double *fx_list
, int radix
)
5038 /* initialize a per-radix list of tolerances. When added
5039 to a number < 1.0, we can determine if we should raund
5040 up and quit converting a number to a string. */
5044 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5045 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5048 /* use this array as a way to generate a single digit */
5049 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5052 idbl2str (double f
, char *a
, int radix
)
5054 int efmt
, dpt
, d
, i
, wp
;
5056 #ifdef DBL_MIN_10_EXP
5059 #endif /* DBL_MIN_10_EXP */
5064 radix
> SCM_MAX_DBL_RADIX
)
5066 /* revert to existing behavior */
5070 wp
= scm_dblprec
[radix
-2];
5071 fx
= fx_per_radix
[radix
-2];
5075 #ifdef HAVE_COPYSIGN
5076 double sgn
= copysign (1.0, f
);
5081 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5087 strcpy (a
, "-inf.0");
5089 strcpy (a
, "+inf.0");
5094 strcpy (a
, "+nan.0");
5104 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5105 make-uniform-vector, from causing infinite loops. */
5106 /* just do the checking...if it passes, we do the conversion for our
5107 radix again below */
5114 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5122 while (f_cpy
> 10.0)
5125 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5146 if (f
+ fx
[wp
] >= radix
)
5153 /* adding 9999 makes this equivalent to abs(x) % 3 */
5154 dpt
= (exp
+ 9999) % 3;
5158 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5180 a
[ch
++] = number_chars
[d
];
5183 if (f
+ fx
[wp
] >= 1.0)
5185 a
[ch
- 1] = number_chars
[d
+1];
5197 if ((dpt
> 4) && (exp
> 6))
5199 d
= (a
[0] == '-' ? 2 : 1);
5200 for (i
= ch
++; i
> d
; i
--)
5213 if (a
[ch
- 1] == '.')
5214 a
[ch
++] = '0'; /* trailing zero */
5223 for (i
= radix
; i
<= exp
; i
*= radix
);
5224 for (i
/= radix
; i
; i
/= radix
)
5226 a
[ch
++] = number_chars
[exp
/ i
];
5235 icmplx2str (double real
, double imag
, char *str
, int radix
)
5240 i
= idbl2str (real
, str
, radix
);
5241 #ifdef HAVE_COPYSIGN
5242 sgn
= copysign (1.0, imag
);
5246 /* Don't output a '+' for negative numbers or for Inf and
5247 NaN. They will provide their own sign. */
5248 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5250 i
+= idbl2str (imag
, &str
[i
], radix
);
5256 iflo2str (SCM flt
, char *str
, int radix
)
5259 if (SCM_REALP (flt
))
5260 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5262 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5267 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5268 characters in the result.
5270 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5272 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5277 return scm_iuint2str (-num
, rad
, p
) + 1;
5280 return scm_iuint2str (num
, rad
, p
);
5283 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5284 characters in the result.
5286 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5288 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5292 scm_t_uintmax n
= num
;
5294 if (rad
< 2 || rad
> 36)
5295 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5297 for (n
/= rad
; n
> 0; n
/= rad
)
5307 p
[i
] = number_chars
[d
];
5312 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5314 "Return a string holding the external representation of the\n"
5315 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5316 "inexact, a radix of 10 will be used.")
5317 #define FUNC_NAME s_scm_number_to_string
5321 if (SCM_UNBNDP (radix
))
5324 base
= scm_to_signed_integer (radix
, 2, 36);
5326 if (SCM_I_INUMP (n
))
5328 char num_buf
[SCM_INTBUFLEN
];
5329 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5330 return scm_from_locale_stringn (num_buf
, length
);
5332 else if (SCM_BIGP (n
))
5334 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5335 size_t len
= strlen (str
);
5336 void (*freefunc
) (void *, size_t);
5338 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5339 scm_remember_upto_here_1 (n
);
5340 ret
= scm_from_latin1_stringn (str
, len
);
5341 freefunc (str
, len
+ 1);
5344 else if (SCM_FRACTIONP (n
))
5346 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5347 scm_from_locale_string ("/"),
5348 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5350 else if (SCM_INEXACTP (n
))
5352 char num_buf
[FLOBUFLEN
];
5353 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5356 SCM_WRONG_TYPE_ARG (1, n
);
5361 /* These print routines used to be stubbed here so that scm_repl.c
5362 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5365 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5367 char num_buf
[FLOBUFLEN
];
5368 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5373 scm_i_print_double (double val
, SCM port
)
5375 char num_buf
[FLOBUFLEN
];
5376 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5380 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5383 char num_buf
[FLOBUFLEN
];
5384 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5389 scm_i_print_complex (double real
, double imag
, SCM port
)
5391 char num_buf
[FLOBUFLEN
];
5392 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5396 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5399 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5400 scm_display (str
, port
);
5401 scm_remember_upto_here_1 (str
);
5406 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5408 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5409 size_t len
= strlen (str
);
5410 void (*freefunc
) (void *, size_t);
5411 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5412 scm_remember_upto_here_1 (exp
);
5413 scm_lfwrite (str
, len
, port
);
5414 freefunc (str
, len
+ 1);
5417 /*** END nums->strs ***/
5420 /*** STRINGS -> NUMBERS ***/
5422 /* The following functions implement the conversion from strings to numbers.
5423 * The implementation somehow follows the grammar for numbers as it is given
5424 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5425 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5426 * points should be noted about the implementation:
5428 * * Each function keeps a local index variable 'idx' that points at the
5429 * current position within the parsed string. The global index is only
5430 * updated if the function could parse the corresponding syntactic unit
5433 * * Similarly, the functions keep track of indicators of inexactness ('#',
5434 * '.' or exponents) using local variables ('hash_seen', 'x').
5436 * * Sequences of digits are parsed into temporary variables holding fixnums.
5437 * Only if these fixnums would overflow, the result variables are updated
5438 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5439 * the temporary variables holding the fixnums are cleared, and the process
5440 * starts over again. If for example fixnums were able to store five decimal
5441 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5442 * and the result was computed as 12345 * 100000 + 67890. In other words,
5443 * only every five digits two bignum operations were performed.
5445 * Notes on the handling of exactness specifiers:
5447 * When parsing non-real complex numbers, we apply exactness specifiers on
5448 * per-component basis, as is done in PLT Scheme. For complex numbers
5449 * written in rectangular form, exactness specifiers are applied to the
5450 * real and imaginary parts before calling scm_make_rectangular. For
5451 * complex numbers written in polar form, exactness specifiers are applied
5452 * to the magnitude and angle before calling scm_make_polar.
5454 * There are two kinds of exactness specifiers: forced and implicit. A
5455 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5456 * the entire number, and applies to both components of a complex number.
5457 * "#e" causes each component to be made exact, and "#i" causes each
5458 * component to be made inexact. If no forced exactness specifier is
5459 * present, then the exactness of each component is determined
5460 * independently by the presence or absence of a decimal point or hash mark
5461 * within that component. If a decimal point or hash mark is present, the
5462 * component is made inexact, otherwise it is made exact.
5464 * After the exactness specifiers have been applied to each component, they
5465 * are passed to either scm_make_rectangular or scm_make_polar to produce
5466 * the final result. Note that this will result in a real number if the
5467 * imaginary part, magnitude, or angle is an exact 0.
5469 * For example, (string->number "#i5.0+0i") does the equivalent of:
5471 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5474 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5476 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5478 /* Caller is responsible for checking that the return value is in range
5479 for the given radix, which should be <= 36. */
5481 char_decimal_value (scm_t_uint32 c
)
5483 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5484 that's certainly above any valid decimal, so we take advantage of
5485 that to elide some tests. */
5486 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5488 /* If that failed, try extended hexadecimals, then. Only accept ascii
5493 if (c
>= (scm_t_uint32
) 'a')
5494 d
= c
- (scm_t_uint32
)'a' + 10U;
5499 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5500 in base RADIX. Upon success, return the unsigned integer and update
5501 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5503 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5504 unsigned int radix
, enum t_exactness
*p_exactness
)
5506 unsigned int idx
= *p_idx
;
5507 unsigned int hash_seen
= 0;
5508 scm_t_bits shift
= 1;
5510 unsigned int digit_value
;
5513 size_t len
= scm_i_string_length (mem
);
5518 c
= scm_i_string_ref (mem
, idx
);
5519 digit_value
= char_decimal_value (c
);
5520 if (digit_value
>= radix
)
5524 result
= SCM_I_MAKINUM (digit_value
);
5527 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5537 digit_value
= char_decimal_value (c
);
5538 /* This check catches non-decimals in addition to out-of-range
5540 if (digit_value
>= radix
)
5545 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5547 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5549 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5556 shift
= shift
* radix
;
5557 add
= add
* radix
+ digit_value
;
5562 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5564 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5568 *p_exactness
= INEXACT
;
5574 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5575 * covers the parts of the rules that start at a potential point. The value
5576 * of the digits up to the point have been parsed by the caller and are given
5577 * in variable result. The content of *p_exactness indicates, whether a hash
5578 * has already been seen in the digits before the point.
5581 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5584 mem2decimal_from_point (SCM result
, SCM mem
,
5585 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5587 unsigned int idx
= *p_idx
;
5588 enum t_exactness x
= *p_exactness
;
5589 size_t len
= scm_i_string_length (mem
);
5594 if (scm_i_string_ref (mem
, idx
) == '.')
5596 scm_t_bits shift
= 1;
5598 unsigned int digit_value
;
5599 SCM big_shift
= SCM_INUM1
;
5604 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5605 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5610 digit_value
= DIGIT2UINT (c
);
5621 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5623 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5624 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5626 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5634 add
= add
* 10 + digit_value
;
5640 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5641 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5642 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5645 result
= scm_divide (result
, big_shift
);
5647 /* We've seen a decimal point, thus the value is implicitly inexact. */
5659 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5661 switch (scm_i_string_ref (mem
, idx
))
5673 c
= scm_i_string_ref (mem
, idx
);
5681 c
= scm_i_string_ref (mem
, idx
);
5690 c
= scm_i_string_ref (mem
, idx
);
5695 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5699 exponent
= DIGIT2UINT (c
);
5702 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5703 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5706 if (exponent
<= SCM_MAXEXP
)
5707 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5713 if (exponent
> SCM_MAXEXP
)
5715 size_t exp_len
= idx
- start
;
5716 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5717 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5718 scm_out_of_range ("string->number", exp_num
);
5721 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5723 result
= scm_product (result
, e
);
5725 result
= scm_divide (result
, e
);
5727 /* We've seen an exponent, thus the value is implicitly inexact. */
5745 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5748 mem2ureal (SCM mem
, unsigned int *p_idx
,
5749 unsigned int radix
, enum t_exactness forced_x
)
5751 unsigned int idx
= *p_idx
;
5753 size_t len
= scm_i_string_length (mem
);
5755 /* Start off believing that the number will be exact. This changes
5756 to INEXACT if we see a decimal point or a hash. */
5757 enum t_exactness implicit_x
= EXACT
;
5762 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5768 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5770 /* Cobble up the fractional part. We might want to set the
5771 NaN's mantissa from it. */
5773 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
), SCM_INUM0
))
5775 #if SCM_ENABLE_DEPRECATED == 1
5776 scm_c_issue_deprecation_warning
5777 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5787 if (scm_i_string_ref (mem
, idx
) == '.')
5791 else if (idx
+ 1 == len
)
5793 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5796 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5797 p_idx
, &implicit_x
);
5803 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5804 if (scm_is_false (uinteger
))
5809 else if (scm_i_string_ref (mem
, idx
) == '/')
5817 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5818 if (scm_is_false (divisor
))
5821 /* both are int/big here, I assume */
5822 result
= scm_i_make_ratio (uinteger
, divisor
);
5824 else if (radix
== 10)
5826 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5827 if (scm_is_false (result
))
5839 if (SCM_INEXACTP (result
))
5840 return scm_inexact_to_exact (result
);
5844 if (SCM_INEXACTP (result
))
5847 return scm_exact_to_inexact (result
);
5849 if (implicit_x
== INEXACT
)
5851 if (SCM_INEXACTP (result
))
5854 return scm_exact_to_inexact (result
);
5860 /* We should never get here */
5861 scm_syserror ("mem2ureal");
5865 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5868 mem2complex (SCM mem
, unsigned int idx
,
5869 unsigned int radix
, enum t_exactness forced_x
)
5874 size_t len
= scm_i_string_length (mem
);
5879 c
= scm_i_string_ref (mem
, idx
);
5894 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5895 if (scm_is_false (ureal
))
5897 /* input must be either +i or -i */
5902 if (scm_i_string_ref (mem
, idx
) == 'i'
5903 || scm_i_string_ref (mem
, idx
) == 'I')
5909 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5916 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5917 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5922 c
= scm_i_string_ref (mem
, idx
);
5926 /* either +<ureal>i or -<ureal>i */
5933 return scm_make_rectangular (SCM_INUM0
, ureal
);
5936 /* polar input: <real>@<real>. */
5947 c
= scm_i_string_ref (mem
, idx
);
5965 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5966 if (scm_is_false (angle
))
5971 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5972 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5974 result
= scm_make_polar (ureal
, angle
);
5979 /* expecting input matching <real>[+-]<ureal>?i */
5986 int sign
= (c
== '+') ? 1 : -1;
5987 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5989 if (scm_is_false (imag
))
5990 imag
= SCM_I_MAKINUM (sign
);
5991 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5992 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5996 if (scm_i_string_ref (mem
, idx
) != 'i'
5997 && scm_i_string_ref (mem
, idx
) != 'I')
6004 return scm_make_rectangular (ureal
, imag
);
6013 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6015 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6018 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6020 unsigned int idx
= 0;
6021 unsigned int radix
= NO_RADIX
;
6022 enum t_exactness forced_x
= NO_EXACTNESS
;
6023 size_t len
= scm_i_string_length (mem
);
6025 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6026 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6028 switch (scm_i_string_ref (mem
, idx
+ 1))
6031 if (radix
!= NO_RADIX
)
6036 if (radix
!= NO_RADIX
)
6041 if (forced_x
!= NO_EXACTNESS
)
6046 if (forced_x
!= NO_EXACTNESS
)
6051 if (radix
!= NO_RADIX
)
6056 if (radix
!= NO_RADIX
)
6066 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6067 if (radix
== NO_RADIX
)
6068 radix
= default_radix
;
6070 return mem2complex (mem
, idx
, radix
, forced_x
);
6074 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6075 unsigned int default_radix
)
6077 SCM str
= scm_from_locale_stringn (mem
, len
);
6079 return scm_i_string_to_number (str
, default_radix
);
6083 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6084 (SCM string
, SCM radix
),
6085 "Return a number of the maximally precise representation\n"
6086 "expressed by the given @var{string}. @var{radix} must be an\n"
6087 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6088 "is a default radix that may be overridden by an explicit radix\n"
6089 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6090 "supplied, then the default radix is 10. If string is not a\n"
6091 "syntactically valid notation for a number, then\n"
6092 "@code{string->number} returns @code{#f}.")
6093 #define FUNC_NAME s_scm_string_to_number
6097 SCM_VALIDATE_STRING (1, string
);
6099 if (SCM_UNBNDP (radix
))
6102 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6104 answer
= scm_i_string_to_number (string
, base
);
6105 scm_remember_upto_here_1 (string
);
6111 /*** END strs->nums ***/
6114 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6116 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6118 #define FUNC_NAME s_scm_number_p
6120 return scm_from_bool (SCM_NUMBERP (x
));
6124 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6126 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6127 "otherwise. Note that the sets of real, rational and integer\n"
6128 "values form subsets of the set of complex numbers, i. e. the\n"
6129 "predicate will also be fulfilled if @var{x} is a real,\n"
6130 "rational or integer number.")
6131 #define FUNC_NAME s_scm_complex_p
6133 /* all numbers are complex. */
6134 return scm_number_p (x
);
6138 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6140 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6141 "otherwise. Note that the set of integer values forms a subset of\n"
6142 "the set of real numbers, i. e. the predicate will also be\n"
6143 "fulfilled if @var{x} is an integer number.")
6144 #define FUNC_NAME s_scm_real_p
6146 return scm_from_bool
6147 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6151 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6153 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6154 "otherwise. Note that the set of integer values forms a subset of\n"
6155 "the set of rational numbers, i. e. the predicate will also be\n"
6156 "fulfilled if @var{x} is an integer number.")
6157 #define FUNC_NAME s_scm_rational_p
6159 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6161 else if (SCM_REALP (x
))
6162 /* due to their limited precision, finite floating point numbers are
6163 rational as well. (finite means neither infinity nor a NaN) */
6164 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6170 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6172 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6174 #define FUNC_NAME s_scm_integer_p
6176 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6178 else if (SCM_REALP (x
))
6180 double val
= SCM_REAL_VALUE (x
);
6181 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6189 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6190 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6191 (SCM x
, SCM y
, SCM rest
),
6192 "Return @code{#t} if all parameters are numerically equal.")
6193 #define FUNC_NAME s_scm_i_num_eq_p
6195 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6197 while (!scm_is_null (rest
))
6199 if (scm_is_false (scm_num_eq_p (x
, y
)))
6203 rest
= scm_cdr (rest
);
6205 return scm_num_eq_p (x
, y
);
6209 scm_num_eq_p (SCM x
, SCM y
)
6212 if (SCM_I_INUMP (x
))
6214 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6215 if (SCM_I_INUMP (y
))
6217 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6218 return scm_from_bool (xx
== yy
);
6220 else if (SCM_BIGP (y
))
6222 else if (SCM_REALP (y
))
6224 /* On a 32-bit system an inum fits a double, we can cast the inum
6225 to a double and compare.
6227 But on a 64-bit system an inum is bigger than a double and
6228 casting it to a double (call that dxx) will round. dxx is at
6229 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6230 an integer and fits a long. So we cast yy to a long and
6231 compare with plain xx.
6233 An alternative (for any size system actually) would be to check
6234 yy is an integer (with floor) and is in range of an inum
6235 (compare against appropriate powers of 2) then test
6236 xx==(scm_t_signed_bits)yy. It's just a matter of which
6237 casts/comparisons might be fastest or easiest for the cpu. */
6239 double yy
= SCM_REAL_VALUE (y
);
6240 return scm_from_bool ((double) xx
== yy
6241 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6242 || xx
== (scm_t_signed_bits
) yy
));
6244 else if (SCM_COMPLEXP (y
))
6245 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6246 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6247 else if (SCM_FRACTIONP (y
))
6250 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6252 else if (SCM_BIGP (x
))
6254 if (SCM_I_INUMP (y
))
6256 else if (SCM_BIGP (y
))
6258 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6259 scm_remember_upto_here_2 (x
, y
);
6260 return scm_from_bool (0 == cmp
);
6262 else if (SCM_REALP (y
))
6265 if (isnan (SCM_REAL_VALUE (y
)))
6267 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6268 scm_remember_upto_here_1 (x
);
6269 return scm_from_bool (0 == cmp
);
6271 else if (SCM_COMPLEXP (y
))
6274 if (0.0 != SCM_COMPLEX_IMAG (y
))
6276 if (isnan (SCM_COMPLEX_REAL (y
)))
6278 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6279 scm_remember_upto_here_1 (x
);
6280 return scm_from_bool (0 == cmp
);
6282 else if (SCM_FRACTIONP (y
))
6285 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6287 else if (SCM_REALP (x
))
6289 double xx
= SCM_REAL_VALUE (x
);
6290 if (SCM_I_INUMP (y
))
6292 /* see comments with inum/real above */
6293 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6294 return scm_from_bool (xx
== (double) yy
6295 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6296 || (scm_t_signed_bits
) xx
== yy
));
6298 else if (SCM_BIGP (y
))
6301 if (isnan (SCM_REAL_VALUE (x
)))
6303 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6304 scm_remember_upto_here_1 (y
);
6305 return scm_from_bool (0 == cmp
);
6307 else if (SCM_REALP (y
))
6308 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6309 else if (SCM_COMPLEXP (y
))
6310 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6311 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6312 else if (SCM_FRACTIONP (y
))
6314 double xx
= SCM_REAL_VALUE (x
);
6318 return scm_from_bool (xx
< 0.0);
6319 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6323 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6325 else if (SCM_COMPLEXP (x
))
6327 if (SCM_I_INUMP (y
))
6328 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6329 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6330 else if (SCM_BIGP (y
))
6333 if (0.0 != SCM_COMPLEX_IMAG (x
))
6335 if (isnan (SCM_COMPLEX_REAL (x
)))
6337 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6338 scm_remember_upto_here_1 (y
);
6339 return scm_from_bool (0 == cmp
);
6341 else if (SCM_REALP (y
))
6342 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6343 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6344 else if (SCM_COMPLEXP (y
))
6345 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6346 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6347 else if (SCM_FRACTIONP (y
))
6350 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6352 xx
= SCM_COMPLEX_REAL (x
);
6356 return scm_from_bool (xx
< 0.0);
6357 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6361 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6363 else if (SCM_FRACTIONP (x
))
6365 if (SCM_I_INUMP (y
))
6367 else if (SCM_BIGP (y
))
6369 else if (SCM_REALP (y
))
6371 double yy
= SCM_REAL_VALUE (y
);
6375 return scm_from_bool (0.0 < yy
);
6376 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6379 else if (SCM_COMPLEXP (y
))
6382 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6384 yy
= SCM_COMPLEX_REAL (y
);
6388 return scm_from_bool (0.0 < yy
);
6389 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6392 else if (SCM_FRACTIONP (y
))
6393 return scm_i_fraction_equalp (x
, y
);
6395 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6398 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6402 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6403 done are good for inums, but for bignums an answer can almost always be
6404 had by just examining a few high bits of the operands, as done by GMP in
6405 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6406 of the float exponent to take into account. */
6408 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6409 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6410 (SCM x
, SCM y
, SCM rest
),
6411 "Return @code{#t} if the list of parameters is monotonically\n"
6413 #define FUNC_NAME s_scm_i_num_less_p
6415 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6417 while (!scm_is_null (rest
))
6419 if (scm_is_false (scm_less_p (x
, y
)))
6423 rest
= scm_cdr (rest
);
6425 return scm_less_p (x
, y
);
6429 scm_less_p (SCM x
, SCM y
)
6432 if (SCM_I_INUMP (x
))
6434 scm_t_inum xx
= SCM_I_INUM (x
);
6435 if (SCM_I_INUMP (y
))
6437 scm_t_inum yy
= SCM_I_INUM (y
);
6438 return scm_from_bool (xx
< yy
);
6440 else if (SCM_BIGP (y
))
6442 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6443 scm_remember_upto_here_1 (y
);
6444 return scm_from_bool (sgn
> 0);
6446 else if (SCM_REALP (y
))
6447 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6448 else if (SCM_FRACTIONP (y
))
6450 /* "x < a/b" becomes "x*b < a" */
6452 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6453 y
= SCM_FRACTION_NUMERATOR (y
);
6457 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6459 else if (SCM_BIGP (x
))
6461 if (SCM_I_INUMP (y
))
6463 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6464 scm_remember_upto_here_1 (x
);
6465 return scm_from_bool (sgn
< 0);
6467 else if (SCM_BIGP (y
))
6469 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6470 scm_remember_upto_here_2 (x
, y
);
6471 return scm_from_bool (cmp
< 0);
6473 else if (SCM_REALP (y
))
6476 if (isnan (SCM_REAL_VALUE (y
)))
6478 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6479 scm_remember_upto_here_1 (x
);
6480 return scm_from_bool (cmp
< 0);
6482 else if (SCM_FRACTIONP (y
))
6485 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6487 else if (SCM_REALP (x
))
6489 if (SCM_I_INUMP (y
))
6490 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6491 else if (SCM_BIGP (y
))
6494 if (isnan (SCM_REAL_VALUE (x
)))
6496 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6497 scm_remember_upto_here_1 (y
);
6498 return scm_from_bool (cmp
> 0);
6500 else if (SCM_REALP (y
))
6501 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6502 else if (SCM_FRACTIONP (y
))
6504 double xx
= SCM_REAL_VALUE (x
);
6508 return scm_from_bool (xx
< 0.0);
6509 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6513 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6515 else if (SCM_FRACTIONP (x
))
6517 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6519 /* "a/b < y" becomes "a < y*b" */
6520 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6521 x
= SCM_FRACTION_NUMERATOR (x
);
6524 else if (SCM_REALP (y
))
6526 double yy
= SCM_REAL_VALUE (y
);
6530 return scm_from_bool (0.0 < yy
);
6531 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6534 else if (SCM_FRACTIONP (y
))
6536 /* "a/b < c/d" becomes "a*d < c*b" */
6537 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6538 SCM_FRACTION_DENOMINATOR (y
));
6539 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6540 SCM_FRACTION_DENOMINATOR (x
));
6546 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6549 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6553 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6554 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6555 (SCM x
, SCM y
, SCM rest
),
6556 "Return @code{#t} if the list of parameters is monotonically\n"
6558 #define FUNC_NAME s_scm_i_num_gr_p
6560 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6562 while (!scm_is_null (rest
))
6564 if (scm_is_false (scm_gr_p (x
, y
)))
6568 rest
= scm_cdr (rest
);
6570 return scm_gr_p (x
, y
);
6573 #define FUNC_NAME s_scm_i_num_gr_p
6575 scm_gr_p (SCM x
, SCM y
)
6577 if (!SCM_NUMBERP (x
))
6578 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6579 else if (!SCM_NUMBERP (y
))
6580 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6582 return scm_less_p (y
, x
);
6587 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6588 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6589 (SCM x
, SCM y
, SCM rest
),
6590 "Return @code{#t} if the list of parameters is monotonically\n"
6592 #define FUNC_NAME s_scm_i_num_leq_p
6594 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6596 while (!scm_is_null (rest
))
6598 if (scm_is_false (scm_leq_p (x
, y
)))
6602 rest
= scm_cdr (rest
);
6604 return scm_leq_p (x
, y
);
6607 #define FUNC_NAME s_scm_i_num_leq_p
6609 scm_leq_p (SCM x
, SCM y
)
6611 if (!SCM_NUMBERP (x
))
6612 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6613 else if (!SCM_NUMBERP (y
))
6614 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6615 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6618 return scm_not (scm_less_p (y
, x
));
6623 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6624 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6625 (SCM x
, SCM y
, SCM rest
),
6626 "Return @code{#t} if the list of parameters is monotonically\n"
6628 #define FUNC_NAME s_scm_i_num_geq_p
6630 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6632 while (!scm_is_null (rest
))
6634 if (scm_is_false (scm_geq_p (x
, y
)))
6638 rest
= scm_cdr (rest
);
6640 return scm_geq_p (x
, y
);
6643 #define FUNC_NAME s_scm_i_num_geq_p
6645 scm_geq_p (SCM x
, SCM y
)
6647 if (!SCM_NUMBERP (x
))
6648 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6649 else if (!SCM_NUMBERP (y
))
6650 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6651 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6654 return scm_not (scm_less_p (x
, y
));
6659 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6661 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6663 #define FUNC_NAME s_scm_zero_p
6665 if (SCM_I_INUMP (z
))
6666 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6667 else if (SCM_BIGP (z
))
6669 else if (SCM_REALP (z
))
6670 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6671 else if (SCM_COMPLEXP (z
))
6672 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6673 && SCM_COMPLEX_IMAG (z
) == 0.0);
6674 else if (SCM_FRACTIONP (z
))
6677 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6682 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6684 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6686 #define FUNC_NAME s_scm_positive_p
6688 if (SCM_I_INUMP (x
))
6689 return scm_from_bool (SCM_I_INUM (x
) > 0);
6690 else if (SCM_BIGP (x
))
6692 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6693 scm_remember_upto_here_1 (x
);
6694 return scm_from_bool (sgn
> 0);
6696 else if (SCM_REALP (x
))
6697 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6698 else if (SCM_FRACTIONP (x
))
6699 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6701 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6706 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6708 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6710 #define FUNC_NAME s_scm_negative_p
6712 if (SCM_I_INUMP (x
))
6713 return scm_from_bool (SCM_I_INUM (x
) < 0);
6714 else if (SCM_BIGP (x
))
6716 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6717 scm_remember_upto_here_1 (x
);
6718 return scm_from_bool (sgn
< 0);
6720 else if (SCM_REALP (x
))
6721 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6722 else if (SCM_FRACTIONP (x
))
6723 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6725 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6730 /* scm_min and scm_max return an inexact when either argument is inexact, as
6731 required by r5rs. On that basis, for exact/inexact combinations the
6732 exact is converted to inexact to compare and possibly return. This is
6733 unlike scm_less_p above which takes some trouble to preserve all bits in
6734 its test, such trouble is not required for min and max. */
6736 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6737 (SCM x
, SCM y
, SCM rest
),
6738 "Return the maximum of all parameter values.")
6739 #define FUNC_NAME s_scm_i_max
6741 while (!scm_is_null (rest
))
6742 { x
= scm_max (x
, y
);
6744 rest
= scm_cdr (rest
);
6746 return scm_max (x
, y
);
6750 #define s_max s_scm_i_max
6751 #define g_max g_scm_i_max
6754 scm_max (SCM x
, SCM y
)
6759 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6760 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6763 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6766 if (SCM_I_INUMP (x
))
6768 scm_t_inum xx
= SCM_I_INUM (x
);
6769 if (SCM_I_INUMP (y
))
6771 scm_t_inum yy
= SCM_I_INUM (y
);
6772 return (xx
< yy
) ? y
: x
;
6774 else if (SCM_BIGP (y
))
6776 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6777 scm_remember_upto_here_1 (y
);
6778 return (sgn
< 0) ? x
: y
;
6780 else if (SCM_REALP (y
))
6783 double yyd
= SCM_REAL_VALUE (y
);
6786 return scm_from_double (xxd
);
6787 /* If y is a NaN, then "==" is false and we return the NaN */
6788 else if (SCM_LIKELY (!(xxd
== yyd
)))
6790 /* Handle signed zeroes properly */
6796 else if (SCM_FRACTIONP (y
))
6799 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6802 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6804 else if (SCM_BIGP (x
))
6806 if (SCM_I_INUMP (y
))
6808 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6809 scm_remember_upto_here_1 (x
);
6810 return (sgn
< 0) ? y
: x
;
6812 else if (SCM_BIGP (y
))
6814 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6815 scm_remember_upto_here_2 (x
, y
);
6816 return (cmp
> 0) ? x
: y
;
6818 else if (SCM_REALP (y
))
6820 /* if y==NaN then xx>yy is false, so we return the NaN y */
6823 xx
= scm_i_big2dbl (x
);
6824 yy
= SCM_REAL_VALUE (y
);
6825 return (xx
> yy
? scm_from_double (xx
) : y
);
6827 else if (SCM_FRACTIONP (y
))
6832 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6834 else if (SCM_REALP (x
))
6836 if (SCM_I_INUMP (y
))
6838 scm_t_inum yy
= SCM_I_INUM (y
);
6839 double xxd
= SCM_REAL_VALUE (x
);
6843 return scm_from_double (yyd
);
6844 /* If x is a NaN, then "==" is false and we return the NaN */
6845 else if (SCM_LIKELY (!(xxd
== yyd
)))
6847 /* Handle signed zeroes properly */
6853 else if (SCM_BIGP (y
))
6858 else if (SCM_REALP (y
))
6860 double xx
= SCM_REAL_VALUE (x
);
6861 double yy
= SCM_REAL_VALUE (y
);
6863 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6866 else if (SCM_LIKELY (xx
< yy
))
6868 /* If neither (xx > yy) nor (xx < yy), then
6869 either they're equal or one is a NaN */
6870 else if (SCM_UNLIKELY (isnan (xx
)))
6871 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6872 else if (SCM_UNLIKELY (isnan (yy
)))
6873 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6874 /* xx == yy, but handle signed zeroes properly */
6875 else if (double_is_non_negative_zero (yy
))
6880 else if (SCM_FRACTIONP (y
))
6882 double yy
= scm_i_fraction2double (y
);
6883 double xx
= SCM_REAL_VALUE (x
);
6884 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6887 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6889 else if (SCM_FRACTIONP (x
))
6891 if (SCM_I_INUMP (y
))
6895 else if (SCM_BIGP (y
))
6899 else if (SCM_REALP (y
))
6901 double xx
= scm_i_fraction2double (x
);
6902 /* if y==NaN then ">" is false, so we return the NaN y */
6903 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6905 else if (SCM_FRACTIONP (y
))
6910 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6913 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6917 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6918 (SCM x
, SCM y
, SCM rest
),
6919 "Return the minimum of all parameter values.")
6920 #define FUNC_NAME s_scm_i_min
6922 while (!scm_is_null (rest
))
6923 { x
= scm_min (x
, y
);
6925 rest
= scm_cdr (rest
);
6927 return scm_min (x
, y
);
6931 #define s_min s_scm_i_min
6932 #define g_min g_scm_i_min
6935 scm_min (SCM x
, SCM y
)
6940 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
6941 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6944 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
6947 if (SCM_I_INUMP (x
))
6949 scm_t_inum xx
= SCM_I_INUM (x
);
6950 if (SCM_I_INUMP (y
))
6952 scm_t_inum yy
= SCM_I_INUM (y
);
6953 return (xx
< yy
) ? x
: y
;
6955 else if (SCM_BIGP (y
))
6957 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6958 scm_remember_upto_here_1 (y
);
6959 return (sgn
< 0) ? y
: x
;
6961 else if (SCM_REALP (y
))
6964 /* if y==NaN then "<" is false and we return NaN */
6965 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6967 else if (SCM_FRACTIONP (y
))
6970 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6973 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6975 else if (SCM_BIGP (x
))
6977 if (SCM_I_INUMP (y
))
6979 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6980 scm_remember_upto_here_1 (x
);
6981 return (sgn
< 0) ? x
: y
;
6983 else if (SCM_BIGP (y
))
6985 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6986 scm_remember_upto_here_2 (x
, y
);
6987 return (cmp
> 0) ? y
: x
;
6989 else if (SCM_REALP (y
))
6991 /* if y==NaN then xx<yy is false, so we return the NaN y */
6994 xx
= scm_i_big2dbl (x
);
6995 yy
= SCM_REAL_VALUE (y
);
6996 return (xx
< yy
? scm_from_double (xx
) : y
);
6998 else if (SCM_FRACTIONP (y
))
7003 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7005 else if (SCM_REALP (x
))
7007 if (SCM_I_INUMP (y
))
7009 double z
= SCM_I_INUM (y
);
7010 /* if x==NaN then "<" is false and we return NaN */
7011 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7013 else if (SCM_BIGP (y
))
7018 else if (SCM_REALP (y
))
7020 double xx
= SCM_REAL_VALUE (x
);
7021 double yy
= SCM_REAL_VALUE (y
);
7023 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7026 else if (SCM_LIKELY (xx
> yy
))
7028 /* If neither (xx < yy) nor (xx > yy), then
7029 either they're equal or one is a NaN */
7030 else if (SCM_UNLIKELY (isnan (xx
)))
7031 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7032 else if (SCM_UNLIKELY (isnan (yy
)))
7033 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7034 /* xx == yy, but handle signed zeroes properly */
7035 else if (double_is_non_negative_zero (xx
))
7040 else if (SCM_FRACTIONP (y
))
7042 double yy
= scm_i_fraction2double (y
);
7043 double xx
= SCM_REAL_VALUE (x
);
7044 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7047 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7049 else if (SCM_FRACTIONP (x
))
7051 if (SCM_I_INUMP (y
))
7055 else if (SCM_BIGP (y
))
7059 else if (SCM_REALP (y
))
7061 double xx
= scm_i_fraction2double (x
);
7062 /* if y==NaN then "<" is false, so we return the NaN y */
7063 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7065 else if (SCM_FRACTIONP (y
))
7070 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7073 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7077 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7078 (SCM x
, SCM y
, SCM rest
),
7079 "Return the sum of all parameter values. Return 0 if called without\n"
7081 #define FUNC_NAME s_scm_i_sum
7083 while (!scm_is_null (rest
))
7084 { x
= scm_sum (x
, y
);
7086 rest
= scm_cdr (rest
);
7088 return scm_sum (x
, y
);
7092 #define s_sum s_scm_i_sum
7093 #define g_sum g_scm_i_sum
7096 scm_sum (SCM x
, SCM y
)
7098 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7100 if (SCM_NUMBERP (x
)) return x
;
7101 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7102 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7105 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7107 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7109 scm_t_inum xx
= SCM_I_INUM (x
);
7110 scm_t_inum yy
= SCM_I_INUM (y
);
7111 scm_t_inum z
= xx
+ yy
;
7112 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7114 else if (SCM_BIGP (y
))
7119 else if (SCM_REALP (y
))
7121 scm_t_inum xx
= SCM_I_INUM (x
);
7122 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7124 else if (SCM_COMPLEXP (y
))
7126 scm_t_inum xx
= SCM_I_INUM (x
);
7127 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7128 SCM_COMPLEX_IMAG (y
));
7130 else if (SCM_FRACTIONP (y
))
7131 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7132 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7133 SCM_FRACTION_DENOMINATOR (y
));
7135 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7136 } else if (SCM_BIGP (x
))
7138 if (SCM_I_INUMP (y
))
7143 inum
= SCM_I_INUM (y
);
7146 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7149 SCM result
= scm_i_mkbig ();
7150 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7151 scm_remember_upto_here_1 (x
);
7152 /* we know the result will have to be a bignum */
7155 return scm_i_normbig (result
);
7159 SCM result
= scm_i_mkbig ();
7160 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7161 scm_remember_upto_here_1 (x
);
7162 /* we know the result will have to be a bignum */
7165 return scm_i_normbig (result
);
7168 else if (SCM_BIGP (y
))
7170 SCM result
= scm_i_mkbig ();
7171 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7172 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7173 mpz_add (SCM_I_BIG_MPZ (result
),
7176 scm_remember_upto_here_2 (x
, y
);
7177 /* we know the result will have to be a bignum */
7180 return scm_i_normbig (result
);
7182 else if (SCM_REALP (y
))
7184 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7185 scm_remember_upto_here_1 (x
);
7186 return scm_from_double (result
);
7188 else if (SCM_COMPLEXP (y
))
7190 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7191 + SCM_COMPLEX_REAL (y
));
7192 scm_remember_upto_here_1 (x
);
7193 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7195 else if (SCM_FRACTIONP (y
))
7196 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7197 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7198 SCM_FRACTION_DENOMINATOR (y
));
7200 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7202 else if (SCM_REALP (x
))
7204 if (SCM_I_INUMP (y
))
7205 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7206 else if (SCM_BIGP (y
))
7208 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7209 scm_remember_upto_here_1 (y
);
7210 return scm_from_double (result
);
7212 else if (SCM_REALP (y
))
7213 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7214 else if (SCM_COMPLEXP (y
))
7215 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7216 SCM_COMPLEX_IMAG (y
));
7217 else if (SCM_FRACTIONP (y
))
7218 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7220 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7222 else if (SCM_COMPLEXP (x
))
7224 if (SCM_I_INUMP (y
))
7225 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7226 SCM_COMPLEX_IMAG (x
));
7227 else if (SCM_BIGP (y
))
7229 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7230 + SCM_COMPLEX_REAL (x
));
7231 scm_remember_upto_here_1 (y
);
7232 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7234 else if (SCM_REALP (y
))
7235 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7236 SCM_COMPLEX_IMAG (x
));
7237 else if (SCM_COMPLEXP (y
))
7238 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7239 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7240 else if (SCM_FRACTIONP (y
))
7241 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7242 SCM_COMPLEX_IMAG (x
));
7244 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7246 else if (SCM_FRACTIONP (x
))
7248 if (SCM_I_INUMP (y
))
7249 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7250 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7251 SCM_FRACTION_DENOMINATOR (x
));
7252 else if (SCM_BIGP (y
))
7253 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7254 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7255 SCM_FRACTION_DENOMINATOR (x
));
7256 else if (SCM_REALP (y
))
7257 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7258 else if (SCM_COMPLEXP (y
))
7259 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7260 SCM_COMPLEX_IMAG (y
));
7261 else if (SCM_FRACTIONP (y
))
7262 /* a/b + c/d = (ad + bc) / bd */
7263 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7264 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7265 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7267 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7270 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7274 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7276 "Return @math{@var{x}+1}.")
7277 #define FUNC_NAME s_scm_oneplus
7279 return scm_sum (x
, SCM_INUM1
);
7284 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7285 (SCM x
, SCM y
, SCM rest
),
7286 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7287 "the sum of all but the first argument are subtracted from the first\n"
7289 #define FUNC_NAME s_scm_i_difference
7291 while (!scm_is_null (rest
))
7292 { x
= scm_difference (x
, y
);
7294 rest
= scm_cdr (rest
);
7296 return scm_difference (x
, y
);
7300 #define s_difference s_scm_i_difference
7301 #define g_difference g_scm_i_difference
7304 scm_difference (SCM x
, SCM y
)
7305 #define FUNC_NAME s_difference
7307 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7310 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7312 if (SCM_I_INUMP (x
))
7314 scm_t_inum xx
= -SCM_I_INUM (x
);
7315 if (SCM_FIXABLE (xx
))
7316 return SCM_I_MAKINUM (xx
);
7318 return scm_i_inum2big (xx
);
7320 else if (SCM_BIGP (x
))
7321 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7322 bignum, but negating that gives a fixnum. */
7323 return scm_i_normbig (scm_i_clonebig (x
, 0));
7324 else if (SCM_REALP (x
))
7325 return scm_from_double (-SCM_REAL_VALUE (x
));
7326 else if (SCM_COMPLEXP (x
))
7327 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7328 -SCM_COMPLEX_IMAG (x
));
7329 else if (SCM_FRACTIONP (x
))
7330 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7331 SCM_FRACTION_DENOMINATOR (x
));
7333 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7336 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7338 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7340 scm_t_inum xx
= SCM_I_INUM (x
);
7341 scm_t_inum yy
= SCM_I_INUM (y
);
7342 scm_t_inum z
= xx
- yy
;
7343 if (SCM_FIXABLE (z
))
7344 return SCM_I_MAKINUM (z
);
7346 return scm_i_inum2big (z
);
7348 else if (SCM_BIGP (y
))
7350 /* inum-x - big-y */
7351 scm_t_inum xx
= SCM_I_INUM (x
);
7355 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7356 bignum, but negating that gives a fixnum. */
7357 return scm_i_normbig (scm_i_clonebig (y
, 0));
7361 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7362 SCM result
= scm_i_mkbig ();
7365 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7368 /* x - y == -(y + -x) */
7369 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7370 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7372 scm_remember_upto_here_1 (y
);
7374 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7375 /* we know the result will have to be a bignum */
7378 return scm_i_normbig (result
);
7381 else if (SCM_REALP (y
))
7383 scm_t_inum xx
= SCM_I_INUM (x
);
7386 * We need to handle x == exact 0
7387 * specially because R6RS states that:
7388 * (- 0.0) ==> -0.0 and
7389 * (- 0.0 0.0) ==> 0.0
7390 * and the scheme compiler changes
7391 * (- 0.0) into (- 0 0.0)
7392 * So we need to treat (- 0 0.0) like (- 0.0).
7393 * At the C level, (-x) is different than (0.0 - x).
7394 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7397 return scm_from_double (- SCM_REAL_VALUE (y
));
7399 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7401 else if (SCM_COMPLEXP (y
))
7403 scm_t_inum xx
= SCM_I_INUM (x
);
7405 /* We need to handle x == exact 0 specially.
7406 See the comment above (for SCM_REALP (y)) */
7408 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7409 - SCM_COMPLEX_IMAG (y
));
7411 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7412 - SCM_COMPLEX_IMAG (y
));
7414 else if (SCM_FRACTIONP (y
))
7415 /* a - b/c = (ac - b) / c */
7416 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7417 SCM_FRACTION_NUMERATOR (y
)),
7418 SCM_FRACTION_DENOMINATOR (y
));
7420 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7422 else if (SCM_BIGP (x
))
7424 if (SCM_I_INUMP (y
))
7426 /* big-x - inum-y */
7427 scm_t_inum yy
= SCM_I_INUM (y
);
7428 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7430 scm_remember_upto_here_1 (x
);
7432 return (SCM_FIXABLE (-yy
) ?
7433 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7436 SCM result
= scm_i_mkbig ();
7439 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7441 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7442 scm_remember_upto_here_1 (x
);
7444 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7445 /* we know the result will have to be a bignum */
7448 return scm_i_normbig (result
);
7451 else if (SCM_BIGP (y
))
7453 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7454 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7455 SCM result
= scm_i_mkbig ();
7456 mpz_sub (SCM_I_BIG_MPZ (result
),
7459 scm_remember_upto_here_2 (x
, y
);
7460 /* we know the result will have to be a bignum */
7461 if ((sgn_x
== 1) && (sgn_y
== -1))
7463 if ((sgn_x
== -1) && (sgn_y
== 1))
7465 return scm_i_normbig (result
);
7467 else if (SCM_REALP (y
))
7469 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7470 scm_remember_upto_here_1 (x
);
7471 return scm_from_double (result
);
7473 else if (SCM_COMPLEXP (y
))
7475 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7476 - SCM_COMPLEX_REAL (y
));
7477 scm_remember_upto_here_1 (x
);
7478 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7480 else if (SCM_FRACTIONP (y
))
7481 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7482 SCM_FRACTION_NUMERATOR (y
)),
7483 SCM_FRACTION_DENOMINATOR (y
));
7484 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7486 else if (SCM_REALP (x
))
7488 if (SCM_I_INUMP (y
))
7489 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7490 else if (SCM_BIGP (y
))
7492 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7493 scm_remember_upto_here_1 (x
);
7494 return scm_from_double (result
);
7496 else if (SCM_REALP (y
))
7497 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7498 else if (SCM_COMPLEXP (y
))
7499 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7500 -SCM_COMPLEX_IMAG (y
));
7501 else if (SCM_FRACTIONP (y
))
7502 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7504 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7506 else if (SCM_COMPLEXP (x
))
7508 if (SCM_I_INUMP (y
))
7509 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7510 SCM_COMPLEX_IMAG (x
));
7511 else if (SCM_BIGP (y
))
7513 double real_part
= (SCM_COMPLEX_REAL (x
)
7514 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7515 scm_remember_upto_here_1 (x
);
7516 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7518 else if (SCM_REALP (y
))
7519 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7520 SCM_COMPLEX_IMAG (x
));
7521 else if (SCM_COMPLEXP (y
))
7522 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7523 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7524 else if (SCM_FRACTIONP (y
))
7525 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7526 SCM_COMPLEX_IMAG (x
));
7528 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7530 else if (SCM_FRACTIONP (x
))
7532 if (SCM_I_INUMP (y
))
7533 /* a/b - c = (a - cb) / b */
7534 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7535 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7536 SCM_FRACTION_DENOMINATOR (x
));
7537 else if (SCM_BIGP (y
))
7538 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7539 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7540 SCM_FRACTION_DENOMINATOR (x
));
7541 else if (SCM_REALP (y
))
7542 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7543 else if (SCM_COMPLEXP (y
))
7544 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7545 -SCM_COMPLEX_IMAG (y
));
7546 else if (SCM_FRACTIONP (y
))
7547 /* a/b - c/d = (ad - bc) / bd */
7548 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7549 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7550 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7552 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7555 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7560 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7562 "Return @math{@var{x}-1}.")
7563 #define FUNC_NAME s_scm_oneminus
7565 return scm_difference (x
, SCM_INUM1
);
7570 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7571 (SCM x
, SCM y
, SCM rest
),
7572 "Return the product of all arguments. If called without arguments,\n"
7574 #define FUNC_NAME s_scm_i_product
7576 while (!scm_is_null (rest
))
7577 { x
= scm_product (x
, y
);
7579 rest
= scm_cdr (rest
);
7581 return scm_product (x
, y
);
7585 #define s_product s_scm_i_product
7586 #define g_product g_scm_i_product
7589 scm_product (SCM x
, SCM y
)
7591 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7594 return SCM_I_MAKINUM (1L);
7595 else if (SCM_NUMBERP (x
))
7598 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7601 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7606 xx
= SCM_I_INUM (x
);
7611 /* exact1 is the universal multiplicative identity */
7615 /* exact0 times a fixnum is exact0: optimize this case */
7616 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7618 /* if the other argument is inexact, the result is inexact,
7619 and we must do the multiplication in order to handle
7620 infinities and NaNs properly. */
7621 else if (SCM_REALP (y
))
7622 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7623 else if (SCM_COMPLEXP (y
))
7624 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7625 0.0 * SCM_COMPLEX_IMAG (y
));
7626 /* we've already handled inexact numbers,
7627 so y must be exact, and we return exact0 */
7628 else if (SCM_NUMP (y
))
7631 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7635 * This case is important for more than just optimization.
7636 * It handles the case of negating
7637 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7638 * which is a bignum that must be changed back into a fixnum.
7639 * Failure to do so will cause the following to return #f:
7640 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7642 return scm_difference(y
, SCM_UNDEFINED
);
7646 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7648 scm_t_inum yy
= SCM_I_INUM (y
);
7649 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
7650 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
7651 if (SCM_FIXABLE (kk
))
7652 return SCM_I_MAKINUM (kk
);
7654 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
7655 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
7656 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
7657 return SCM_I_MAKINUM (xx
* yy
);
7661 SCM result
= scm_i_inum2big (xx
);
7662 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7663 return scm_i_normbig (result
);
7666 else if (SCM_BIGP (y
))
7668 SCM result
= scm_i_mkbig ();
7669 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7670 scm_remember_upto_here_1 (y
);
7673 else if (SCM_REALP (y
))
7674 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7675 else if (SCM_COMPLEXP (y
))
7676 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7677 xx
* SCM_COMPLEX_IMAG (y
));
7678 else if (SCM_FRACTIONP (y
))
7679 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7680 SCM_FRACTION_DENOMINATOR (y
));
7682 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7684 else if (SCM_BIGP (x
))
7686 if (SCM_I_INUMP (y
))
7691 else if (SCM_BIGP (y
))
7693 SCM result
= scm_i_mkbig ();
7694 mpz_mul (SCM_I_BIG_MPZ (result
),
7697 scm_remember_upto_here_2 (x
, y
);
7700 else if (SCM_REALP (y
))
7702 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7703 scm_remember_upto_here_1 (x
);
7704 return scm_from_double (result
);
7706 else if (SCM_COMPLEXP (y
))
7708 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7709 scm_remember_upto_here_1 (x
);
7710 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7711 z
* SCM_COMPLEX_IMAG (y
));
7713 else if (SCM_FRACTIONP (y
))
7714 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7715 SCM_FRACTION_DENOMINATOR (y
));
7717 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7719 else if (SCM_REALP (x
))
7721 if (SCM_I_INUMP (y
))
7726 else if (SCM_BIGP (y
))
7728 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7729 scm_remember_upto_here_1 (y
);
7730 return scm_from_double (result
);
7732 else if (SCM_REALP (y
))
7733 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7734 else if (SCM_COMPLEXP (y
))
7735 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7736 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7737 else if (SCM_FRACTIONP (y
))
7738 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7740 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7742 else if (SCM_COMPLEXP (x
))
7744 if (SCM_I_INUMP (y
))
7749 else if (SCM_BIGP (y
))
7751 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7752 scm_remember_upto_here_1 (y
);
7753 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7754 z
* SCM_COMPLEX_IMAG (x
));
7756 else if (SCM_REALP (y
))
7757 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7758 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7759 else if (SCM_COMPLEXP (y
))
7761 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7762 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7763 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7764 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7766 else if (SCM_FRACTIONP (y
))
7768 double yy
= scm_i_fraction2double (y
);
7769 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7770 yy
* SCM_COMPLEX_IMAG (x
));
7773 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7775 else if (SCM_FRACTIONP (x
))
7777 if (SCM_I_INUMP (y
))
7778 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7779 SCM_FRACTION_DENOMINATOR (x
));
7780 else if (SCM_BIGP (y
))
7781 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7782 SCM_FRACTION_DENOMINATOR (x
));
7783 else if (SCM_REALP (y
))
7784 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7785 else if (SCM_COMPLEXP (y
))
7787 double xx
= scm_i_fraction2double (x
);
7788 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7789 xx
* SCM_COMPLEX_IMAG (y
));
7791 else if (SCM_FRACTIONP (y
))
7792 /* a/b * c/d = ac / bd */
7793 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7794 SCM_FRACTION_NUMERATOR (y
)),
7795 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7796 SCM_FRACTION_DENOMINATOR (y
)));
7798 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7801 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7804 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7805 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7806 #define ALLOW_DIVIDE_BY_ZERO
7807 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7810 /* The code below for complex division is adapted from the GNU
7811 libstdc++, which adapted it from f2c's libF77, and is subject to
7814 /****************************************************************
7815 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7817 Permission to use, copy, modify, and distribute this software
7818 and its documentation for any purpose and without fee is hereby
7819 granted, provided that the above copyright notice appear in all
7820 copies and that both that the copyright notice and this
7821 permission notice and warranty disclaimer appear in supporting
7822 documentation, and that the names of AT&T Bell Laboratories or
7823 Bellcore or any of their entities not be used in advertising or
7824 publicity pertaining to distribution of the software without
7825 specific, written prior permission.
7827 AT&T and Bellcore disclaim all warranties with regard to this
7828 software, including all implied warranties of merchantability
7829 and fitness. In no event shall AT&T or Bellcore be liable for
7830 any special, indirect or consequential damages or any damages
7831 whatsoever resulting from loss of use, data or profits, whether
7832 in an action of contract, negligence or other tortious action,
7833 arising out of or in connection with the use or performance of
7835 ****************************************************************/
7837 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7838 (SCM x
, SCM y
, SCM rest
),
7839 "Divide the first argument by the product of the remaining\n"
7840 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7842 #define FUNC_NAME s_scm_i_divide
7844 while (!scm_is_null (rest
))
7845 { x
= scm_divide (x
, y
);
7847 rest
= scm_cdr (rest
);
7849 return scm_divide (x
, y
);
7853 #define s_divide s_scm_i_divide
7854 #define g_divide g_scm_i_divide
7857 do_divide (SCM x
, SCM y
, int inexact
)
7858 #define FUNC_NAME s_divide
7862 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7865 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7866 else if (SCM_I_INUMP (x
))
7868 scm_t_inum xx
= SCM_I_INUM (x
);
7869 if (xx
== 1 || xx
== -1)
7871 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7873 scm_num_overflow (s_divide
);
7878 return scm_from_double (1.0 / (double) xx
);
7879 else return scm_i_make_ratio (SCM_INUM1
, x
);
7882 else if (SCM_BIGP (x
))
7885 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7886 else return scm_i_make_ratio (SCM_INUM1
, x
);
7888 else if (SCM_REALP (x
))
7890 double xx
= SCM_REAL_VALUE (x
);
7891 #ifndef ALLOW_DIVIDE_BY_ZERO
7893 scm_num_overflow (s_divide
);
7896 return scm_from_double (1.0 / xx
);
7898 else if (SCM_COMPLEXP (x
))
7900 double r
= SCM_COMPLEX_REAL (x
);
7901 double i
= SCM_COMPLEX_IMAG (x
);
7902 if (fabs(r
) <= fabs(i
))
7905 double d
= i
* (1.0 + t
* t
);
7906 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7911 double d
= r
* (1.0 + t
* t
);
7912 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7915 else if (SCM_FRACTIONP (x
))
7916 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7917 SCM_FRACTION_NUMERATOR (x
));
7919 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7922 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7924 scm_t_inum xx
= SCM_I_INUM (x
);
7925 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7927 scm_t_inum yy
= SCM_I_INUM (y
);
7930 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7931 scm_num_overflow (s_divide
);
7933 return scm_from_double ((double) xx
/ (double) yy
);
7936 else if (xx
% yy
!= 0)
7939 return scm_from_double ((double) xx
/ (double) yy
);
7940 else return scm_i_make_ratio (x
, y
);
7944 scm_t_inum z
= xx
/ yy
;
7945 if (SCM_FIXABLE (z
))
7946 return SCM_I_MAKINUM (z
);
7948 return scm_i_inum2big (z
);
7951 else if (SCM_BIGP (y
))
7954 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7955 else return scm_i_make_ratio (x
, y
);
7957 else if (SCM_REALP (y
))
7959 double yy
= SCM_REAL_VALUE (y
);
7960 #ifndef ALLOW_DIVIDE_BY_ZERO
7962 scm_num_overflow (s_divide
);
7965 return scm_from_double ((double) xx
/ yy
);
7967 else if (SCM_COMPLEXP (y
))
7970 complex_div
: /* y _must_ be a complex number */
7972 double r
= SCM_COMPLEX_REAL (y
);
7973 double i
= SCM_COMPLEX_IMAG (y
);
7974 if (fabs(r
) <= fabs(i
))
7977 double d
= i
* (1.0 + t
* t
);
7978 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7983 double d
= r
* (1.0 + t
* t
);
7984 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7988 else if (SCM_FRACTIONP (y
))
7989 /* a / b/c = ac / b */
7990 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7991 SCM_FRACTION_NUMERATOR (y
));
7993 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7995 else if (SCM_BIGP (x
))
7997 if (SCM_I_INUMP (y
))
7999 scm_t_inum yy
= SCM_I_INUM (y
);
8002 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8003 scm_num_overflow (s_divide
);
8005 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8006 scm_remember_upto_here_1 (x
);
8007 return (sgn
== 0) ? scm_nan () : scm_inf ();
8014 /* FIXME: HMM, what are the relative performance issues here?
8015 We need to test. Is it faster on average to test
8016 divisible_p, then perform whichever operation, or is it
8017 faster to perform the integer div opportunistically and
8018 switch to real if there's a remainder? For now we take the
8019 middle ground: test, then if divisible, use the faster div
8022 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8023 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8027 SCM result
= scm_i_mkbig ();
8028 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8029 scm_remember_upto_here_1 (x
);
8031 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8032 return scm_i_normbig (result
);
8037 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
8038 else return scm_i_make_ratio (x
, y
);
8042 else if (SCM_BIGP (y
))
8047 /* It's easily possible for the ratio x/y to fit a double
8048 but one or both x and y be too big to fit a double,
8049 hence the use of mpq_get_d rather than converting and
8052 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8053 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8054 return scm_from_double (mpq_get_d (q
));
8058 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8062 SCM result
= scm_i_mkbig ();
8063 mpz_divexact (SCM_I_BIG_MPZ (result
),
8066 scm_remember_upto_here_2 (x
, y
);
8067 return scm_i_normbig (result
);
8070 return scm_i_make_ratio (x
, y
);
8073 else if (SCM_REALP (y
))
8075 double yy
= SCM_REAL_VALUE (y
);
8076 #ifndef ALLOW_DIVIDE_BY_ZERO
8078 scm_num_overflow (s_divide
);
8081 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8083 else if (SCM_COMPLEXP (y
))
8085 a
= scm_i_big2dbl (x
);
8088 else if (SCM_FRACTIONP (y
))
8089 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8090 SCM_FRACTION_NUMERATOR (y
));
8092 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8094 else if (SCM_REALP (x
))
8096 double rx
= SCM_REAL_VALUE (x
);
8097 if (SCM_I_INUMP (y
))
8099 scm_t_inum yy
= SCM_I_INUM (y
);
8100 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8102 scm_num_overflow (s_divide
);
8105 return scm_from_double (rx
/ (double) yy
);
8107 else if (SCM_BIGP (y
))
8109 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8110 scm_remember_upto_here_1 (y
);
8111 return scm_from_double (rx
/ dby
);
8113 else if (SCM_REALP (y
))
8115 double yy
= SCM_REAL_VALUE (y
);
8116 #ifndef ALLOW_DIVIDE_BY_ZERO
8118 scm_num_overflow (s_divide
);
8121 return scm_from_double (rx
/ yy
);
8123 else if (SCM_COMPLEXP (y
))
8128 else if (SCM_FRACTIONP (y
))
8129 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8131 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8133 else if (SCM_COMPLEXP (x
))
8135 double rx
= SCM_COMPLEX_REAL (x
);
8136 double ix
= SCM_COMPLEX_IMAG (x
);
8137 if (SCM_I_INUMP (y
))
8139 scm_t_inum yy
= SCM_I_INUM (y
);
8140 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8142 scm_num_overflow (s_divide
);
8147 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8150 else if (SCM_BIGP (y
))
8152 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8153 scm_remember_upto_here_1 (y
);
8154 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8156 else if (SCM_REALP (y
))
8158 double yy
= SCM_REAL_VALUE (y
);
8159 #ifndef ALLOW_DIVIDE_BY_ZERO
8161 scm_num_overflow (s_divide
);
8164 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8166 else if (SCM_COMPLEXP (y
))
8168 double ry
= SCM_COMPLEX_REAL (y
);
8169 double iy
= SCM_COMPLEX_IMAG (y
);
8170 if (fabs(ry
) <= fabs(iy
))
8173 double d
= iy
* (1.0 + t
* t
);
8174 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8179 double d
= ry
* (1.0 + t
* t
);
8180 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8183 else if (SCM_FRACTIONP (y
))
8185 double yy
= scm_i_fraction2double (y
);
8186 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8189 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8191 else if (SCM_FRACTIONP (x
))
8193 if (SCM_I_INUMP (y
))
8195 scm_t_inum yy
= SCM_I_INUM (y
);
8196 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8198 scm_num_overflow (s_divide
);
8201 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8202 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8204 else if (SCM_BIGP (y
))
8206 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8207 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8209 else if (SCM_REALP (y
))
8211 double yy
= SCM_REAL_VALUE (y
);
8212 #ifndef ALLOW_DIVIDE_BY_ZERO
8214 scm_num_overflow (s_divide
);
8217 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8219 else if (SCM_COMPLEXP (y
))
8221 a
= scm_i_fraction2double (x
);
8224 else if (SCM_FRACTIONP (y
))
8225 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8226 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8228 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8231 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8235 scm_divide (SCM x
, SCM y
)
8237 return do_divide (x
, y
, 0);
8240 static SCM
scm_divide2real (SCM x
, SCM y
)
8242 return do_divide (x
, y
, 1);
8248 scm_c_truncate (double x
)
8253 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8254 half-way case (ie. when x is an integer plus 0.5) going upwards.
8255 Then half-way cases are identified and adjusted down if the
8256 round-upwards didn't give the desired even integer.
8258 "plus_half == result" identifies a half-way case. If plus_half, which is
8259 x + 0.5, is an integer then x must be an integer plus 0.5.
8261 An odd "result" value is identified with result/2 != floor(result/2).
8262 This is done with plus_half, since that value is ready for use sooner in
8263 a pipelined cpu, and we're already requiring plus_half == result.
8265 Note however that we need to be careful when x is big and already an
8266 integer. In that case "x+0.5" may round to an adjacent integer, causing
8267 us to return such a value, incorrectly. For instance if the hardware is
8268 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8269 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8270 returned. Or if the hardware is in round-upwards mode, then other bigger
8271 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8272 representable value, 2^128+2^76 (or whatever), again incorrect.
8274 These bad roundings of x+0.5 are avoided by testing at the start whether
8275 x is already an integer. If it is then clearly that's the desired result
8276 already. And if it's not then the exponent must be small enough to allow
8277 an 0.5 to be represented, and hence added without a bad rounding. */
8280 scm_c_round (double x
)
8282 double plus_half
, result
;
8287 plus_half
= x
+ 0.5;
8288 result
= floor (plus_half
);
8289 /* Adjust so that the rounding is towards even. */
8290 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8295 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8297 "Round the number @var{x} towards zero.")
8298 #define FUNC_NAME s_scm_truncate_number
8300 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8302 else if (SCM_REALP (x
))
8303 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8304 else if (SCM_FRACTIONP (x
))
8305 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8306 SCM_FRACTION_DENOMINATOR (x
));
8308 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8309 s_scm_truncate_number
);
8313 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8315 "Round the number @var{x} towards the nearest integer. "
8316 "When it is exactly halfway between two integers, "
8317 "round towards the even one.")
8318 #define FUNC_NAME s_scm_round_number
8320 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8322 else if (SCM_REALP (x
))
8323 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8324 else if (SCM_FRACTIONP (x
))
8325 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8326 SCM_FRACTION_DENOMINATOR (x
));
8328 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8329 s_scm_round_number
);
8333 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8335 "Round the number @var{x} towards minus infinity.")
8336 #define FUNC_NAME s_scm_floor
8338 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8340 else if (SCM_REALP (x
))
8341 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8342 else if (SCM_FRACTIONP (x
))
8343 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8344 SCM_FRACTION_DENOMINATOR (x
));
8346 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8350 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8352 "Round the number @var{x} towards infinity.")
8353 #define FUNC_NAME s_scm_ceiling
8355 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8357 else if (SCM_REALP (x
))
8358 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8359 else if (SCM_FRACTIONP (x
))
8360 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8361 SCM_FRACTION_DENOMINATOR (x
));
8363 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8367 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8369 "Return @var{x} raised to the power of @var{y}.")
8370 #define FUNC_NAME s_scm_expt
8372 if (scm_is_integer (y
))
8374 if (scm_is_true (scm_exact_p (y
)))
8375 return scm_integer_expt (x
, y
);
8378 /* Here we handle the case where the exponent is an inexact
8379 integer. We make the exponent exact in order to use
8380 scm_integer_expt, and thus avoid the spurious imaginary
8381 parts that may result from round-off errors in the general
8382 e^(y log x) method below (for example when squaring a large
8383 negative number). In this case, we must return an inexact
8384 result for correctness. We also make the base inexact so
8385 that scm_integer_expt will use fast inexact arithmetic
8386 internally. Note that making the base inexact is not
8387 sufficient to guarantee an inexact result, because
8388 scm_integer_expt will return an exact 1 when the exponent
8389 is 0, even if the base is inexact. */
8390 return scm_exact_to_inexact
8391 (scm_integer_expt (scm_exact_to_inexact (x
),
8392 scm_inexact_to_exact (y
)));
8395 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8397 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8399 else if (scm_is_complex (x
) && scm_is_complex (y
))
8400 return scm_exp (scm_product (scm_log (x
), y
));
8401 else if (scm_is_complex (x
))
8402 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8404 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8408 /* sin/cos/tan/asin/acos/atan
8409 sinh/cosh/tanh/asinh/acosh/atanh
8410 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8411 Written by Jerry D. Hedden, (C) FSF.
8412 See the file `COPYING' for terms applying to this program. */
8414 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8416 "Compute the sine of @var{z}.")
8417 #define FUNC_NAME s_scm_sin
8419 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8420 return z
; /* sin(exact0) = exact0 */
8421 else if (scm_is_real (z
))
8422 return scm_from_double (sin (scm_to_double (z
)));
8423 else if (SCM_COMPLEXP (z
))
8425 x
= SCM_COMPLEX_REAL (z
);
8426 y
= SCM_COMPLEX_IMAG (z
);
8427 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8428 cos (x
) * sinh (y
));
8431 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8435 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8437 "Compute the cosine of @var{z}.")
8438 #define FUNC_NAME s_scm_cos
8440 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8441 return SCM_INUM1
; /* cos(exact0) = exact1 */
8442 else if (scm_is_real (z
))
8443 return scm_from_double (cos (scm_to_double (z
)));
8444 else if (SCM_COMPLEXP (z
))
8446 x
= SCM_COMPLEX_REAL (z
);
8447 y
= SCM_COMPLEX_IMAG (z
);
8448 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8449 -sin (x
) * sinh (y
));
8452 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8456 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8458 "Compute the tangent of @var{z}.")
8459 #define FUNC_NAME s_scm_tan
8461 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8462 return z
; /* tan(exact0) = exact0 */
8463 else if (scm_is_real (z
))
8464 return scm_from_double (tan (scm_to_double (z
)));
8465 else if (SCM_COMPLEXP (z
))
8467 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8468 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8469 w
= cos (x
) + cosh (y
);
8470 #ifndef ALLOW_DIVIDE_BY_ZERO
8472 scm_num_overflow (s_scm_tan
);
8474 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8477 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8481 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8483 "Compute the hyperbolic sine of @var{z}.")
8484 #define FUNC_NAME s_scm_sinh
8486 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8487 return z
; /* sinh(exact0) = exact0 */
8488 else if (scm_is_real (z
))
8489 return scm_from_double (sinh (scm_to_double (z
)));
8490 else if (SCM_COMPLEXP (z
))
8492 x
= SCM_COMPLEX_REAL (z
);
8493 y
= SCM_COMPLEX_IMAG (z
);
8494 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8495 cosh (x
) * sin (y
));
8498 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8502 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8504 "Compute the hyperbolic cosine of @var{z}.")
8505 #define FUNC_NAME s_scm_cosh
8507 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8508 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8509 else if (scm_is_real (z
))
8510 return scm_from_double (cosh (scm_to_double (z
)));
8511 else if (SCM_COMPLEXP (z
))
8513 x
= SCM_COMPLEX_REAL (z
);
8514 y
= SCM_COMPLEX_IMAG (z
);
8515 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8516 sinh (x
) * sin (y
));
8519 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8523 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8525 "Compute the hyperbolic tangent of @var{z}.")
8526 #define FUNC_NAME s_scm_tanh
8528 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8529 return z
; /* tanh(exact0) = exact0 */
8530 else if (scm_is_real (z
))
8531 return scm_from_double (tanh (scm_to_double (z
)));
8532 else if (SCM_COMPLEXP (z
))
8534 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8535 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8536 w
= cosh (x
) + cos (y
);
8537 #ifndef ALLOW_DIVIDE_BY_ZERO
8539 scm_num_overflow (s_scm_tanh
);
8541 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8544 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8548 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8550 "Compute the arc sine of @var{z}.")
8551 #define FUNC_NAME s_scm_asin
8553 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8554 return z
; /* asin(exact0) = exact0 */
8555 else if (scm_is_real (z
))
8557 double w
= scm_to_double (z
);
8558 if (w
>= -1.0 && w
<= 1.0)
8559 return scm_from_double (asin (w
));
8561 return scm_product (scm_c_make_rectangular (0, -1),
8562 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8564 else if (SCM_COMPLEXP (z
))
8566 x
= SCM_COMPLEX_REAL (z
);
8567 y
= SCM_COMPLEX_IMAG (z
);
8568 return scm_product (scm_c_make_rectangular (0, -1),
8569 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8572 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8576 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8578 "Compute the arc cosine of @var{z}.")
8579 #define FUNC_NAME s_scm_acos
8581 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8582 return SCM_INUM0
; /* acos(exact1) = exact0 */
8583 else if (scm_is_real (z
))
8585 double w
= scm_to_double (z
);
8586 if (w
>= -1.0 && w
<= 1.0)
8587 return scm_from_double (acos (w
));
8589 return scm_sum (scm_from_double (acos (0.0)),
8590 scm_product (scm_c_make_rectangular (0, 1),
8591 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8593 else if (SCM_COMPLEXP (z
))
8595 x
= SCM_COMPLEX_REAL (z
);
8596 y
= SCM_COMPLEX_IMAG (z
);
8597 return scm_sum (scm_from_double (acos (0.0)),
8598 scm_product (scm_c_make_rectangular (0, 1),
8599 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8602 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8606 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8608 "With one argument, compute the arc tangent of @var{z}.\n"
8609 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8610 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8611 #define FUNC_NAME s_scm_atan
8615 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8616 return z
; /* atan(exact0) = exact0 */
8617 else if (scm_is_real (z
))
8618 return scm_from_double (atan (scm_to_double (z
)));
8619 else if (SCM_COMPLEXP (z
))
8622 v
= SCM_COMPLEX_REAL (z
);
8623 w
= SCM_COMPLEX_IMAG (z
);
8624 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8625 scm_c_make_rectangular (v
, w
+ 1.0))),
8626 scm_c_make_rectangular (0, 2));
8629 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8631 else if (scm_is_real (z
))
8633 if (scm_is_real (y
))
8634 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8636 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8639 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8643 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8645 "Compute the inverse hyperbolic sine of @var{z}.")
8646 #define FUNC_NAME s_scm_sys_asinh
8648 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8649 return z
; /* asinh(exact0) = exact0 */
8650 else if (scm_is_real (z
))
8651 return scm_from_double (asinh (scm_to_double (z
)));
8652 else if (scm_is_number (z
))
8653 return scm_log (scm_sum (z
,
8654 scm_sqrt (scm_sum (scm_product (z
, z
),
8657 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8661 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8663 "Compute the inverse hyperbolic cosine of @var{z}.")
8664 #define FUNC_NAME s_scm_sys_acosh
8666 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8667 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8668 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8669 return scm_from_double (acosh (scm_to_double (z
)));
8670 else if (scm_is_number (z
))
8671 return scm_log (scm_sum (z
,
8672 scm_sqrt (scm_difference (scm_product (z
, z
),
8675 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8679 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8681 "Compute the inverse hyperbolic tangent of @var{z}.")
8682 #define FUNC_NAME s_scm_sys_atanh
8684 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8685 return z
; /* atanh(exact0) = exact0 */
8686 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8687 return scm_from_double (atanh (scm_to_double (z
)));
8688 else if (scm_is_number (z
))
8689 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8690 scm_difference (SCM_INUM1
, z
))),
8693 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8698 scm_c_make_rectangular (double re
, double im
)
8702 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8704 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8705 SCM_COMPLEX_REAL (z
) = re
;
8706 SCM_COMPLEX_IMAG (z
) = im
;
8710 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8711 (SCM real_part
, SCM imaginary_part
),
8712 "Return a complex number constructed of the given @var{real_part} "
8713 "and @var{imaginary_part} parts.")
8714 #define FUNC_NAME s_scm_make_rectangular
8716 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8717 SCM_ARG1
, FUNC_NAME
, "real");
8718 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8719 SCM_ARG2
, FUNC_NAME
, "real");
8721 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8722 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8725 return scm_c_make_rectangular (scm_to_double (real_part
),
8726 scm_to_double (imaginary_part
));
8731 scm_c_make_polar (double mag
, double ang
)
8735 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8736 use it on Glibc-based systems that have it (it's a GNU extension). See
8737 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8739 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8740 sincos (ang
, &s
, &c
);
8746 /* If s and c are NaNs, this indicates that the angle is a NaN,
8747 infinite, or perhaps simply too large to determine its value
8748 mod 2*pi. However, we know something that the floating-point
8749 implementation doesn't know: We know that s and c are finite.
8750 Therefore, if the magnitude is zero, return a complex zero.
8752 The reason we check for the NaNs instead of using this case
8753 whenever mag == 0.0 is because when the angle is known, we'd
8754 like to return the correct kind of non-real complex zero:
8755 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8756 on which quadrant the angle is in.
8758 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8759 return scm_c_make_rectangular (0.0, 0.0);
8761 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8764 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8766 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8767 #define FUNC_NAME s_scm_make_polar
8769 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8770 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8772 /* If mag is exact0, return exact0 */
8773 if (scm_is_eq (mag
, SCM_INUM0
))
8775 /* Return a real if ang is exact0 */
8776 else if (scm_is_eq (ang
, SCM_INUM0
))
8779 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8784 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8786 "Return the real part of the number @var{z}.")
8787 #define FUNC_NAME s_scm_real_part
8789 if (SCM_COMPLEXP (z
))
8790 return scm_from_double (SCM_COMPLEX_REAL (z
));
8791 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8794 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8799 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8801 "Return the imaginary part of the number @var{z}.")
8802 #define FUNC_NAME s_scm_imag_part
8804 if (SCM_COMPLEXP (z
))
8805 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8806 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8809 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8813 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8815 "Return the numerator of the number @var{z}.")
8816 #define FUNC_NAME s_scm_numerator
8818 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8820 else if (SCM_FRACTIONP (z
))
8821 return SCM_FRACTION_NUMERATOR (z
);
8822 else if (SCM_REALP (z
))
8823 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8825 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8830 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8832 "Return the denominator of the number @var{z}.")
8833 #define FUNC_NAME s_scm_denominator
8835 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8837 else if (SCM_FRACTIONP (z
))
8838 return SCM_FRACTION_DENOMINATOR (z
);
8839 else if (SCM_REALP (z
))
8840 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8842 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8847 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8849 "Return the magnitude of the number @var{z}. This is the same as\n"
8850 "@code{abs} for real arguments, but also allows complex numbers.")
8851 #define FUNC_NAME s_scm_magnitude
8853 if (SCM_I_INUMP (z
))
8855 scm_t_inum zz
= SCM_I_INUM (z
);
8858 else if (SCM_POSFIXABLE (-zz
))
8859 return SCM_I_MAKINUM (-zz
);
8861 return scm_i_inum2big (-zz
);
8863 else if (SCM_BIGP (z
))
8865 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8866 scm_remember_upto_here_1 (z
);
8868 return scm_i_clonebig (z
, 0);
8872 else if (SCM_REALP (z
))
8873 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8874 else if (SCM_COMPLEXP (z
))
8875 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8876 else if (SCM_FRACTIONP (z
))
8878 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8880 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8881 SCM_FRACTION_DENOMINATOR (z
));
8884 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8889 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8891 "Return the angle of the complex number @var{z}.")
8892 #define FUNC_NAME s_scm_angle
8894 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8895 flo0 to save allocating a new flonum with scm_from_double each time.
8896 But if atan2 follows the floating point rounding mode, then the value
8897 is not a constant. Maybe it'd be close enough though. */
8898 if (SCM_I_INUMP (z
))
8900 if (SCM_I_INUM (z
) >= 0)
8903 return scm_from_double (atan2 (0.0, -1.0));
8905 else if (SCM_BIGP (z
))
8907 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8908 scm_remember_upto_here_1 (z
);
8910 return scm_from_double (atan2 (0.0, -1.0));
8914 else if (SCM_REALP (z
))
8916 double x
= SCM_REAL_VALUE (z
);
8917 if (x
> 0.0 || double_is_non_negative_zero (x
))
8920 return scm_from_double (atan2 (0.0, -1.0));
8922 else if (SCM_COMPLEXP (z
))
8923 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8924 else if (SCM_FRACTIONP (z
))
8926 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8928 else return scm_from_double (atan2 (0.0, -1.0));
8931 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8936 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8938 "Convert the number @var{z} to its inexact representation.\n")
8939 #define FUNC_NAME s_scm_exact_to_inexact
8941 if (SCM_I_INUMP (z
))
8942 return scm_from_double ((double) SCM_I_INUM (z
));
8943 else if (SCM_BIGP (z
))
8944 return scm_from_double (scm_i_big2dbl (z
));
8945 else if (SCM_FRACTIONP (z
))
8946 return scm_from_double (scm_i_fraction2double (z
));
8947 else if (SCM_INEXACTP (z
))
8950 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
8955 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8957 "Return an exact number that is numerically closest to @var{z}.")
8958 #define FUNC_NAME s_scm_inexact_to_exact
8960 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8967 val
= SCM_REAL_VALUE (z
);
8968 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8969 val
= SCM_COMPLEX_REAL (z
);
8971 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
8973 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8974 SCM_OUT_OF_RANGE (1, z
);
8981 mpq_set_d (frac
, val
);
8982 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8983 scm_i_mpz2num (mpq_denref (frac
)));
8985 /* When scm_i_make_ratio throws, we leak the memory allocated
8995 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8997 "Returns the @emph{simplest} rational number differing\n"
8998 "from @var{x} by no more than @var{eps}.\n"
9000 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9001 "exact result when both its arguments are exact. Thus, you might need\n"
9002 "to use @code{inexact->exact} on the arguments.\n"
9005 "(rationalize (inexact->exact 1.2) 1/100)\n"
9008 #define FUNC_NAME s_scm_rationalize
9010 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9011 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9012 eps
= scm_abs (eps
);
9013 if (scm_is_false (scm_positive_p (eps
)))
9015 /* eps is either zero or a NaN */
9016 if (scm_is_true (scm_nan_p (eps
)))
9018 else if (SCM_INEXACTP (eps
))
9019 return scm_exact_to_inexact (x
);
9023 else if (scm_is_false (scm_finite_p (eps
)))
9025 if (scm_is_true (scm_finite_p (x
)))
9030 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9032 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9033 scm_ceiling (scm_difference (x
, eps
)))))
9035 /* There's an integer within range; we want the one closest to zero */
9036 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9038 /* zero is within range */
9039 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9044 else if (scm_is_true (scm_positive_p (x
)))
9045 return scm_ceiling (scm_difference (x
, eps
));
9047 return scm_floor (scm_sum (x
, eps
));
9051 /* Use continued fractions to find closest ratio. All
9052 arithmetic is done with exact numbers.
9055 SCM ex
= scm_inexact_to_exact (x
);
9056 SCM int_part
= scm_floor (ex
);
9058 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9059 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9063 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9064 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9066 /* We stop after a million iterations just to be absolutely sure
9067 that we don't go into an infinite loop. The process normally
9068 converges after less than a dozen iterations.
9071 while (++i
< 1000000)
9073 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9074 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9075 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9077 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9078 eps
))) /* abs(x-a/b) <= eps */
9080 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9081 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9082 return scm_exact_to_inexact (res
);
9086 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9088 tt
= scm_floor (rx
); /* tt = floor (rx) */
9094 scm_num_overflow (s_scm_rationalize
);
9099 /* conversion functions */
9102 scm_is_integer (SCM val
)
9104 return scm_is_true (scm_integer_p (val
));
9108 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9110 if (SCM_I_INUMP (val
))
9112 scm_t_signed_bits n
= SCM_I_INUM (val
);
9113 return n
>= min
&& n
<= max
;
9115 else if (SCM_BIGP (val
))
9117 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9119 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9121 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9123 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9124 return n
>= min
&& n
<= max
;
9134 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9135 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9138 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9139 SCM_I_BIG_MPZ (val
));
9141 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9153 return n
>= min
&& n
<= max
;
9161 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9163 if (SCM_I_INUMP (val
))
9165 scm_t_signed_bits n
= SCM_I_INUM (val
);
9166 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9168 else if (SCM_BIGP (val
))
9170 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9172 else if (max
<= ULONG_MAX
)
9174 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9176 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9177 return n
>= min
&& n
<= max
;
9187 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9190 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9191 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9194 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9195 SCM_I_BIG_MPZ (val
));
9197 return n
>= min
&& n
<= max
;
9205 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9207 scm_error (scm_out_of_range_key
,
9209 "Value out of range ~S to ~S: ~S",
9210 scm_list_3 (min
, max
, bad_val
),
9211 scm_list_1 (bad_val
));
9214 #define TYPE scm_t_intmax
9215 #define TYPE_MIN min
9216 #define TYPE_MAX max
9217 #define SIZEOF_TYPE 0
9218 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9219 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9220 #include "libguile/conv-integer.i.c"
9222 #define TYPE scm_t_uintmax
9223 #define TYPE_MIN min
9224 #define TYPE_MAX max
9225 #define SIZEOF_TYPE 0
9226 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9227 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9228 #include "libguile/conv-uinteger.i.c"
9230 #define TYPE scm_t_int8
9231 #define TYPE_MIN SCM_T_INT8_MIN
9232 #define TYPE_MAX SCM_T_INT8_MAX
9233 #define SIZEOF_TYPE 1
9234 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9235 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9236 #include "libguile/conv-integer.i.c"
9238 #define TYPE scm_t_uint8
9240 #define TYPE_MAX SCM_T_UINT8_MAX
9241 #define SIZEOF_TYPE 1
9242 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9243 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9244 #include "libguile/conv-uinteger.i.c"
9246 #define TYPE scm_t_int16
9247 #define TYPE_MIN SCM_T_INT16_MIN
9248 #define TYPE_MAX SCM_T_INT16_MAX
9249 #define SIZEOF_TYPE 2
9250 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9251 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9252 #include "libguile/conv-integer.i.c"
9254 #define TYPE scm_t_uint16
9256 #define TYPE_MAX SCM_T_UINT16_MAX
9257 #define SIZEOF_TYPE 2
9258 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9259 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9260 #include "libguile/conv-uinteger.i.c"
9262 #define TYPE scm_t_int32
9263 #define TYPE_MIN SCM_T_INT32_MIN
9264 #define TYPE_MAX SCM_T_INT32_MAX
9265 #define SIZEOF_TYPE 4
9266 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9267 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9268 #include "libguile/conv-integer.i.c"
9270 #define TYPE scm_t_uint32
9272 #define TYPE_MAX SCM_T_UINT32_MAX
9273 #define SIZEOF_TYPE 4
9274 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9275 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9276 #include "libguile/conv-uinteger.i.c"
9278 #define TYPE scm_t_wchar
9279 #define TYPE_MIN (scm_t_int32)-1
9280 #define TYPE_MAX (scm_t_int32)0x10ffff
9281 #define SIZEOF_TYPE 4
9282 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9283 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9284 #include "libguile/conv-integer.i.c"
9286 #define TYPE scm_t_int64
9287 #define TYPE_MIN SCM_T_INT64_MIN
9288 #define TYPE_MAX SCM_T_INT64_MAX
9289 #define SIZEOF_TYPE 8
9290 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9291 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9292 #include "libguile/conv-integer.i.c"
9294 #define TYPE scm_t_uint64
9296 #define TYPE_MAX SCM_T_UINT64_MAX
9297 #define SIZEOF_TYPE 8
9298 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9299 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9300 #include "libguile/conv-uinteger.i.c"
9303 scm_to_mpz (SCM val
, mpz_t rop
)
9305 if (SCM_I_INUMP (val
))
9306 mpz_set_si (rop
, SCM_I_INUM (val
));
9307 else if (SCM_BIGP (val
))
9308 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9310 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9314 scm_from_mpz (mpz_t val
)
9316 return scm_i_mpz2num (val
);
9320 scm_is_real (SCM val
)
9322 return scm_is_true (scm_real_p (val
));
9326 scm_is_rational (SCM val
)
9328 return scm_is_true (scm_rational_p (val
));
9332 scm_to_double (SCM val
)
9334 if (SCM_I_INUMP (val
))
9335 return SCM_I_INUM (val
);
9336 else if (SCM_BIGP (val
))
9337 return scm_i_big2dbl (val
);
9338 else if (SCM_FRACTIONP (val
))
9339 return scm_i_fraction2double (val
);
9340 else if (SCM_REALP (val
))
9341 return SCM_REAL_VALUE (val
);
9343 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9347 scm_from_double (double val
)
9351 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9353 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9354 SCM_REAL_VALUE (z
) = val
;
9359 #if SCM_ENABLE_DEPRECATED == 1
9362 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9364 scm_c_issue_deprecation_warning
9365 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9369 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9373 scm_out_of_range (NULL
, num
);
9376 return scm_to_double (num
);
9380 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9382 scm_c_issue_deprecation_warning
9383 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9387 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9391 scm_out_of_range (NULL
, num
);
9394 return scm_to_double (num
);
9400 scm_is_complex (SCM val
)
9402 return scm_is_true (scm_complex_p (val
));
9406 scm_c_real_part (SCM z
)
9408 if (SCM_COMPLEXP (z
))
9409 return SCM_COMPLEX_REAL (z
);
9412 /* Use the scm_real_part to get proper error checking and
9415 return scm_to_double (scm_real_part (z
));
9420 scm_c_imag_part (SCM z
)
9422 if (SCM_COMPLEXP (z
))
9423 return SCM_COMPLEX_IMAG (z
);
9426 /* Use the scm_imag_part to get proper error checking and
9427 dispatching. The result will almost always be 0.0, but not
9430 return scm_to_double (scm_imag_part (z
));
9435 scm_c_magnitude (SCM z
)
9437 return scm_to_double (scm_magnitude (z
));
9443 return scm_to_double (scm_angle (z
));
9447 scm_is_number (SCM z
)
9449 return scm_is_true (scm_number_p (z
));
9453 /* Returns log(x * 2^shift) */
9455 log_of_shifted_double (double x
, long shift
)
9457 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9459 if (x
> 0.0 || double_is_non_negative_zero (x
))
9460 return scm_from_double (ans
);
9462 return scm_c_make_rectangular (ans
, M_PI
);
9465 /* Returns log(n), for exact integer n of integer-length size */
9467 log_of_exact_integer_with_size (SCM n
, long size
)
9469 long shift
= size
- 2 * scm_dblprec
[0];
9472 return log_of_shifted_double
9473 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9476 return log_of_shifted_double (scm_to_double (n
), 0);
9479 /* Returns log(n), for exact integer n */
9481 log_of_exact_integer (SCM n
)
9483 return log_of_exact_integer_with_size
9484 (n
, scm_to_long (scm_integer_length (n
)));
9487 /* Returns log(n/d), for exact non-zero integers n and d */
9489 log_of_fraction (SCM n
, SCM d
)
9491 long n_size
= scm_to_long (scm_integer_length (n
));
9492 long d_size
= scm_to_long (scm_integer_length (d
));
9494 if (abs (n_size
- d_size
) > 1)
9495 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9496 log_of_exact_integer_with_size (d
, d_size
)));
9497 else if (scm_is_false (scm_negative_p (n
)))
9498 return scm_from_double
9499 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9501 return scm_c_make_rectangular
9502 (log1p (scm_to_double (scm_divide2real
9503 (scm_difference (scm_abs (n
), d
),
9509 /* In the following functions we dispatch to the real-arg funcs like log()
9510 when we know the arg is real, instead of just handing everything to
9511 clog() for instance. This is in case clog() doesn't optimize for a
9512 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9513 well use it to go straight to the applicable C func. */
9515 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9517 "Return the natural logarithm of @var{z}.")
9518 #define FUNC_NAME s_scm_log
9520 if (SCM_COMPLEXP (z
))
9522 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9523 && defined (SCM_COMPLEX_VALUE)
9524 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9526 double re
= SCM_COMPLEX_REAL (z
);
9527 double im
= SCM_COMPLEX_IMAG (z
);
9528 return scm_c_make_rectangular (log (hypot (re
, im
)),
9532 else if (SCM_REALP (z
))
9533 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9534 else if (SCM_I_INUMP (z
))
9536 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9537 if (scm_is_eq (z
, SCM_INUM0
))
9538 scm_num_overflow (s_scm_log
);
9540 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9542 else if (SCM_BIGP (z
))
9543 return log_of_exact_integer (z
);
9544 else if (SCM_FRACTIONP (z
))
9545 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9546 SCM_FRACTION_DENOMINATOR (z
));
9548 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9553 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9555 "Return the base 10 logarithm of @var{z}.")
9556 #define FUNC_NAME s_scm_log10
9558 if (SCM_COMPLEXP (z
))
9560 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9561 clog() and a multiply by M_LOG10E, rather than the fallback
9562 log10+hypot+atan2.) */
9563 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9564 && defined SCM_COMPLEX_VALUE
9565 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9567 double re
= SCM_COMPLEX_REAL (z
);
9568 double im
= SCM_COMPLEX_IMAG (z
);
9569 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9570 M_LOG10E
* atan2 (im
, re
));
9573 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9575 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9576 if (scm_is_eq (z
, SCM_INUM0
))
9577 scm_num_overflow (s_scm_log10
);
9580 double re
= scm_to_double (z
);
9581 double l
= log10 (fabs (re
));
9582 if (re
> 0.0 || double_is_non_negative_zero (re
))
9583 return scm_from_double (l
);
9585 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9588 else if (SCM_BIGP (z
))
9589 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9590 else if (SCM_FRACTIONP (z
))
9591 return scm_product (flo_log10e
,
9592 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9593 SCM_FRACTION_DENOMINATOR (z
)));
9595 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9600 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9602 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9603 "base of natural logarithms (2.71828@dots{}).")
9604 #define FUNC_NAME s_scm_exp
9606 if (SCM_COMPLEXP (z
))
9608 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9609 && defined (SCM_COMPLEX_VALUE)
9610 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9612 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9613 SCM_COMPLEX_IMAG (z
));
9616 else if (SCM_NUMBERP (z
))
9618 /* When z is a negative bignum the conversion to double overflows,
9619 giving -infinity, but that's ok, the exp is still 0.0. */
9620 return scm_from_double (exp (scm_to_double (z
)));
9623 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9628 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9630 "Return two exact non-negative integers @var{s} and @var{r}\n"
9631 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9632 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9633 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9636 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9638 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9642 scm_exact_integer_sqrt (k
, &s
, &r
);
9643 return scm_values (scm_list_2 (s
, r
));
9648 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9650 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9652 scm_t_inum kk
= SCM_I_INUM (k
);
9656 if (SCM_LIKELY (kk
> 0))
9661 uu
= (ss
+ kk
/ss
) / 2;
9663 *sp
= SCM_I_MAKINUM (ss
);
9664 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9666 else if (SCM_LIKELY (kk
== 0))
9667 *sp
= *rp
= SCM_INUM0
;
9669 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9670 "exact non-negative integer");
9672 else if (SCM_LIKELY (SCM_BIGP (k
)))
9676 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9677 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9678 "exact non-negative integer");
9681 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9682 scm_remember_upto_here_1 (k
);
9683 *sp
= scm_i_normbig (s
);
9684 *rp
= scm_i_normbig (r
);
9687 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9688 "exact non-negative integer");
9692 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9694 "Return the square root of @var{z}. Of the two possible roots\n"
9695 "(positive and negative), the one with positive real part\n"
9696 "is returned, or if that's zero then a positive imaginary part.\n"
9700 "(sqrt 9.0) @result{} 3.0\n"
9701 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9702 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9703 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9705 #define FUNC_NAME s_scm_sqrt
9707 if (SCM_COMPLEXP (z
))
9709 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9710 && defined SCM_COMPLEX_VALUE
9711 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9713 double re
= SCM_COMPLEX_REAL (z
);
9714 double im
= SCM_COMPLEX_IMAG (z
);
9715 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9716 0.5 * atan2 (im
, re
));
9719 else if (SCM_NUMBERP (z
))
9721 double xx
= scm_to_double (z
);
9723 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9725 return scm_from_double (sqrt (xx
));
9728 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9739 if (scm_install_gmp_memory_functions
)
9740 mp_set_memory_functions (custom_gmp_malloc
,
9744 mpz_init_set_si (z_negative_one
, -1);
9746 /* It may be possible to tune the performance of some algorithms by using
9747 * the following constants to avoid the creation of bignums. Please, before
9748 * using these values, remember the two rules of program optimization:
9749 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9750 scm_c_define ("most-positive-fixnum",
9751 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9752 scm_c_define ("most-negative-fixnum",
9753 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9755 scm_add_feature ("complex");
9756 scm_add_feature ("inexact");
9757 flo0
= scm_from_double (0.0);
9758 flo_log10e
= scm_from_double (M_LOG10E
);
9760 /* determine floating point precision */
9761 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9763 init_dblprec(&scm_dblprec
[i
-2],i
);
9764 init_fx_radix(fx_per_radix
[i
-2],i
);
9767 /* hard code precision for base 10 if the preprocessor tells us to... */
9768 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9771 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9772 #include "libguile/numbers.x"