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
)
3893 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3895 if (SCM_I_INUMP (x
))
3897 if (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
;
3912 /* Determine a common factor 2^k */
3913 while (!(1 & (u
| v
)))
3919 /* Now, any factor 2^n can be eliminated */
3939 return (SCM_POSFIXABLE (result
)
3940 ? SCM_I_MAKINUM (result
)
3941 : scm_i_inum2big (result
));
3943 else if (SCM_BIGP (y
))
3949 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3951 else if (SCM_BIGP (x
))
3953 if (SCM_I_INUMP (y
))
3958 yy
= SCM_I_INUM (y
);
3963 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3964 scm_remember_upto_here_1 (x
);
3965 return (SCM_POSFIXABLE (result
)
3966 ? SCM_I_MAKINUM (result
)
3967 : scm_from_unsigned_integer (result
));
3969 else if (SCM_BIGP (y
))
3971 SCM result
= scm_i_mkbig ();
3972 mpz_gcd (SCM_I_BIG_MPZ (result
),
3975 scm_remember_upto_here_2 (x
, y
);
3976 return scm_i_normbig (result
);
3979 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3982 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3985 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3986 (SCM x
, SCM y
, SCM rest
),
3987 "Return the least common multiple of the arguments.\n"
3988 "If called without arguments, 1 is returned.")
3989 #define FUNC_NAME s_scm_i_lcm
3991 while (!scm_is_null (rest
))
3992 { x
= scm_lcm (x
, y
);
3994 rest
= scm_cdr (rest
);
3996 return scm_lcm (x
, y
);
4000 #define s_lcm s_scm_i_lcm
4001 #define g_lcm g_scm_i_lcm
4004 scm_lcm (SCM n1
, SCM n2
)
4006 if (SCM_UNBNDP (n2
))
4008 if (SCM_UNBNDP (n1
))
4009 return SCM_I_MAKINUM (1L);
4010 n2
= SCM_I_MAKINUM (1L);
4013 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
4014 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4015 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
4016 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
4018 if (SCM_I_INUMP (n1
))
4020 if (SCM_I_INUMP (n2
))
4022 SCM d
= scm_gcd (n1
, n2
);
4023 if (scm_is_eq (d
, SCM_INUM0
))
4026 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4030 /* inum n1, big n2 */
4033 SCM result
= scm_i_mkbig ();
4034 scm_t_inum nn1
= SCM_I_INUM (n1
);
4035 if (nn1
== 0) return SCM_INUM0
;
4036 if (nn1
< 0) nn1
= - nn1
;
4037 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4038 scm_remember_upto_here_1 (n2
);
4046 if (SCM_I_INUMP (n2
))
4053 SCM result
= scm_i_mkbig ();
4054 mpz_lcm(SCM_I_BIG_MPZ (result
),
4056 SCM_I_BIG_MPZ (n2
));
4057 scm_remember_upto_here_2(n1
, n2
);
4058 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4064 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4069 + + + x (map digit:logand X Y)
4070 + - + x (map digit:logand X (lognot (+ -1 Y)))
4071 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4072 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4077 + + + (map digit:logior X Y)
4078 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4079 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4080 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4085 + + + (map digit:logxor X Y)
4086 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4087 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4088 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4093 + + (any digit:logand X Y)
4094 + - (any digit:logand X (lognot (+ -1 Y)))
4095 - + (any digit:logand (lognot (+ -1 X)) Y)
4100 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4101 (SCM x
, SCM y
, SCM rest
),
4102 "Return the bitwise AND of the integer arguments.\n\n"
4104 "(logand) @result{} -1\n"
4105 "(logand 7) @result{} 7\n"
4106 "(logand #b111 #b011 #b001) @result{} 1\n"
4108 #define FUNC_NAME s_scm_i_logand
4110 while (!scm_is_null (rest
))
4111 { x
= scm_logand (x
, y
);
4113 rest
= scm_cdr (rest
);
4115 return scm_logand (x
, y
);
4119 #define s_scm_logand s_scm_i_logand
4121 SCM
scm_logand (SCM n1
, SCM n2
)
4122 #define FUNC_NAME s_scm_logand
4126 if (SCM_UNBNDP (n2
))
4128 if (SCM_UNBNDP (n1
))
4129 return SCM_I_MAKINUM (-1);
4130 else if (!SCM_NUMBERP (n1
))
4131 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4132 else if (SCM_NUMBERP (n1
))
4135 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4138 if (SCM_I_INUMP (n1
))
4140 nn1
= SCM_I_INUM (n1
);
4141 if (SCM_I_INUMP (n2
))
4143 scm_t_inum nn2
= SCM_I_INUM (n2
);
4144 return SCM_I_MAKINUM (nn1
& nn2
);
4146 else if SCM_BIGP (n2
)
4152 SCM result_z
= scm_i_mkbig ();
4154 mpz_init_set_si (nn1_z
, nn1
);
4155 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4156 scm_remember_upto_here_1 (n2
);
4158 return scm_i_normbig (result_z
);
4162 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4164 else if (SCM_BIGP (n1
))
4166 if (SCM_I_INUMP (n2
))
4169 nn1
= SCM_I_INUM (n1
);
4172 else if (SCM_BIGP (n2
))
4174 SCM result_z
= scm_i_mkbig ();
4175 mpz_and (SCM_I_BIG_MPZ (result_z
),
4177 SCM_I_BIG_MPZ (n2
));
4178 scm_remember_upto_here_2 (n1
, n2
);
4179 return scm_i_normbig (result_z
);
4182 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4185 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4190 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4191 (SCM x
, SCM y
, SCM rest
),
4192 "Return the bitwise OR of the integer arguments.\n\n"
4194 "(logior) @result{} 0\n"
4195 "(logior 7) @result{} 7\n"
4196 "(logior #b000 #b001 #b011) @result{} 3\n"
4198 #define FUNC_NAME s_scm_i_logior
4200 while (!scm_is_null (rest
))
4201 { x
= scm_logior (x
, y
);
4203 rest
= scm_cdr (rest
);
4205 return scm_logior (x
, y
);
4209 #define s_scm_logior s_scm_i_logior
4211 SCM
scm_logior (SCM n1
, SCM n2
)
4212 #define FUNC_NAME s_scm_logior
4216 if (SCM_UNBNDP (n2
))
4218 if (SCM_UNBNDP (n1
))
4220 else if (SCM_NUMBERP (n1
))
4223 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4226 if (SCM_I_INUMP (n1
))
4228 nn1
= SCM_I_INUM (n1
);
4229 if (SCM_I_INUMP (n2
))
4231 long nn2
= SCM_I_INUM (n2
);
4232 return SCM_I_MAKINUM (nn1
| nn2
);
4234 else if (SCM_BIGP (n2
))
4240 SCM result_z
= scm_i_mkbig ();
4242 mpz_init_set_si (nn1_z
, nn1
);
4243 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4244 scm_remember_upto_here_1 (n2
);
4246 return scm_i_normbig (result_z
);
4250 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4252 else if (SCM_BIGP (n1
))
4254 if (SCM_I_INUMP (n2
))
4257 nn1
= SCM_I_INUM (n1
);
4260 else if (SCM_BIGP (n2
))
4262 SCM result_z
= scm_i_mkbig ();
4263 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4265 SCM_I_BIG_MPZ (n2
));
4266 scm_remember_upto_here_2 (n1
, n2
);
4267 return scm_i_normbig (result_z
);
4270 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4273 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4278 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4279 (SCM x
, SCM y
, SCM rest
),
4280 "Return the bitwise XOR of the integer arguments. A bit is\n"
4281 "set in the result if it is set in an odd number of arguments.\n"
4283 "(logxor) @result{} 0\n"
4284 "(logxor 7) @result{} 7\n"
4285 "(logxor #b000 #b001 #b011) @result{} 2\n"
4286 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4288 #define FUNC_NAME s_scm_i_logxor
4290 while (!scm_is_null (rest
))
4291 { x
= scm_logxor (x
, y
);
4293 rest
= scm_cdr (rest
);
4295 return scm_logxor (x
, y
);
4299 #define s_scm_logxor s_scm_i_logxor
4301 SCM
scm_logxor (SCM n1
, SCM n2
)
4302 #define FUNC_NAME s_scm_logxor
4306 if (SCM_UNBNDP (n2
))
4308 if (SCM_UNBNDP (n1
))
4310 else if (SCM_NUMBERP (n1
))
4313 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4316 if (SCM_I_INUMP (n1
))
4318 nn1
= SCM_I_INUM (n1
);
4319 if (SCM_I_INUMP (n2
))
4321 scm_t_inum nn2
= SCM_I_INUM (n2
);
4322 return SCM_I_MAKINUM (nn1
^ nn2
);
4324 else if (SCM_BIGP (n2
))
4328 SCM result_z
= scm_i_mkbig ();
4330 mpz_init_set_si (nn1_z
, nn1
);
4331 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4332 scm_remember_upto_here_1 (n2
);
4334 return scm_i_normbig (result_z
);
4338 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4340 else if (SCM_BIGP (n1
))
4342 if (SCM_I_INUMP (n2
))
4345 nn1
= SCM_I_INUM (n1
);
4348 else if (SCM_BIGP (n2
))
4350 SCM result_z
= scm_i_mkbig ();
4351 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4353 SCM_I_BIG_MPZ (n2
));
4354 scm_remember_upto_here_2 (n1
, n2
);
4355 return scm_i_normbig (result_z
);
4358 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4361 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4366 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4368 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4369 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4370 "without actually calculating the @code{logand}, just testing\n"
4374 "(logtest #b0100 #b1011) @result{} #f\n"
4375 "(logtest #b0100 #b0111) @result{} #t\n"
4377 #define FUNC_NAME s_scm_logtest
4381 if (SCM_I_INUMP (j
))
4383 nj
= SCM_I_INUM (j
);
4384 if (SCM_I_INUMP (k
))
4386 scm_t_inum nk
= SCM_I_INUM (k
);
4387 return scm_from_bool (nj
& nk
);
4389 else if (SCM_BIGP (k
))
4397 mpz_init_set_si (nj_z
, nj
);
4398 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4399 scm_remember_upto_here_1 (k
);
4400 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4406 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4408 else if (SCM_BIGP (j
))
4410 if (SCM_I_INUMP (k
))
4413 nj
= SCM_I_INUM (j
);
4416 else if (SCM_BIGP (k
))
4420 mpz_init (result_z
);
4424 scm_remember_upto_here_2 (j
, k
);
4425 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4426 mpz_clear (result_z
);
4430 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4433 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4438 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4440 "Test whether bit number @var{index} in @var{j} is set.\n"
4441 "@var{index} starts from 0 for the least significant bit.\n"
4444 "(logbit? 0 #b1101) @result{} #t\n"
4445 "(logbit? 1 #b1101) @result{} #f\n"
4446 "(logbit? 2 #b1101) @result{} #t\n"
4447 "(logbit? 3 #b1101) @result{} #t\n"
4448 "(logbit? 4 #b1101) @result{} #f\n"
4450 #define FUNC_NAME s_scm_logbit_p
4452 unsigned long int iindex
;
4453 iindex
= scm_to_ulong (index
);
4455 if (SCM_I_INUMP (j
))
4457 /* bits above what's in an inum follow the sign bit */
4458 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4459 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4461 else if (SCM_BIGP (j
))
4463 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4464 scm_remember_upto_here_1 (j
);
4465 return scm_from_bool (val
);
4468 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4473 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4475 "Return the integer which is the ones-complement of the integer\n"
4479 "(number->string (lognot #b10000000) 2)\n"
4480 " @result{} \"-10000001\"\n"
4481 "(number->string (lognot #b0) 2)\n"
4482 " @result{} \"-1\"\n"
4484 #define FUNC_NAME s_scm_lognot
4486 if (SCM_I_INUMP (n
)) {
4487 /* No overflow here, just need to toggle all the bits making up the inum.
4488 Enhancement: No need to strip the tag and add it back, could just xor
4489 a block of 1 bits, if that worked with the various debug versions of
4491 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4493 } else if (SCM_BIGP (n
)) {
4494 SCM result
= scm_i_mkbig ();
4495 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4496 scm_remember_upto_here_1 (n
);
4500 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4505 /* returns 0 if IN is not an integer. OUT must already be
4508 coerce_to_big (SCM in
, mpz_t out
)
4511 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4512 else if (SCM_I_INUMP (in
))
4513 mpz_set_si (out
, SCM_I_INUM (in
));
4520 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4521 (SCM n
, SCM k
, SCM m
),
4522 "Return @var{n} raised to the integer exponent\n"
4523 "@var{k}, modulo @var{m}.\n"
4526 "(modulo-expt 2 3 5)\n"
4529 #define FUNC_NAME s_scm_modulo_expt
4535 /* There are two classes of error we might encounter --
4536 1) Math errors, which we'll report by calling scm_num_overflow,
4538 2) wrong-type errors, which of course we'll report by calling
4540 We don't report those errors immediately, however; instead we do
4541 some cleanup first. These variables tell us which error (if
4542 any) we should report after cleaning up.
4544 int report_overflow
= 0;
4546 int position_of_wrong_type
= 0;
4547 SCM value_of_wrong_type
= SCM_INUM0
;
4549 SCM result
= SCM_UNDEFINED
;
4555 if (scm_is_eq (m
, SCM_INUM0
))
4557 report_overflow
= 1;
4561 if (!coerce_to_big (n
, n_tmp
))
4563 value_of_wrong_type
= n
;
4564 position_of_wrong_type
= 1;
4568 if (!coerce_to_big (k
, k_tmp
))
4570 value_of_wrong_type
= k
;
4571 position_of_wrong_type
= 2;
4575 if (!coerce_to_big (m
, m_tmp
))
4577 value_of_wrong_type
= m
;
4578 position_of_wrong_type
= 3;
4582 /* if the exponent K is negative, and we simply call mpz_powm, we
4583 will get a divide-by-zero exception when an inverse 1/n mod m
4584 doesn't exist (or is not unique). Since exceptions are hard to
4585 handle, we'll attempt the inversion "by hand" -- that way, we get
4586 a simple failure code, which is easy to handle. */
4588 if (-1 == mpz_sgn (k_tmp
))
4590 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4592 report_overflow
= 1;
4595 mpz_neg (k_tmp
, k_tmp
);
4598 result
= scm_i_mkbig ();
4599 mpz_powm (SCM_I_BIG_MPZ (result
),
4604 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4605 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4612 if (report_overflow
)
4613 scm_num_overflow (FUNC_NAME
);
4615 if (position_of_wrong_type
)
4616 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4617 value_of_wrong_type
);
4619 return scm_i_normbig (result
);
4623 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4625 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4626 "exact integer, @var{n} can be any number.\n"
4628 "Negative @var{k} is supported, and results in\n"
4629 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4630 "@math{@var{n}^0} is 1, as usual, and that\n"
4631 "includes @math{0^0} is 1.\n"
4634 "(integer-expt 2 5) @result{} 32\n"
4635 "(integer-expt -3 3) @result{} -27\n"
4636 "(integer-expt 5 -3) @result{} 1/125\n"
4637 "(integer-expt 0 0) @result{} 1\n"
4639 #define FUNC_NAME s_scm_integer_expt
4642 SCM z_i2
= SCM_BOOL_F
;
4644 SCM acc
= SCM_I_MAKINUM (1L);
4646 /* Specifically refrain from checking the type of the first argument.
4647 This allows us to exponentiate any object that can be multiplied.
4648 If we must raise to a negative power, we must also be able to
4649 take its reciprocal. */
4650 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4651 SCM_WRONG_TYPE_ARG (2, k
);
4653 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4654 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4655 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4656 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4657 /* The next check is necessary only because R6RS specifies different
4658 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4659 we simply skip this case and move on. */
4660 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4662 /* k cannot be 0 at this point, because we
4663 have already checked for that case above */
4664 if (scm_is_true (scm_positive_p (k
)))
4666 else /* return NaN for (0 ^ k) for negative k per R6RS */
4670 if (SCM_I_INUMP (k
))
4671 i2
= SCM_I_INUM (k
);
4672 else if (SCM_BIGP (k
))
4674 z_i2
= scm_i_clonebig (k
, 1);
4675 scm_remember_upto_here_1 (k
);
4679 SCM_WRONG_TYPE_ARG (2, k
);
4683 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4685 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4686 n
= scm_divide (n
, SCM_UNDEFINED
);
4690 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4694 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4696 return scm_product (acc
, n
);
4698 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4699 acc
= scm_product (acc
, n
);
4700 n
= scm_product (n
, n
);
4701 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4709 n
= scm_divide (n
, SCM_UNDEFINED
);
4716 return scm_product (acc
, n
);
4718 acc
= scm_product (acc
, n
);
4719 n
= scm_product (n
, n
);
4726 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4728 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4729 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4731 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4732 "@var{cnt} is negative it's a division, rounded towards negative\n"
4733 "infinity. (Note that this is not the same rounding as\n"
4734 "@code{quotient} does.)\n"
4736 "With @var{n} viewed as an infinite precision twos complement,\n"
4737 "@code{ash} means a left shift introducing zero bits, or a right\n"
4738 "shift dropping bits.\n"
4741 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4742 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4744 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4745 "(ash -23 -2) @result{} -6\n"
4747 #define FUNC_NAME s_scm_ash
4750 bits_to_shift
= scm_to_long (cnt
);
4752 if (SCM_I_INUMP (n
))
4754 scm_t_inum nn
= SCM_I_INUM (n
);
4756 if (bits_to_shift
> 0)
4758 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4759 overflow a non-zero fixnum. For smaller shifts we check the
4760 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4761 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4762 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4768 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4770 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4773 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4777 SCM result
= scm_i_inum2big (nn
);
4778 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4785 bits_to_shift
= -bits_to_shift
;
4786 if (bits_to_shift
>= SCM_LONG_BIT
)
4787 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4789 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4793 else if (SCM_BIGP (n
))
4797 if (bits_to_shift
== 0)
4800 result
= scm_i_mkbig ();
4801 if (bits_to_shift
>= 0)
4803 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4809 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4810 we have to allocate a bignum even if the result is going to be a
4812 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4814 return scm_i_normbig (result
);
4820 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4826 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4827 (SCM n
, SCM start
, SCM end
),
4828 "Return the integer composed of the @var{start} (inclusive)\n"
4829 "through @var{end} (exclusive) bits of @var{n}. The\n"
4830 "@var{start}th bit becomes the 0-th bit in the result.\n"
4833 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4834 " @result{} \"1010\"\n"
4835 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4836 " @result{} \"10110\"\n"
4838 #define FUNC_NAME s_scm_bit_extract
4840 unsigned long int istart
, iend
, bits
;
4841 istart
= scm_to_ulong (start
);
4842 iend
= scm_to_ulong (end
);
4843 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4845 /* how many bits to keep */
4846 bits
= iend
- istart
;
4848 if (SCM_I_INUMP (n
))
4850 scm_t_inum in
= SCM_I_INUM (n
);
4852 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4853 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4854 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4856 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4858 /* Since we emulate two's complement encoded numbers, this
4859 * special case requires us to produce a result that has
4860 * more bits than can be stored in a fixnum.
4862 SCM result
= scm_i_inum2big (in
);
4863 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4868 /* mask down to requisite bits */
4869 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4870 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4872 else if (SCM_BIGP (n
))
4877 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4881 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4882 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4883 such bits into a ulong. */
4884 result
= scm_i_mkbig ();
4885 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4886 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4887 result
= scm_i_normbig (result
);
4889 scm_remember_upto_here_1 (n
);
4893 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4898 static const char scm_logtab
[] = {
4899 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4902 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4904 "Return the number of bits in integer @var{n}. If integer is\n"
4905 "positive, the 1-bits in its binary representation are counted.\n"
4906 "If negative, the 0-bits in its two's-complement binary\n"
4907 "representation are counted. If 0, 0 is returned.\n"
4910 "(logcount #b10101010)\n"
4917 #define FUNC_NAME s_scm_logcount
4919 if (SCM_I_INUMP (n
))
4921 unsigned long c
= 0;
4922 scm_t_inum nn
= SCM_I_INUM (n
);
4927 c
+= scm_logtab
[15 & nn
];
4930 return SCM_I_MAKINUM (c
);
4932 else if (SCM_BIGP (n
))
4934 unsigned long count
;
4935 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4936 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4938 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4939 scm_remember_upto_here_1 (n
);
4940 return SCM_I_MAKINUM (count
);
4943 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4948 static const char scm_ilentab
[] = {
4949 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4953 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4955 "Return the number of bits necessary to represent @var{n}.\n"
4958 "(integer-length #b10101010)\n"
4960 "(integer-length 0)\n"
4962 "(integer-length #b1111)\n"
4965 #define FUNC_NAME s_scm_integer_length
4967 if (SCM_I_INUMP (n
))
4969 unsigned long c
= 0;
4971 scm_t_inum nn
= SCM_I_INUM (n
);
4977 l
= scm_ilentab
[15 & nn
];
4980 return SCM_I_MAKINUM (c
- 4 + l
);
4982 else if (SCM_BIGP (n
))
4984 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4985 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4986 1 too big, so check for that and adjust. */
4987 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4988 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4989 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4990 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4992 scm_remember_upto_here_1 (n
);
4993 return SCM_I_MAKINUM (size
);
4996 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5000 /*** NUMBERS -> STRINGS ***/
5001 #define SCM_MAX_DBL_PREC 60
5002 #define SCM_MAX_DBL_RADIX 36
5004 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
5005 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
5006 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
5009 void init_dblprec(int *prec
, int radix
) {
5010 /* determine floating point precision by adding successively
5011 smaller increments to 1.0 until it is considered == 1.0 */
5012 double f
= ((double)1.0)/radix
;
5013 double fsum
= 1.0 + f
;
5018 if (++(*prec
) > SCM_MAX_DBL_PREC
)
5030 void init_fx_radix(double *fx_list
, int radix
)
5032 /* initialize a per-radix list of tolerances. When added
5033 to a number < 1.0, we can determine if we should raund
5034 up and quit converting a number to a string. */
5038 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5039 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5042 /* use this array as a way to generate a single digit */
5043 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5046 idbl2str (double f
, char *a
, int radix
)
5048 int efmt
, dpt
, d
, i
, wp
;
5050 #ifdef DBL_MIN_10_EXP
5053 #endif /* DBL_MIN_10_EXP */
5058 radix
> SCM_MAX_DBL_RADIX
)
5060 /* revert to existing behavior */
5064 wp
= scm_dblprec
[radix
-2];
5065 fx
= fx_per_radix
[radix
-2];
5069 #ifdef HAVE_COPYSIGN
5070 double sgn
= copysign (1.0, f
);
5075 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5081 strcpy (a
, "-inf.0");
5083 strcpy (a
, "+inf.0");
5088 strcpy (a
, "+nan.0");
5098 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5099 make-uniform-vector, from causing infinite loops. */
5100 /* just do the checking...if it passes, we do the conversion for our
5101 radix again below */
5108 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5116 while (f_cpy
> 10.0)
5119 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5140 if (f
+ fx
[wp
] >= radix
)
5147 /* adding 9999 makes this equivalent to abs(x) % 3 */
5148 dpt
= (exp
+ 9999) % 3;
5152 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5174 a
[ch
++] = number_chars
[d
];
5177 if (f
+ fx
[wp
] >= 1.0)
5179 a
[ch
- 1] = number_chars
[d
+1];
5191 if ((dpt
> 4) && (exp
> 6))
5193 d
= (a
[0] == '-' ? 2 : 1);
5194 for (i
= ch
++; i
> d
; i
--)
5207 if (a
[ch
- 1] == '.')
5208 a
[ch
++] = '0'; /* trailing zero */
5217 for (i
= radix
; i
<= exp
; i
*= radix
);
5218 for (i
/= radix
; i
; i
/= radix
)
5220 a
[ch
++] = number_chars
[exp
/ i
];
5229 icmplx2str (double real
, double imag
, char *str
, int radix
)
5234 i
= idbl2str (real
, str
, radix
);
5235 #ifdef HAVE_COPYSIGN
5236 sgn
= copysign (1.0, imag
);
5240 /* Don't output a '+' for negative numbers or for Inf and
5241 NaN. They will provide their own sign. */
5242 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5244 i
+= idbl2str (imag
, &str
[i
], radix
);
5250 iflo2str (SCM flt
, char *str
, int radix
)
5253 if (SCM_REALP (flt
))
5254 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5256 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5261 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5262 characters in the result.
5264 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5266 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5271 return scm_iuint2str (-num
, rad
, p
) + 1;
5274 return scm_iuint2str (num
, rad
, p
);
5277 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5278 characters in the result.
5280 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5282 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5286 scm_t_uintmax n
= num
;
5288 if (rad
< 2 || rad
> 36)
5289 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5291 for (n
/= rad
; n
> 0; n
/= rad
)
5301 p
[i
] = number_chars
[d
];
5306 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5308 "Return a string holding the external representation of the\n"
5309 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5310 "inexact, a radix of 10 will be used.")
5311 #define FUNC_NAME s_scm_number_to_string
5315 if (SCM_UNBNDP (radix
))
5318 base
= scm_to_signed_integer (radix
, 2, 36);
5320 if (SCM_I_INUMP (n
))
5322 char num_buf
[SCM_INTBUFLEN
];
5323 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5324 return scm_from_locale_stringn (num_buf
, length
);
5326 else if (SCM_BIGP (n
))
5328 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5329 size_t len
= strlen (str
);
5330 void (*freefunc
) (void *, size_t);
5332 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5333 scm_remember_upto_here_1 (n
);
5334 ret
= scm_from_latin1_stringn (str
, len
);
5335 freefunc (str
, len
+ 1);
5338 else if (SCM_FRACTIONP (n
))
5340 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5341 scm_from_locale_string ("/"),
5342 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5344 else if (SCM_INEXACTP (n
))
5346 char num_buf
[FLOBUFLEN
];
5347 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5350 SCM_WRONG_TYPE_ARG (1, n
);
5355 /* These print routines used to be stubbed here so that scm_repl.c
5356 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5359 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5361 char num_buf
[FLOBUFLEN
];
5362 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5367 scm_i_print_double (double val
, SCM port
)
5369 char num_buf
[FLOBUFLEN
];
5370 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5374 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5377 char num_buf
[FLOBUFLEN
];
5378 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5383 scm_i_print_complex (double real
, double imag
, SCM port
)
5385 char num_buf
[FLOBUFLEN
];
5386 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5390 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5393 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5394 scm_display (str
, port
);
5395 scm_remember_upto_here_1 (str
);
5400 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5402 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5403 size_t len
= strlen (str
);
5404 void (*freefunc
) (void *, size_t);
5405 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5406 scm_remember_upto_here_1 (exp
);
5407 scm_lfwrite (str
, len
, port
);
5408 freefunc (str
, len
+ 1);
5411 /*** END nums->strs ***/
5414 /*** STRINGS -> NUMBERS ***/
5416 /* The following functions implement the conversion from strings to numbers.
5417 * The implementation somehow follows the grammar for numbers as it is given
5418 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5419 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5420 * points should be noted about the implementation:
5422 * * Each function keeps a local index variable 'idx' that points at the
5423 * current position within the parsed string. The global index is only
5424 * updated if the function could parse the corresponding syntactic unit
5427 * * Similarly, the functions keep track of indicators of inexactness ('#',
5428 * '.' or exponents) using local variables ('hash_seen', 'x').
5430 * * Sequences of digits are parsed into temporary variables holding fixnums.
5431 * Only if these fixnums would overflow, the result variables are updated
5432 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5433 * the temporary variables holding the fixnums are cleared, and the process
5434 * starts over again. If for example fixnums were able to store five decimal
5435 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5436 * and the result was computed as 12345 * 100000 + 67890. In other words,
5437 * only every five digits two bignum operations were performed.
5439 * Notes on the handling of exactness specifiers:
5441 * When parsing non-real complex numbers, we apply exactness specifiers on
5442 * per-component basis, as is done in PLT Scheme. For complex numbers
5443 * written in rectangular form, exactness specifiers are applied to the
5444 * real and imaginary parts before calling scm_make_rectangular. For
5445 * complex numbers written in polar form, exactness specifiers are applied
5446 * to the magnitude and angle before calling scm_make_polar.
5448 * There are two kinds of exactness specifiers: forced and implicit. A
5449 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5450 * the entire number, and applies to both components of a complex number.
5451 * "#e" causes each component to be made exact, and "#i" causes each
5452 * component to be made inexact. If no forced exactness specifier is
5453 * present, then the exactness of each component is determined
5454 * independently by the presence or absence of a decimal point or hash mark
5455 * within that component. If a decimal point or hash mark is present, the
5456 * component is made inexact, otherwise it is made exact.
5458 * After the exactness specifiers have been applied to each component, they
5459 * are passed to either scm_make_rectangular or scm_make_polar to produce
5460 * the final result. Note that this will result in a real number if the
5461 * imaginary part, magnitude, or angle is an exact 0.
5463 * For example, (string->number "#i5.0+0i") does the equivalent of:
5465 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5468 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5470 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5472 /* Caller is responsible for checking that the return value is in range
5473 for the given radix, which should be <= 36. */
5475 char_decimal_value (scm_t_uint32 c
)
5477 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5478 that's certainly above any valid decimal, so we take advantage of
5479 that to elide some tests. */
5480 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5482 /* If that failed, try extended hexadecimals, then. Only accept ascii
5487 if (c
>= (scm_t_uint32
) 'a')
5488 d
= c
- (scm_t_uint32
)'a' + 10U;
5493 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5494 in base RADIX. Upon success, return the unsigned integer and update
5495 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5497 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5498 unsigned int radix
, enum t_exactness
*p_exactness
)
5500 unsigned int idx
= *p_idx
;
5501 unsigned int hash_seen
= 0;
5502 scm_t_bits shift
= 1;
5504 unsigned int digit_value
;
5507 size_t len
= scm_i_string_length (mem
);
5512 c
= scm_i_string_ref (mem
, idx
);
5513 digit_value
= char_decimal_value (c
);
5514 if (digit_value
>= radix
)
5518 result
= SCM_I_MAKINUM (digit_value
);
5521 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5531 digit_value
= char_decimal_value (c
);
5532 /* This check catches non-decimals in addition to out-of-range
5534 if (digit_value
>= radix
)
5539 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5541 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5543 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5550 shift
= shift
* radix
;
5551 add
= add
* radix
+ digit_value
;
5556 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5558 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5562 *p_exactness
= INEXACT
;
5568 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5569 * covers the parts of the rules that start at a potential point. The value
5570 * of the digits up to the point have been parsed by the caller and are given
5571 * in variable result. The content of *p_exactness indicates, whether a hash
5572 * has already been seen in the digits before the point.
5575 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5578 mem2decimal_from_point (SCM result
, SCM mem
,
5579 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5581 unsigned int idx
= *p_idx
;
5582 enum t_exactness x
= *p_exactness
;
5583 size_t len
= scm_i_string_length (mem
);
5588 if (scm_i_string_ref (mem
, idx
) == '.')
5590 scm_t_bits shift
= 1;
5592 unsigned int digit_value
;
5593 SCM big_shift
= SCM_INUM1
;
5598 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5599 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5604 digit_value
= DIGIT2UINT (c
);
5615 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5617 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5618 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5620 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5628 add
= add
* 10 + digit_value
;
5634 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5635 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5636 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5639 result
= scm_divide (result
, big_shift
);
5641 /* We've seen a decimal point, thus the value is implicitly inexact. */
5653 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5655 switch (scm_i_string_ref (mem
, idx
))
5667 c
= scm_i_string_ref (mem
, idx
);
5675 c
= scm_i_string_ref (mem
, idx
);
5684 c
= scm_i_string_ref (mem
, idx
);
5689 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5693 exponent
= DIGIT2UINT (c
);
5696 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5697 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5700 if (exponent
<= SCM_MAXEXP
)
5701 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5707 if (exponent
> SCM_MAXEXP
)
5709 size_t exp_len
= idx
- start
;
5710 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5711 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5712 scm_out_of_range ("string->number", exp_num
);
5715 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5717 result
= scm_product (result
, e
);
5719 result
= scm_divide (result
, e
);
5721 /* We've seen an exponent, thus the value is implicitly inexact. */
5739 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5742 mem2ureal (SCM mem
, unsigned int *p_idx
,
5743 unsigned int radix
, enum t_exactness forced_x
)
5745 unsigned int idx
= *p_idx
;
5747 size_t len
= scm_i_string_length (mem
);
5749 /* Start off believing that the number will be exact. This changes
5750 to INEXACT if we see a decimal point or a hash. */
5751 enum t_exactness implicit_x
= EXACT
;
5756 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5762 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5764 /* Cobble up the fractional part. We might want to set the
5765 NaN's mantissa from it. */
5767 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
), SCM_INUM0
))
5769 #if SCM_ENABLE_DEPRECATED == 1
5770 scm_c_issue_deprecation_warning
5771 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5781 if (scm_i_string_ref (mem
, idx
) == '.')
5785 else if (idx
+ 1 == len
)
5787 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5790 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5791 p_idx
, &implicit_x
);
5797 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5798 if (scm_is_false (uinteger
))
5803 else if (scm_i_string_ref (mem
, idx
) == '/')
5811 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5812 if (scm_is_false (divisor
))
5815 /* both are int/big here, I assume */
5816 result
= scm_i_make_ratio (uinteger
, divisor
);
5818 else if (radix
== 10)
5820 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5821 if (scm_is_false (result
))
5833 if (SCM_INEXACTP (result
))
5834 return scm_inexact_to_exact (result
);
5838 if (SCM_INEXACTP (result
))
5841 return scm_exact_to_inexact (result
);
5843 if (implicit_x
== INEXACT
)
5845 if (SCM_INEXACTP (result
))
5848 return scm_exact_to_inexact (result
);
5854 /* We should never get here */
5855 scm_syserror ("mem2ureal");
5859 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5862 mem2complex (SCM mem
, unsigned int idx
,
5863 unsigned int radix
, enum t_exactness forced_x
)
5868 size_t len
= scm_i_string_length (mem
);
5873 c
= scm_i_string_ref (mem
, idx
);
5888 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5889 if (scm_is_false (ureal
))
5891 /* input must be either +i or -i */
5896 if (scm_i_string_ref (mem
, idx
) == 'i'
5897 || scm_i_string_ref (mem
, idx
) == 'I')
5903 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5910 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5911 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5916 c
= scm_i_string_ref (mem
, idx
);
5920 /* either +<ureal>i or -<ureal>i */
5927 return scm_make_rectangular (SCM_INUM0
, ureal
);
5930 /* polar input: <real>@<real>. */
5941 c
= scm_i_string_ref (mem
, idx
);
5959 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5960 if (scm_is_false (angle
))
5965 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5966 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5968 result
= scm_make_polar (ureal
, angle
);
5973 /* expecting input matching <real>[+-]<ureal>?i */
5980 int sign
= (c
== '+') ? 1 : -1;
5981 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5983 if (scm_is_false (imag
))
5984 imag
= SCM_I_MAKINUM (sign
);
5985 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5986 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5990 if (scm_i_string_ref (mem
, idx
) != 'i'
5991 && scm_i_string_ref (mem
, idx
) != 'I')
5998 return scm_make_rectangular (ureal
, imag
);
6007 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6009 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6012 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6014 unsigned int idx
= 0;
6015 unsigned int radix
= NO_RADIX
;
6016 enum t_exactness forced_x
= NO_EXACTNESS
;
6017 size_t len
= scm_i_string_length (mem
);
6019 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6020 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6022 switch (scm_i_string_ref (mem
, idx
+ 1))
6025 if (radix
!= NO_RADIX
)
6030 if (radix
!= NO_RADIX
)
6035 if (forced_x
!= NO_EXACTNESS
)
6040 if (forced_x
!= NO_EXACTNESS
)
6045 if (radix
!= NO_RADIX
)
6050 if (radix
!= NO_RADIX
)
6060 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6061 if (radix
== NO_RADIX
)
6062 radix
= default_radix
;
6064 return mem2complex (mem
, idx
, radix
, forced_x
);
6068 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6069 unsigned int default_radix
)
6071 SCM str
= scm_from_locale_stringn (mem
, len
);
6073 return scm_i_string_to_number (str
, default_radix
);
6077 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6078 (SCM string
, SCM radix
),
6079 "Return a number of the maximally precise representation\n"
6080 "expressed by the given @var{string}. @var{radix} must be an\n"
6081 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6082 "is a default radix that may be overridden by an explicit radix\n"
6083 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6084 "supplied, then the default radix is 10. If string is not a\n"
6085 "syntactically valid notation for a number, then\n"
6086 "@code{string->number} returns @code{#f}.")
6087 #define FUNC_NAME s_scm_string_to_number
6091 SCM_VALIDATE_STRING (1, string
);
6093 if (SCM_UNBNDP (radix
))
6096 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6098 answer
= scm_i_string_to_number (string
, base
);
6099 scm_remember_upto_here_1 (string
);
6105 /*** END strs->nums ***/
6108 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6110 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6112 #define FUNC_NAME s_scm_number_p
6114 return scm_from_bool (SCM_NUMBERP (x
));
6118 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6120 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6121 "otherwise. Note that the sets of real, rational and integer\n"
6122 "values form subsets of the set of complex numbers, i. e. the\n"
6123 "predicate will also be fulfilled if @var{x} is a real,\n"
6124 "rational or integer number.")
6125 #define FUNC_NAME s_scm_complex_p
6127 /* all numbers are complex. */
6128 return scm_number_p (x
);
6132 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6134 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6135 "otherwise. Note that the set of integer values forms a subset of\n"
6136 "the set of real numbers, i. e. the predicate will also be\n"
6137 "fulfilled if @var{x} is an integer number.")
6138 #define FUNC_NAME s_scm_real_p
6140 return scm_from_bool
6141 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6145 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6147 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6148 "otherwise. Note that the set of integer values forms a subset of\n"
6149 "the set of rational numbers, i. e. the predicate will also be\n"
6150 "fulfilled if @var{x} is an integer number.")
6151 #define FUNC_NAME s_scm_rational_p
6153 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6155 else if (SCM_REALP (x
))
6156 /* due to their limited precision, finite floating point numbers are
6157 rational as well. (finite means neither infinity nor a NaN) */
6158 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6164 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6166 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6168 #define FUNC_NAME s_scm_integer_p
6170 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6172 else if (SCM_REALP (x
))
6174 double val
= SCM_REAL_VALUE (x
);
6175 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6183 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6184 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6185 (SCM x
, SCM y
, SCM rest
),
6186 "Return @code{#t} if all parameters are numerically equal.")
6187 #define FUNC_NAME s_scm_i_num_eq_p
6189 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6191 while (!scm_is_null (rest
))
6193 if (scm_is_false (scm_num_eq_p (x
, y
)))
6197 rest
= scm_cdr (rest
);
6199 return scm_num_eq_p (x
, y
);
6203 scm_num_eq_p (SCM x
, SCM y
)
6206 if (SCM_I_INUMP (x
))
6208 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6209 if (SCM_I_INUMP (y
))
6211 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6212 return scm_from_bool (xx
== yy
);
6214 else if (SCM_BIGP (y
))
6216 else if (SCM_REALP (y
))
6218 /* On a 32-bit system an inum fits a double, we can cast the inum
6219 to a double and compare.
6221 But on a 64-bit system an inum is bigger than a double and
6222 casting it to a double (call that dxx) will round. dxx is at
6223 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6224 an integer and fits a long. So we cast yy to a long and
6225 compare with plain xx.
6227 An alternative (for any size system actually) would be to check
6228 yy is an integer (with floor) and is in range of an inum
6229 (compare against appropriate powers of 2) then test
6230 xx==(scm_t_signed_bits)yy. It's just a matter of which
6231 casts/comparisons might be fastest or easiest for the cpu. */
6233 double yy
= SCM_REAL_VALUE (y
);
6234 return scm_from_bool ((double) xx
== yy
6235 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6236 || xx
== (scm_t_signed_bits
) yy
));
6238 else if (SCM_COMPLEXP (y
))
6239 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6240 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6241 else if (SCM_FRACTIONP (y
))
6244 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6246 else if (SCM_BIGP (x
))
6248 if (SCM_I_INUMP (y
))
6250 else if (SCM_BIGP (y
))
6252 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6253 scm_remember_upto_here_2 (x
, y
);
6254 return scm_from_bool (0 == cmp
);
6256 else if (SCM_REALP (y
))
6259 if (isnan (SCM_REAL_VALUE (y
)))
6261 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6262 scm_remember_upto_here_1 (x
);
6263 return scm_from_bool (0 == cmp
);
6265 else if (SCM_COMPLEXP (y
))
6268 if (0.0 != SCM_COMPLEX_IMAG (y
))
6270 if (isnan (SCM_COMPLEX_REAL (y
)))
6272 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6273 scm_remember_upto_here_1 (x
);
6274 return scm_from_bool (0 == cmp
);
6276 else if (SCM_FRACTIONP (y
))
6279 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6281 else if (SCM_REALP (x
))
6283 double xx
= SCM_REAL_VALUE (x
);
6284 if (SCM_I_INUMP (y
))
6286 /* see comments with inum/real above */
6287 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6288 return scm_from_bool (xx
== (double) yy
6289 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6290 || (scm_t_signed_bits
) xx
== yy
));
6292 else if (SCM_BIGP (y
))
6295 if (isnan (SCM_REAL_VALUE (x
)))
6297 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6298 scm_remember_upto_here_1 (y
);
6299 return scm_from_bool (0 == cmp
);
6301 else if (SCM_REALP (y
))
6302 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6303 else if (SCM_COMPLEXP (y
))
6304 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6305 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6306 else if (SCM_FRACTIONP (y
))
6308 double xx
= SCM_REAL_VALUE (x
);
6312 return scm_from_bool (xx
< 0.0);
6313 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6317 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6319 else if (SCM_COMPLEXP (x
))
6321 if (SCM_I_INUMP (y
))
6322 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6323 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6324 else if (SCM_BIGP (y
))
6327 if (0.0 != SCM_COMPLEX_IMAG (x
))
6329 if (isnan (SCM_COMPLEX_REAL (x
)))
6331 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6332 scm_remember_upto_here_1 (y
);
6333 return scm_from_bool (0 == cmp
);
6335 else if (SCM_REALP (y
))
6336 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6337 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6338 else if (SCM_COMPLEXP (y
))
6339 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6340 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6341 else if (SCM_FRACTIONP (y
))
6344 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6346 xx
= SCM_COMPLEX_REAL (x
);
6350 return scm_from_bool (xx
< 0.0);
6351 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6355 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6357 else if (SCM_FRACTIONP (x
))
6359 if (SCM_I_INUMP (y
))
6361 else if (SCM_BIGP (y
))
6363 else if (SCM_REALP (y
))
6365 double yy
= SCM_REAL_VALUE (y
);
6369 return scm_from_bool (0.0 < yy
);
6370 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6373 else if (SCM_COMPLEXP (y
))
6376 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6378 yy
= SCM_COMPLEX_REAL (y
);
6382 return scm_from_bool (0.0 < yy
);
6383 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6386 else if (SCM_FRACTIONP (y
))
6387 return scm_i_fraction_equalp (x
, y
);
6389 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6392 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6396 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6397 done are good for inums, but for bignums an answer can almost always be
6398 had by just examining a few high bits of the operands, as done by GMP in
6399 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6400 of the float exponent to take into account. */
6402 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6403 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6404 (SCM x
, SCM y
, SCM rest
),
6405 "Return @code{#t} if the list of parameters is monotonically\n"
6407 #define FUNC_NAME s_scm_i_num_less_p
6409 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6411 while (!scm_is_null (rest
))
6413 if (scm_is_false (scm_less_p (x
, y
)))
6417 rest
= scm_cdr (rest
);
6419 return scm_less_p (x
, y
);
6423 scm_less_p (SCM x
, SCM y
)
6426 if (SCM_I_INUMP (x
))
6428 scm_t_inum xx
= SCM_I_INUM (x
);
6429 if (SCM_I_INUMP (y
))
6431 scm_t_inum yy
= SCM_I_INUM (y
);
6432 return scm_from_bool (xx
< yy
);
6434 else if (SCM_BIGP (y
))
6436 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6437 scm_remember_upto_here_1 (y
);
6438 return scm_from_bool (sgn
> 0);
6440 else if (SCM_REALP (y
))
6441 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6442 else if (SCM_FRACTIONP (y
))
6444 /* "x < a/b" becomes "x*b < a" */
6446 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6447 y
= SCM_FRACTION_NUMERATOR (y
);
6451 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6453 else if (SCM_BIGP (x
))
6455 if (SCM_I_INUMP (y
))
6457 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6458 scm_remember_upto_here_1 (x
);
6459 return scm_from_bool (sgn
< 0);
6461 else if (SCM_BIGP (y
))
6463 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6464 scm_remember_upto_here_2 (x
, y
);
6465 return scm_from_bool (cmp
< 0);
6467 else if (SCM_REALP (y
))
6470 if (isnan (SCM_REAL_VALUE (y
)))
6472 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6473 scm_remember_upto_here_1 (x
);
6474 return scm_from_bool (cmp
< 0);
6476 else if (SCM_FRACTIONP (y
))
6479 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6481 else if (SCM_REALP (x
))
6483 if (SCM_I_INUMP (y
))
6484 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6485 else if (SCM_BIGP (y
))
6488 if (isnan (SCM_REAL_VALUE (x
)))
6490 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6491 scm_remember_upto_here_1 (y
);
6492 return scm_from_bool (cmp
> 0);
6494 else if (SCM_REALP (y
))
6495 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6496 else if (SCM_FRACTIONP (y
))
6498 double xx
= SCM_REAL_VALUE (x
);
6502 return scm_from_bool (xx
< 0.0);
6503 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6507 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6509 else if (SCM_FRACTIONP (x
))
6511 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6513 /* "a/b < y" becomes "a < y*b" */
6514 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6515 x
= SCM_FRACTION_NUMERATOR (x
);
6518 else if (SCM_REALP (y
))
6520 double yy
= SCM_REAL_VALUE (y
);
6524 return scm_from_bool (0.0 < yy
);
6525 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6528 else if (SCM_FRACTIONP (y
))
6530 /* "a/b < c/d" becomes "a*d < c*b" */
6531 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6532 SCM_FRACTION_DENOMINATOR (y
));
6533 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6534 SCM_FRACTION_DENOMINATOR (x
));
6540 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6543 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6547 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6548 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6549 (SCM x
, SCM y
, SCM rest
),
6550 "Return @code{#t} if the list of parameters is monotonically\n"
6552 #define FUNC_NAME s_scm_i_num_gr_p
6554 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6556 while (!scm_is_null (rest
))
6558 if (scm_is_false (scm_gr_p (x
, y
)))
6562 rest
= scm_cdr (rest
);
6564 return scm_gr_p (x
, y
);
6567 #define FUNC_NAME s_scm_i_num_gr_p
6569 scm_gr_p (SCM x
, SCM y
)
6571 if (!SCM_NUMBERP (x
))
6572 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6573 else if (!SCM_NUMBERP (y
))
6574 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6576 return scm_less_p (y
, x
);
6581 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6582 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6583 (SCM x
, SCM y
, SCM rest
),
6584 "Return @code{#t} if the list of parameters is monotonically\n"
6586 #define FUNC_NAME s_scm_i_num_leq_p
6588 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6590 while (!scm_is_null (rest
))
6592 if (scm_is_false (scm_leq_p (x
, y
)))
6596 rest
= scm_cdr (rest
);
6598 return scm_leq_p (x
, y
);
6601 #define FUNC_NAME s_scm_i_num_leq_p
6603 scm_leq_p (SCM x
, SCM y
)
6605 if (!SCM_NUMBERP (x
))
6606 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6607 else if (!SCM_NUMBERP (y
))
6608 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6609 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6612 return scm_not (scm_less_p (y
, x
));
6617 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6618 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6619 (SCM x
, SCM y
, SCM rest
),
6620 "Return @code{#t} if the list of parameters is monotonically\n"
6622 #define FUNC_NAME s_scm_i_num_geq_p
6624 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6626 while (!scm_is_null (rest
))
6628 if (scm_is_false (scm_geq_p (x
, y
)))
6632 rest
= scm_cdr (rest
);
6634 return scm_geq_p (x
, y
);
6637 #define FUNC_NAME s_scm_i_num_geq_p
6639 scm_geq_p (SCM x
, SCM y
)
6641 if (!SCM_NUMBERP (x
))
6642 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6643 else if (!SCM_NUMBERP (y
))
6644 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6645 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6648 return scm_not (scm_less_p (x
, y
));
6653 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6655 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6657 #define FUNC_NAME s_scm_zero_p
6659 if (SCM_I_INUMP (z
))
6660 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6661 else if (SCM_BIGP (z
))
6663 else if (SCM_REALP (z
))
6664 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6665 else if (SCM_COMPLEXP (z
))
6666 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6667 && SCM_COMPLEX_IMAG (z
) == 0.0);
6668 else if (SCM_FRACTIONP (z
))
6671 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6676 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6678 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6680 #define FUNC_NAME s_scm_positive_p
6682 if (SCM_I_INUMP (x
))
6683 return scm_from_bool (SCM_I_INUM (x
) > 0);
6684 else if (SCM_BIGP (x
))
6686 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6687 scm_remember_upto_here_1 (x
);
6688 return scm_from_bool (sgn
> 0);
6690 else if (SCM_REALP (x
))
6691 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6692 else if (SCM_FRACTIONP (x
))
6693 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6695 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6700 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6702 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6704 #define FUNC_NAME s_scm_negative_p
6706 if (SCM_I_INUMP (x
))
6707 return scm_from_bool (SCM_I_INUM (x
) < 0);
6708 else if (SCM_BIGP (x
))
6710 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6711 scm_remember_upto_here_1 (x
);
6712 return scm_from_bool (sgn
< 0);
6714 else if (SCM_REALP (x
))
6715 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6716 else if (SCM_FRACTIONP (x
))
6717 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6719 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6724 /* scm_min and scm_max return an inexact when either argument is inexact, as
6725 required by r5rs. On that basis, for exact/inexact combinations the
6726 exact is converted to inexact to compare and possibly return. This is
6727 unlike scm_less_p above which takes some trouble to preserve all bits in
6728 its test, such trouble is not required for min and max. */
6730 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6731 (SCM x
, SCM y
, SCM rest
),
6732 "Return the maximum of all parameter values.")
6733 #define FUNC_NAME s_scm_i_max
6735 while (!scm_is_null (rest
))
6736 { x
= scm_max (x
, y
);
6738 rest
= scm_cdr (rest
);
6740 return scm_max (x
, y
);
6744 #define s_max s_scm_i_max
6745 #define g_max g_scm_i_max
6748 scm_max (SCM x
, SCM y
)
6753 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6754 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6757 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6760 if (SCM_I_INUMP (x
))
6762 scm_t_inum xx
= SCM_I_INUM (x
);
6763 if (SCM_I_INUMP (y
))
6765 scm_t_inum yy
= SCM_I_INUM (y
);
6766 return (xx
< yy
) ? y
: x
;
6768 else if (SCM_BIGP (y
))
6770 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6771 scm_remember_upto_here_1 (y
);
6772 return (sgn
< 0) ? x
: y
;
6774 else if (SCM_REALP (y
))
6777 double yyd
= SCM_REAL_VALUE (y
);
6780 return scm_from_double (xxd
);
6781 /* If y is a NaN, then "==" is false and we return the NaN */
6782 else if (SCM_LIKELY (!(xxd
== yyd
)))
6784 /* Handle signed zeroes properly */
6790 else if (SCM_FRACTIONP (y
))
6793 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6796 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6798 else if (SCM_BIGP (x
))
6800 if (SCM_I_INUMP (y
))
6802 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6803 scm_remember_upto_here_1 (x
);
6804 return (sgn
< 0) ? y
: x
;
6806 else if (SCM_BIGP (y
))
6808 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6809 scm_remember_upto_here_2 (x
, y
);
6810 return (cmp
> 0) ? x
: y
;
6812 else if (SCM_REALP (y
))
6814 /* if y==NaN then xx>yy is false, so we return the NaN y */
6817 xx
= scm_i_big2dbl (x
);
6818 yy
= SCM_REAL_VALUE (y
);
6819 return (xx
> yy
? scm_from_double (xx
) : y
);
6821 else if (SCM_FRACTIONP (y
))
6826 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6828 else if (SCM_REALP (x
))
6830 if (SCM_I_INUMP (y
))
6832 scm_t_inum yy
= SCM_I_INUM (y
);
6833 double xxd
= SCM_REAL_VALUE (x
);
6837 return scm_from_double (yyd
);
6838 /* If x is a NaN, then "==" is false and we return the NaN */
6839 else if (SCM_LIKELY (!(xxd
== yyd
)))
6841 /* Handle signed zeroes properly */
6847 else if (SCM_BIGP (y
))
6852 else if (SCM_REALP (y
))
6854 double xx
= SCM_REAL_VALUE (x
);
6855 double yy
= SCM_REAL_VALUE (y
);
6857 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6860 else if (SCM_LIKELY (xx
< yy
))
6862 /* If neither (xx > yy) nor (xx < yy), then
6863 either they're equal or one is a NaN */
6864 else if (SCM_UNLIKELY (isnan (xx
)))
6865 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6866 else if (SCM_UNLIKELY (isnan (yy
)))
6867 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6868 /* xx == yy, but handle signed zeroes properly */
6869 else if (double_is_non_negative_zero (yy
))
6874 else if (SCM_FRACTIONP (y
))
6876 double yy
= scm_i_fraction2double (y
);
6877 double xx
= SCM_REAL_VALUE (x
);
6878 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6881 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6883 else if (SCM_FRACTIONP (x
))
6885 if (SCM_I_INUMP (y
))
6889 else if (SCM_BIGP (y
))
6893 else if (SCM_REALP (y
))
6895 double xx
= scm_i_fraction2double (x
);
6896 /* if y==NaN then ">" is false, so we return the NaN y */
6897 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6899 else if (SCM_FRACTIONP (y
))
6904 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6907 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6911 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6912 (SCM x
, SCM y
, SCM rest
),
6913 "Return the minimum of all parameter values.")
6914 #define FUNC_NAME s_scm_i_min
6916 while (!scm_is_null (rest
))
6917 { x
= scm_min (x
, y
);
6919 rest
= scm_cdr (rest
);
6921 return scm_min (x
, y
);
6925 #define s_min s_scm_i_min
6926 #define g_min g_scm_i_min
6929 scm_min (SCM x
, SCM y
)
6934 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
6935 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6938 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
6941 if (SCM_I_INUMP (x
))
6943 scm_t_inum xx
= SCM_I_INUM (x
);
6944 if (SCM_I_INUMP (y
))
6946 scm_t_inum yy
= SCM_I_INUM (y
);
6947 return (xx
< yy
) ? x
: y
;
6949 else if (SCM_BIGP (y
))
6951 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6952 scm_remember_upto_here_1 (y
);
6953 return (sgn
< 0) ? y
: x
;
6955 else if (SCM_REALP (y
))
6958 /* if y==NaN then "<" is false and we return NaN */
6959 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6961 else if (SCM_FRACTIONP (y
))
6964 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6967 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6969 else if (SCM_BIGP (x
))
6971 if (SCM_I_INUMP (y
))
6973 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6974 scm_remember_upto_here_1 (x
);
6975 return (sgn
< 0) ? x
: y
;
6977 else if (SCM_BIGP (y
))
6979 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6980 scm_remember_upto_here_2 (x
, y
);
6981 return (cmp
> 0) ? y
: x
;
6983 else if (SCM_REALP (y
))
6985 /* if y==NaN then xx<yy is false, so we return the NaN y */
6988 xx
= scm_i_big2dbl (x
);
6989 yy
= SCM_REAL_VALUE (y
);
6990 return (xx
< yy
? scm_from_double (xx
) : y
);
6992 else if (SCM_FRACTIONP (y
))
6997 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6999 else if (SCM_REALP (x
))
7001 if (SCM_I_INUMP (y
))
7003 double z
= SCM_I_INUM (y
);
7004 /* if x==NaN then "<" is false and we return NaN */
7005 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7007 else if (SCM_BIGP (y
))
7012 else if (SCM_REALP (y
))
7014 double xx
= SCM_REAL_VALUE (x
);
7015 double yy
= SCM_REAL_VALUE (y
);
7017 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7020 else if (SCM_LIKELY (xx
> yy
))
7022 /* If neither (xx < yy) nor (xx > yy), then
7023 either they're equal or one is a NaN */
7024 else if (SCM_UNLIKELY (isnan (xx
)))
7025 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7026 else if (SCM_UNLIKELY (isnan (yy
)))
7027 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7028 /* xx == yy, but handle signed zeroes properly */
7029 else if (double_is_non_negative_zero (xx
))
7034 else if (SCM_FRACTIONP (y
))
7036 double yy
= scm_i_fraction2double (y
);
7037 double xx
= SCM_REAL_VALUE (x
);
7038 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7041 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7043 else if (SCM_FRACTIONP (x
))
7045 if (SCM_I_INUMP (y
))
7049 else if (SCM_BIGP (y
))
7053 else if (SCM_REALP (y
))
7055 double xx
= scm_i_fraction2double (x
);
7056 /* if y==NaN then "<" is false, so we return the NaN y */
7057 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7059 else if (SCM_FRACTIONP (y
))
7064 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7067 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7071 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7072 (SCM x
, SCM y
, SCM rest
),
7073 "Return the sum of all parameter values. Return 0 if called without\n"
7075 #define FUNC_NAME s_scm_i_sum
7077 while (!scm_is_null (rest
))
7078 { x
= scm_sum (x
, y
);
7080 rest
= scm_cdr (rest
);
7082 return scm_sum (x
, y
);
7086 #define s_sum s_scm_i_sum
7087 #define g_sum g_scm_i_sum
7090 scm_sum (SCM x
, SCM y
)
7092 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7094 if (SCM_NUMBERP (x
)) return x
;
7095 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7096 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7099 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7101 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7103 scm_t_inum xx
= SCM_I_INUM (x
);
7104 scm_t_inum yy
= SCM_I_INUM (y
);
7105 scm_t_inum z
= xx
+ yy
;
7106 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7108 else if (SCM_BIGP (y
))
7113 else if (SCM_REALP (y
))
7115 scm_t_inum xx
= SCM_I_INUM (x
);
7116 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7118 else if (SCM_COMPLEXP (y
))
7120 scm_t_inum xx
= SCM_I_INUM (x
);
7121 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7122 SCM_COMPLEX_IMAG (y
));
7124 else if (SCM_FRACTIONP (y
))
7125 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7126 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7127 SCM_FRACTION_DENOMINATOR (y
));
7129 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7130 } else if (SCM_BIGP (x
))
7132 if (SCM_I_INUMP (y
))
7137 inum
= SCM_I_INUM (y
);
7140 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7143 SCM result
= scm_i_mkbig ();
7144 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7145 scm_remember_upto_here_1 (x
);
7146 /* we know the result will have to be a bignum */
7149 return scm_i_normbig (result
);
7153 SCM result
= scm_i_mkbig ();
7154 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7155 scm_remember_upto_here_1 (x
);
7156 /* we know the result will have to be a bignum */
7159 return scm_i_normbig (result
);
7162 else if (SCM_BIGP (y
))
7164 SCM result
= scm_i_mkbig ();
7165 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7166 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7167 mpz_add (SCM_I_BIG_MPZ (result
),
7170 scm_remember_upto_here_2 (x
, y
);
7171 /* we know the result will have to be a bignum */
7174 return scm_i_normbig (result
);
7176 else if (SCM_REALP (y
))
7178 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7179 scm_remember_upto_here_1 (x
);
7180 return scm_from_double (result
);
7182 else if (SCM_COMPLEXP (y
))
7184 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7185 + SCM_COMPLEX_REAL (y
));
7186 scm_remember_upto_here_1 (x
);
7187 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7189 else if (SCM_FRACTIONP (y
))
7190 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7191 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7192 SCM_FRACTION_DENOMINATOR (y
));
7194 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7196 else if (SCM_REALP (x
))
7198 if (SCM_I_INUMP (y
))
7199 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7200 else if (SCM_BIGP (y
))
7202 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7203 scm_remember_upto_here_1 (y
);
7204 return scm_from_double (result
);
7206 else if (SCM_REALP (y
))
7207 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7208 else if (SCM_COMPLEXP (y
))
7209 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7210 SCM_COMPLEX_IMAG (y
));
7211 else if (SCM_FRACTIONP (y
))
7212 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7214 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7216 else if (SCM_COMPLEXP (x
))
7218 if (SCM_I_INUMP (y
))
7219 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7220 SCM_COMPLEX_IMAG (x
));
7221 else if (SCM_BIGP (y
))
7223 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7224 + SCM_COMPLEX_REAL (x
));
7225 scm_remember_upto_here_1 (y
);
7226 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7228 else if (SCM_REALP (y
))
7229 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7230 SCM_COMPLEX_IMAG (x
));
7231 else if (SCM_COMPLEXP (y
))
7232 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7233 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7234 else if (SCM_FRACTIONP (y
))
7235 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7236 SCM_COMPLEX_IMAG (x
));
7238 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7240 else if (SCM_FRACTIONP (x
))
7242 if (SCM_I_INUMP (y
))
7243 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7244 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7245 SCM_FRACTION_DENOMINATOR (x
));
7246 else if (SCM_BIGP (y
))
7247 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7248 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7249 SCM_FRACTION_DENOMINATOR (x
));
7250 else if (SCM_REALP (y
))
7251 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7252 else if (SCM_COMPLEXP (y
))
7253 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7254 SCM_COMPLEX_IMAG (y
));
7255 else if (SCM_FRACTIONP (y
))
7256 /* a/b + c/d = (ad + bc) / bd */
7257 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7258 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7259 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7261 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7264 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7268 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7270 "Return @math{@var{x}+1}.")
7271 #define FUNC_NAME s_scm_oneplus
7273 return scm_sum (x
, SCM_INUM1
);
7278 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7279 (SCM x
, SCM y
, SCM rest
),
7280 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7281 "the sum of all but the first argument are subtracted from the first\n"
7283 #define FUNC_NAME s_scm_i_difference
7285 while (!scm_is_null (rest
))
7286 { x
= scm_difference (x
, y
);
7288 rest
= scm_cdr (rest
);
7290 return scm_difference (x
, y
);
7294 #define s_difference s_scm_i_difference
7295 #define g_difference g_scm_i_difference
7298 scm_difference (SCM x
, SCM y
)
7299 #define FUNC_NAME s_difference
7301 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7304 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7306 if (SCM_I_INUMP (x
))
7308 scm_t_inum xx
= -SCM_I_INUM (x
);
7309 if (SCM_FIXABLE (xx
))
7310 return SCM_I_MAKINUM (xx
);
7312 return scm_i_inum2big (xx
);
7314 else if (SCM_BIGP (x
))
7315 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7316 bignum, but negating that gives a fixnum. */
7317 return scm_i_normbig (scm_i_clonebig (x
, 0));
7318 else if (SCM_REALP (x
))
7319 return scm_from_double (-SCM_REAL_VALUE (x
));
7320 else if (SCM_COMPLEXP (x
))
7321 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7322 -SCM_COMPLEX_IMAG (x
));
7323 else if (SCM_FRACTIONP (x
))
7324 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7325 SCM_FRACTION_DENOMINATOR (x
));
7327 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7330 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7332 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7334 scm_t_inum xx
= SCM_I_INUM (x
);
7335 scm_t_inum yy
= SCM_I_INUM (y
);
7336 scm_t_inum z
= xx
- yy
;
7337 if (SCM_FIXABLE (z
))
7338 return SCM_I_MAKINUM (z
);
7340 return scm_i_inum2big (z
);
7342 else if (SCM_BIGP (y
))
7344 /* inum-x - big-y */
7345 scm_t_inum xx
= SCM_I_INUM (x
);
7349 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7350 bignum, but negating that gives a fixnum. */
7351 return scm_i_normbig (scm_i_clonebig (y
, 0));
7355 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7356 SCM result
= scm_i_mkbig ();
7359 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7362 /* x - y == -(y + -x) */
7363 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7364 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7366 scm_remember_upto_here_1 (y
);
7368 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7369 /* we know the result will have to be a bignum */
7372 return scm_i_normbig (result
);
7375 else if (SCM_REALP (y
))
7377 scm_t_inum xx
= SCM_I_INUM (x
);
7380 * We need to handle x == exact 0
7381 * specially because R6RS states that:
7382 * (- 0.0) ==> -0.0 and
7383 * (- 0.0 0.0) ==> 0.0
7384 * and the scheme compiler changes
7385 * (- 0.0) into (- 0 0.0)
7386 * So we need to treat (- 0 0.0) like (- 0.0).
7387 * At the C level, (-x) is different than (0.0 - x).
7388 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7391 return scm_from_double (- SCM_REAL_VALUE (y
));
7393 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7395 else if (SCM_COMPLEXP (y
))
7397 scm_t_inum xx
= SCM_I_INUM (x
);
7399 /* We need to handle x == exact 0 specially.
7400 See the comment above (for SCM_REALP (y)) */
7402 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7403 - SCM_COMPLEX_IMAG (y
));
7405 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7406 - SCM_COMPLEX_IMAG (y
));
7408 else if (SCM_FRACTIONP (y
))
7409 /* a - b/c = (ac - b) / c */
7410 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7411 SCM_FRACTION_NUMERATOR (y
)),
7412 SCM_FRACTION_DENOMINATOR (y
));
7414 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7416 else if (SCM_BIGP (x
))
7418 if (SCM_I_INUMP (y
))
7420 /* big-x - inum-y */
7421 scm_t_inum yy
= SCM_I_INUM (y
);
7422 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7424 scm_remember_upto_here_1 (x
);
7426 return (SCM_FIXABLE (-yy
) ?
7427 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7430 SCM result
= scm_i_mkbig ();
7433 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7435 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7436 scm_remember_upto_here_1 (x
);
7438 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7439 /* we know the result will have to be a bignum */
7442 return scm_i_normbig (result
);
7445 else if (SCM_BIGP (y
))
7447 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7448 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7449 SCM result
= scm_i_mkbig ();
7450 mpz_sub (SCM_I_BIG_MPZ (result
),
7453 scm_remember_upto_here_2 (x
, y
);
7454 /* we know the result will have to be a bignum */
7455 if ((sgn_x
== 1) && (sgn_y
== -1))
7457 if ((sgn_x
== -1) && (sgn_y
== 1))
7459 return scm_i_normbig (result
);
7461 else if (SCM_REALP (y
))
7463 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7464 scm_remember_upto_here_1 (x
);
7465 return scm_from_double (result
);
7467 else if (SCM_COMPLEXP (y
))
7469 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7470 - SCM_COMPLEX_REAL (y
));
7471 scm_remember_upto_here_1 (x
);
7472 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7474 else if (SCM_FRACTIONP (y
))
7475 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7476 SCM_FRACTION_NUMERATOR (y
)),
7477 SCM_FRACTION_DENOMINATOR (y
));
7478 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7480 else if (SCM_REALP (x
))
7482 if (SCM_I_INUMP (y
))
7483 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7484 else if (SCM_BIGP (y
))
7486 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7487 scm_remember_upto_here_1 (x
);
7488 return scm_from_double (result
);
7490 else if (SCM_REALP (y
))
7491 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7492 else if (SCM_COMPLEXP (y
))
7493 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7494 -SCM_COMPLEX_IMAG (y
));
7495 else if (SCM_FRACTIONP (y
))
7496 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7498 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7500 else if (SCM_COMPLEXP (x
))
7502 if (SCM_I_INUMP (y
))
7503 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7504 SCM_COMPLEX_IMAG (x
));
7505 else if (SCM_BIGP (y
))
7507 double real_part
= (SCM_COMPLEX_REAL (x
)
7508 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7509 scm_remember_upto_here_1 (x
);
7510 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7512 else if (SCM_REALP (y
))
7513 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7514 SCM_COMPLEX_IMAG (x
));
7515 else if (SCM_COMPLEXP (y
))
7516 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7517 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7518 else if (SCM_FRACTIONP (y
))
7519 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7520 SCM_COMPLEX_IMAG (x
));
7522 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7524 else if (SCM_FRACTIONP (x
))
7526 if (SCM_I_INUMP (y
))
7527 /* a/b - c = (a - cb) / b */
7528 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7529 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7530 SCM_FRACTION_DENOMINATOR (x
));
7531 else if (SCM_BIGP (y
))
7532 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7533 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7534 SCM_FRACTION_DENOMINATOR (x
));
7535 else if (SCM_REALP (y
))
7536 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7537 else if (SCM_COMPLEXP (y
))
7538 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7539 -SCM_COMPLEX_IMAG (y
));
7540 else if (SCM_FRACTIONP (y
))
7541 /* a/b - c/d = (ad - bc) / bd */
7542 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7543 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7544 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7546 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7549 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7554 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7556 "Return @math{@var{x}-1}.")
7557 #define FUNC_NAME s_scm_oneminus
7559 return scm_difference (x
, SCM_INUM1
);
7564 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7565 (SCM x
, SCM y
, SCM rest
),
7566 "Return the product of all arguments. If called without arguments,\n"
7568 #define FUNC_NAME s_scm_i_product
7570 while (!scm_is_null (rest
))
7571 { x
= scm_product (x
, y
);
7573 rest
= scm_cdr (rest
);
7575 return scm_product (x
, y
);
7579 #define s_product s_scm_i_product
7580 #define g_product g_scm_i_product
7583 scm_product (SCM x
, SCM y
)
7585 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7588 return SCM_I_MAKINUM (1L);
7589 else if (SCM_NUMBERP (x
))
7592 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7595 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7600 xx
= SCM_I_INUM (x
);
7605 /* exact1 is the universal multiplicative identity */
7609 /* exact0 times a fixnum is exact0: optimize this case */
7610 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7612 /* if the other argument is inexact, the result is inexact,
7613 and we must do the multiplication in order to handle
7614 infinities and NaNs properly. */
7615 else if (SCM_REALP (y
))
7616 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7617 else if (SCM_COMPLEXP (y
))
7618 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7619 0.0 * SCM_COMPLEX_IMAG (y
));
7620 /* we've already handled inexact numbers,
7621 so y must be exact, and we return exact0 */
7622 else if (SCM_NUMP (y
))
7625 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7629 * This case is important for more than just optimization.
7630 * It handles the case of negating
7631 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7632 * which is a bignum that must be changed back into a fixnum.
7633 * Failure to do so will cause the following to return #f:
7634 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7636 return scm_difference(y
, SCM_UNDEFINED
);
7640 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7642 scm_t_inum yy
= SCM_I_INUM (y
);
7643 scm_t_inum kk
= xx
* yy
;
7644 SCM k
= SCM_I_MAKINUM (kk
);
7645 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7649 SCM result
= scm_i_inum2big (xx
);
7650 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7651 return scm_i_normbig (result
);
7654 else if (SCM_BIGP (y
))
7656 SCM result
= scm_i_mkbig ();
7657 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7658 scm_remember_upto_here_1 (y
);
7661 else if (SCM_REALP (y
))
7662 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7663 else if (SCM_COMPLEXP (y
))
7664 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7665 xx
* SCM_COMPLEX_IMAG (y
));
7666 else if (SCM_FRACTIONP (y
))
7667 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7668 SCM_FRACTION_DENOMINATOR (y
));
7670 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7672 else if (SCM_BIGP (x
))
7674 if (SCM_I_INUMP (y
))
7679 else if (SCM_BIGP (y
))
7681 SCM result
= scm_i_mkbig ();
7682 mpz_mul (SCM_I_BIG_MPZ (result
),
7685 scm_remember_upto_here_2 (x
, y
);
7688 else if (SCM_REALP (y
))
7690 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7691 scm_remember_upto_here_1 (x
);
7692 return scm_from_double (result
);
7694 else if (SCM_COMPLEXP (y
))
7696 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7697 scm_remember_upto_here_1 (x
);
7698 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7699 z
* SCM_COMPLEX_IMAG (y
));
7701 else if (SCM_FRACTIONP (y
))
7702 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7703 SCM_FRACTION_DENOMINATOR (y
));
7705 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7707 else if (SCM_REALP (x
))
7709 if (SCM_I_INUMP (y
))
7714 else if (SCM_BIGP (y
))
7716 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7717 scm_remember_upto_here_1 (y
);
7718 return scm_from_double (result
);
7720 else if (SCM_REALP (y
))
7721 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7722 else if (SCM_COMPLEXP (y
))
7723 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7724 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7725 else if (SCM_FRACTIONP (y
))
7726 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7728 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7730 else if (SCM_COMPLEXP (x
))
7732 if (SCM_I_INUMP (y
))
7737 else if (SCM_BIGP (y
))
7739 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7740 scm_remember_upto_here_1 (y
);
7741 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7742 z
* SCM_COMPLEX_IMAG (x
));
7744 else if (SCM_REALP (y
))
7745 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7746 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7747 else if (SCM_COMPLEXP (y
))
7749 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7750 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7751 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7752 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7754 else if (SCM_FRACTIONP (y
))
7756 double yy
= scm_i_fraction2double (y
);
7757 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7758 yy
* SCM_COMPLEX_IMAG (x
));
7761 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7763 else if (SCM_FRACTIONP (x
))
7765 if (SCM_I_INUMP (y
))
7766 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7767 SCM_FRACTION_DENOMINATOR (x
));
7768 else if (SCM_BIGP (y
))
7769 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7770 SCM_FRACTION_DENOMINATOR (x
));
7771 else if (SCM_REALP (y
))
7772 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7773 else if (SCM_COMPLEXP (y
))
7775 double xx
= scm_i_fraction2double (x
);
7776 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7777 xx
* SCM_COMPLEX_IMAG (y
));
7779 else if (SCM_FRACTIONP (y
))
7780 /* a/b * c/d = ac / bd */
7781 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7782 SCM_FRACTION_NUMERATOR (y
)),
7783 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7784 SCM_FRACTION_DENOMINATOR (y
)));
7786 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7789 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7792 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7793 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7794 #define ALLOW_DIVIDE_BY_ZERO
7795 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7798 /* The code below for complex division is adapted from the GNU
7799 libstdc++, which adapted it from f2c's libF77, and is subject to
7802 /****************************************************************
7803 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7805 Permission to use, copy, modify, and distribute this software
7806 and its documentation for any purpose and without fee is hereby
7807 granted, provided that the above copyright notice appear in all
7808 copies and that both that the copyright notice and this
7809 permission notice and warranty disclaimer appear in supporting
7810 documentation, and that the names of AT&T Bell Laboratories or
7811 Bellcore or any of their entities not be used in advertising or
7812 publicity pertaining to distribution of the software without
7813 specific, written prior permission.
7815 AT&T and Bellcore disclaim all warranties with regard to this
7816 software, including all implied warranties of merchantability
7817 and fitness. In no event shall AT&T or Bellcore be liable for
7818 any special, indirect or consequential damages or any damages
7819 whatsoever resulting from loss of use, data or profits, whether
7820 in an action of contract, negligence or other tortious action,
7821 arising out of or in connection with the use or performance of
7823 ****************************************************************/
7825 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7826 (SCM x
, SCM y
, SCM rest
),
7827 "Divide the first argument by the product of the remaining\n"
7828 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7830 #define FUNC_NAME s_scm_i_divide
7832 while (!scm_is_null (rest
))
7833 { x
= scm_divide (x
, y
);
7835 rest
= scm_cdr (rest
);
7837 return scm_divide (x
, y
);
7841 #define s_divide s_scm_i_divide
7842 #define g_divide g_scm_i_divide
7845 do_divide (SCM x
, SCM y
, int inexact
)
7846 #define FUNC_NAME s_divide
7850 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7853 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7854 else if (SCM_I_INUMP (x
))
7856 scm_t_inum xx
= SCM_I_INUM (x
);
7857 if (xx
== 1 || xx
== -1)
7859 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7861 scm_num_overflow (s_divide
);
7866 return scm_from_double (1.0 / (double) xx
);
7867 else return scm_i_make_ratio (SCM_INUM1
, x
);
7870 else if (SCM_BIGP (x
))
7873 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7874 else return scm_i_make_ratio (SCM_INUM1
, x
);
7876 else if (SCM_REALP (x
))
7878 double xx
= SCM_REAL_VALUE (x
);
7879 #ifndef ALLOW_DIVIDE_BY_ZERO
7881 scm_num_overflow (s_divide
);
7884 return scm_from_double (1.0 / xx
);
7886 else if (SCM_COMPLEXP (x
))
7888 double r
= SCM_COMPLEX_REAL (x
);
7889 double i
= SCM_COMPLEX_IMAG (x
);
7890 if (fabs(r
) <= fabs(i
))
7893 double d
= i
* (1.0 + t
* t
);
7894 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7899 double d
= r
* (1.0 + t
* t
);
7900 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7903 else if (SCM_FRACTIONP (x
))
7904 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7905 SCM_FRACTION_NUMERATOR (x
));
7907 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7910 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7912 scm_t_inum xx
= SCM_I_INUM (x
);
7913 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7915 scm_t_inum yy
= SCM_I_INUM (y
);
7918 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7919 scm_num_overflow (s_divide
);
7921 return scm_from_double ((double) xx
/ (double) yy
);
7924 else if (xx
% yy
!= 0)
7927 return scm_from_double ((double) xx
/ (double) yy
);
7928 else return scm_i_make_ratio (x
, y
);
7932 scm_t_inum z
= xx
/ yy
;
7933 if (SCM_FIXABLE (z
))
7934 return SCM_I_MAKINUM (z
);
7936 return scm_i_inum2big (z
);
7939 else if (SCM_BIGP (y
))
7942 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7943 else return scm_i_make_ratio (x
, y
);
7945 else if (SCM_REALP (y
))
7947 double yy
= SCM_REAL_VALUE (y
);
7948 #ifndef ALLOW_DIVIDE_BY_ZERO
7950 scm_num_overflow (s_divide
);
7953 return scm_from_double ((double) xx
/ yy
);
7955 else if (SCM_COMPLEXP (y
))
7958 complex_div
: /* y _must_ be a complex number */
7960 double r
= SCM_COMPLEX_REAL (y
);
7961 double i
= SCM_COMPLEX_IMAG (y
);
7962 if (fabs(r
) <= fabs(i
))
7965 double d
= i
* (1.0 + t
* t
);
7966 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7971 double d
= r
* (1.0 + t
* t
);
7972 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7976 else if (SCM_FRACTIONP (y
))
7977 /* a / b/c = ac / b */
7978 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7979 SCM_FRACTION_NUMERATOR (y
));
7981 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7983 else if (SCM_BIGP (x
))
7985 if (SCM_I_INUMP (y
))
7987 scm_t_inum yy
= SCM_I_INUM (y
);
7990 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7991 scm_num_overflow (s_divide
);
7993 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7994 scm_remember_upto_here_1 (x
);
7995 return (sgn
== 0) ? scm_nan () : scm_inf ();
8002 /* FIXME: HMM, what are the relative performance issues here?
8003 We need to test. Is it faster on average to test
8004 divisible_p, then perform whichever operation, or is it
8005 faster to perform the integer div opportunistically and
8006 switch to real if there's a remainder? For now we take the
8007 middle ground: test, then if divisible, use the faster div
8010 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8011 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8015 SCM result
= scm_i_mkbig ();
8016 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8017 scm_remember_upto_here_1 (x
);
8019 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8020 return scm_i_normbig (result
);
8025 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
8026 else return scm_i_make_ratio (x
, y
);
8030 else if (SCM_BIGP (y
))
8035 /* It's easily possible for the ratio x/y to fit a double
8036 but one or both x and y be too big to fit a double,
8037 hence the use of mpq_get_d rather than converting and
8040 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8041 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8042 return scm_from_double (mpq_get_d (q
));
8046 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8050 SCM result
= scm_i_mkbig ();
8051 mpz_divexact (SCM_I_BIG_MPZ (result
),
8054 scm_remember_upto_here_2 (x
, y
);
8055 return scm_i_normbig (result
);
8058 return scm_i_make_ratio (x
, y
);
8061 else if (SCM_REALP (y
))
8063 double yy
= SCM_REAL_VALUE (y
);
8064 #ifndef ALLOW_DIVIDE_BY_ZERO
8066 scm_num_overflow (s_divide
);
8069 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8071 else if (SCM_COMPLEXP (y
))
8073 a
= scm_i_big2dbl (x
);
8076 else if (SCM_FRACTIONP (y
))
8077 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8078 SCM_FRACTION_NUMERATOR (y
));
8080 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8082 else if (SCM_REALP (x
))
8084 double rx
= SCM_REAL_VALUE (x
);
8085 if (SCM_I_INUMP (y
))
8087 scm_t_inum yy
= SCM_I_INUM (y
);
8088 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8090 scm_num_overflow (s_divide
);
8093 return scm_from_double (rx
/ (double) yy
);
8095 else if (SCM_BIGP (y
))
8097 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8098 scm_remember_upto_here_1 (y
);
8099 return scm_from_double (rx
/ dby
);
8101 else if (SCM_REALP (y
))
8103 double yy
= SCM_REAL_VALUE (y
);
8104 #ifndef ALLOW_DIVIDE_BY_ZERO
8106 scm_num_overflow (s_divide
);
8109 return scm_from_double (rx
/ yy
);
8111 else if (SCM_COMPLEXP (y
))
8116 else if (SCM_FRACTIONP (y
))
8117 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8119 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8121 else if (SCM_COMPLEXP (x
))
8123 double rx
= SCM_COMPLEX_REAL (x
);
8124 double ix
= SCM_COMPLEX_IMAG (x
);
8125 if (SCM_I_INUMP (y
))
8127 scm_t_inum yy
= SCM_I_INUM (y
);
8128 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8130 scm_num_overflow (s_divide
);
8135 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8138 else if (SCM_BIGP (y
))
8140 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8141 scm_remember_upto_here_1 (y
);
8142 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8144 else if (SCM_REALP (y
))
8146 double yy
= SCM_REAL_VALUE (y
);
8147 #ifndef ALLOW_DIVIDE_BY_ZERO
8149 scm_num_overflow (s_divide
);
8152 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8154 else if (SCM_COMPLEXP (y
))
8156 double ry
= SCM_COMPLEX_REAL (y
);
8157 double iy
= SCM_COMPLEX_IMAG (y
);
8158 if (fabs(ry
) <= fabs(iy
))
8161 double d
= iy
* (1.0 + t
* t
);
8162 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8167 double d
= ry
* (1.0 + t
* t
);
8168 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8171 else if (SCM_FRACTIONP (y
))
8173 double yy
= scm_i_fraction2double (y
);
8174 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8177 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8179 else if (SCM_FRACTIONP (x
))
8181 if (SCM_I_INUMP (y
))
8183 scm_t_inum yy
= SCM_I_INUM (y
);
8184 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8186 scm_num_overflow (s_divide
);
8189 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8190 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8192 else if (SCM_BIGP (y
))
8194 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8195 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8197 else if (SCM_REALP (y
))
8199 double yy
= SCM_REAL_VALUE (y
);
8200 #ifndef ALLOW_DIVIDE_BY_ZERO
8202 scm_num_overflow (s_divide
);
8205 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8207 else if (SCM_COMPLEXP (y
))
8209 a
= scm_i_fraction2double (x
);
8212 else if (SCM_FRACTIONP (y
))
8213 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8214 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8216 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8219 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8223 scm_divide (SCM x
, SCM y
)
8225 return do_divide (x
, y
, 0);
8228 static SCM
scm_divide2real (SCM x
, SCM y
)
8230 return do_divide (x
, y
, 1);
8236 scm_c_truncate (double x
)
8241 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8242 half-way case (ie. when x is an integer plus 0.5) going upwards.
8243 Then half-way cases are identified and adjusted down if the
8244 round-upwards didn't give the desired even integer.
8246 "plus_half == result" identifies a half-way case. If plus_half, which is
8247 x + 0.5, is an integer then x must be an integer plus 0.5.
8249 An odd "result" value is identified with result/2 != floor(result/2).
8250 This is done with plus_half, since that value is ready for use sooner in
8251 a pipelined cpu, and we're already requiring plus_half == result.
8253 Note however that we need to be careful when x is big and already an
8254 integer. In that case "x+0.5" may round to an adjacent integer, causing
8255 us to return such a value, incorrectly. For instance if the hardware is
8256 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8257 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8258 returned. Or if the hardware is in round-upwards mode, then other bigger
8259 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8260 representable value, 2^128+2^76 (or whatever), again incorrect.
8262 These bad roundings of x+0.5 are avoided by testing at the start whether
8263 x is already an integer. If it is then clearly that's the desired result
8264 already. And if it's not then the exponent must be small enough to allow
8265 an 0.5 to be represented, and hence added without a bad rounding. */
8268 scm_c_round (double x
)
8270 double plus_half
, result
;
8275 plus_half
= x
+ 0.5;
8276 result
= floor (plus_half
);
8277 /* Adjust so that the rounding is towards even. */
8278 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8283 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8285 "Round the number @var{x} towards zero.")
8286 #define FUNC_NAME s_scm_truncate_number
8288 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8290 else if (SCM_REALP (x
))
8291 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8292 else if (SCM_FRACTIONP (x
))
8293 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8294 SCM_FRACTION_DENOMINATOR (x
));
8296 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8297 s_scm_truncate_number
);
8301 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8303 "Round the number @var{x} towards the nearest integer. "
8304 "When it is exactly halfway between two integers, "
8305 "round towards the even one.")
8306 #define FUNC_NAME s_scm_round_number
8308 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8310 else if (SCM_REALP (x
))
8311 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8312 else if (SCM_FRACTIONP (x
))
8313 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8314 SCM_FRACTION_DENOMINATOR (x
));
8316 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8317 s_scm_round_number
);
8321 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8323 "Round the number @var{x} towards minus infinity.")
8324 #define FUNC_NAME s_scm_floor
8326 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8328 else if (SCM_REALP (x
))
8329 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8330 else if (SCM_FRACTIONP (x
))
8331 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8332 SCM_FRACTION_DENOMINATOR (x
));
8334 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8338 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8340 "Round the number @var{x} towards infinity.")
8341 #define FUNC_NAME s_scm_ceiling
8343 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8345 else if (SCM_REALP (x
))
8346 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8347 else if (SCM_FRACTIONP (x
))
8348 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8349 SCM_FRACTION_DENOMINATOR (x
));
8351 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8355 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8357 "Return @var{x} raised to the power of @var{y}.")
8358 #define FUNC_NAME s_scm_expt
8360 if (scm_is_integer (y
))
8362 if (scm_is_true (scm_exact_p (y
)))
8363 return scm_integer_expt (x
, y
);
8366 /* Here we handle the case where the exponent is an inexact
8367 integer. We make the exponent exact in order to use
8368 scm_integer_expt, and thus avoid the spurious imaginary
8369 parts that may result from round-off errors in the general
8370 e^(y log x) method below (for example when squaring a large
8371 negative number). In this case, we must return an inexact
8372 result for correctness. We also make the base inexact so
8373 that scm_integer_expt will use fast inexact arithmetic
8374 internally. Note that making the base inexact is not
8375 sufficient to guarantee an inexact result, because
8376 scm_integer_expt will return an exact 1 when the exponent
8377 is 0, even if the base is inexact. */
8378 return scm_exact_to_inexact
8379 (scm_integer_expt (scm_exact_to_inexact (x
),
8380 scm_inexact_to_exact (y
)));
8383 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8385 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8387 else if (scm_is_complex (x
) && scm_is_complex (y
))
8388 return scm_exp (scm_product (scm_log (x
), y
));
8389 else if (scm_is_complex (x
))
8390 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8392 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8396 /* sin/cos/tan/asin/acos/atan
8397 sinh/cosh/tanh/asinh/acosh/atanh
8398 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8399 Written by Jerry D. Hedden, (C) FSF.
8400 See the file `COPYING' for terms applying to this program. */
8402 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8404 "Compute the sine of @var{z}.")
8405 #define FUNC_NAME s_scm_sin
8407 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8408 return z
; /* sin(exact0) = exact0 */
8409 else if (scm_is_real (z
))
8410 return scm_from_double (sin (scm_to_double (z
)));
8411 else if (SCM_COMPLEXP (z
))
8413 x
= SCM_COMPLEX_REAL (z
);
8414 y
= SCM_COMPLEX_IMAG (z
);
8415 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8416 cos (x
) * sinh (y
));
8419 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8423 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8425 "Compute the cosine of @var{z}.")
8426 #define FUNC_NAME s_scm_cos
8428 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8429 return SCM_INUM1
; /* cos(exact0) = exact1 */
8430 else if (scm_is_real (z
))
8431 return scm_from_double (cos (scm_to_double (z
)));
8432 else if (SCM_COMPLEXP (z
))
8434 x
= SCM_COMPLEX_REAL (z
);
8435 y
= SCM_COMPLEX_IMAG (z
);
8436 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8437 -sin (x
) * sinh (y
));
8440 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8444 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8446 "Compute the tangent of @var{z}.")
8447 #define FUNC_NAME s_scm_tan
8449 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8450 return z
; /* tan(exact0) = exact0 */
8451 else if (scm_is_real (z
))
8452 return scm_from_double (tan (scm_to_double (z
)));
8453 else if (SCM_COMPLEXP (z
))
8455 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8456 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8457 w
= cos (x
) + cosh (y
);
8458 #ifndef ALLOW_DIVIDE_BY_ZERO
8460 scm_num_overflow (s_scm_tan
);
8462 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8465 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8469 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8471 "Compute the hyperbolic sine of @var{z}.")
8472 #define FUNC_NAME s_scm_sinh
8474 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8475 return z
; /* sinh(exact0) = exact0 */
8476 else if (scm_is_real (z
))
8477 return scm_from_double (sinh (scm_to_double (z
)));
8478 else if (SCM_COMPLEXP (z
))
8480 x
= SCM_COMPLEX_REAL (z
);
8481 y
= SCM_COMPLEX_IMAG (z
);
8482 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8483 cosh (x
) * sin (y
));
8486 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8490 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8492 "Compute the hyperbolic cosine of @var{z}.")
8493 #define FUNC_NAME s_scm_cosh
8495 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8496 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8497 else if (scm_is_real (z
))
8498 return scm_from_double (cosh (scm_to_double (z
)));
8499 else if (SCM_COMPLEXP (z
))
8501 x
= SCM_COMPLEX_REAL (z
);
8502 y
= SCM_COMPLEX_IMAG (z
);
8503 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8504 sinh (x
) * sin (y
));
8507 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8511 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8513 "Compute the hyperbolic tangent of @var{z}.")
8514 #define FUNC_NAME s_scm_tanh
8516 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8517 return z
; /* tanh(exact0) = exact0 */
8518 else if (scm_is_real (z
))
8519 return scm_from_double (tanh (scm_to_double (z
)));
8520 else if (SCM_COMPLEXP (z
))
8522 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8523 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8524 w
= cosh (x
) + cos (y
);
8525 #ifndef ALLOW_DIVIDE_BY_ZERO
8527 scm_num_overflow (s_scm_tanh
);
8529 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8532 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8536 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8538 "Compute the arc sine of @var{z}.")
8539 #define FUNC_NAME s_scm_asin
8541 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8542 return z
; /* asin(exact0) = exact0 */
8543 else if (scm_is_real (z
))
8545 double w
= scm_to_double (z
);
8546 if (w
>= -1.0 && w
<= 1.0)
8547 return scm_from_double (asin (w
));
8549 return scm_product (scm_c_make_rectangular (0, -1),
8550 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8552 else if (SCM_COMPLEXP (z
))
8554 x
= SCM_COMPLEX_REAL (z
);
8555 y
= SCM_COMPLEX_IMAG (z
);
8556 return scm_product (scm_c_make_rectangular (0, -1),
8557 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8560 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8564 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8566 "Compute the arc cosine of @var{z}.")
8567 #define FUNC_NAME s_scm_acos
8569 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8570 return SCM_INUM0
; /* acos(exact1) = exact0 */
8571 else if (scm_is_real (z
))
8573 double w
= scm_to_double (z
);
8574 if (w
>= -1.0 && w
<= 1.0)
8575 return scm_from_double (acos (w
));
8577 return scm_sum (scm_from_double (acos (0.0)),
8578 scm_product (scm_c_make_rectangular (0, 1),
8579 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8581 else if (SCM_COMPLEXP (z
))
8583 x
= SCM_COMPLEX_REAL (z
);
8584 y
= SCM_COMPLEX_IMAG (z
);
8585 return scm_sum (scm_from_double (acos (0.0)),
8586 scm_product (scm_c_make_rectangular (0, 1),
8587 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8590 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8594 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8596 "With one argument, compute the arc tangent of @var{z}.\n"
8597 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8598 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8599 #define FUNC_NAME s_scm_atan
8603 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8604 return z
; /* atan(exact0) = exact0 */
8605 else if (scm_is_real (z
))
8606 return scm_from_double (atan (scm_to_double (z
)));
8607 else if (SCM_COMPLEXP (z
))
8610 v
= SCM_COMPLEX_REAL (z
);
8611 w
= SCM_COMPLEX_IMAG (z
);
8612 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8613 scm_c_make_rectangular (v
, w
+ 1.0))),
8614 scm_c_make_rectangular (0, 2));
8617 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8619 else if (scm_is_real (z
))
8621 if (scm_is_real (y
))
8622 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8624 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8627 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8631 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8633 "Compute the inverse hyperbolic sine of @var{z}.")
8634 #define FUNC_NAME s_scm_sys_asinh
8636 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8637 return z
; /* asinh(exact0) = exact0 */
8638 else if (scm_is_real (z
))
8639 return scm_from_double (asinh (scm_to_double (z
)));
8640 else if (scm_is_number (z
))
8641 return scm_log (scm_sum (z
,
8642 scm_sqrt (scm_sum (scm_product (z
, z
),
8645 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8649 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8651 "Compute the inverse hyperbolic cosine of @var{z}.")
8652 #define FUNC_NAME s_scm_sys_acosh
8654 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8655 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8656 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8657 return scm_from_double (acosh (scm_to_double (z
)));
8658 else if (scm_is_number (z
))
8659 return scm_log (scm_sum (z
,
8660 scm_sqrt (scm_difference (scm_product (z
, z
),
8663 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8667 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8669 "Compute the inverse hyperbolic tangent of @var{z}.")
8670 #define FUNC_NAME s_scm_sys_atanh
8672 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8673 return z
; /* atanh(exact0) = exact0 */
8674 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8675 return scm_from_double (atanh (scm_to_double (z
)));
8676 else if (scm_is_number (z
))
8677 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8678 scm_difference (SCM_INUM1
, z
))),
8681 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8686 scm_c_make_rectangular (double re
, double im
)
8690 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8692 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8693 SCM_COMPLEX_REAL (z
) = re
;
8694 SCM_COMPLEX_IMAG (z
) = im
;
8698 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8699 (SCM real_part
, SCM imaginary_part
),
8700 "Return a complex number constructed of the given @var{real_part} "
8701 "and @var{imaginary_part} parts.")
8702 #define FUNC_NAME s_scm_make_rectangular
8704 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8705 SCM_ARG1
, FUNC_NAME
, "real");
8706 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8707 SCM_ARG2
, FUNC_NAME
, "real");
8709 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8710 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8713 return scm_c_make_rectangular (scm_to_double (real_part
),
8714 scm_to_double (imaginary_part
));
8719 scm_c_make_polar (double mag
, double ang
)
8723 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8724 use it on Glibc-based systems that have it (it's a GNU extension). See
8725 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8727 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8728 sincos (ang
, &s
, &c
);
8734 /* If s and c are NaNs, this indicates that the angle is a NaN,
8735 infinite, or perhaps simply too large to determine its value
8736 mod 2*pi. However, we know something that the floating-point
8737 implementation doesn't know: We know that s and c are finite.
8738 Therefore, if the magnitude is zero, return a complex zero.
8740 The reason we check for the NaNs instead of using this case
8741 whenever mag == 0.0 is because when the angle is known, we'd
8742 like to return the correct kind of non-real complex zero:
8743 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8744 on which quadrant the angle is in.
8746 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8747 return scm_c_make_rectangular (0.0, 0.0);
8749 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8752 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8754 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8755 #define FUNC_NAME s_scm_make_polar
8757 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8758 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8760 /* If mag is exact0, return exact0 */
8761 if (scm_is_eq (mag
, SCM_INUM0
))
8763 /* Return a real if ang is exact0 */
8764 else if (scm_is_eq (ang
, SCM_INUM0
))
8767 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8772 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8774 "Return the real part of the number @var{z}.")
8775 #define FUNC_NAME s_scm_real_part
8777 if (SCM_COMPLEXP (z
))
8778 return scm_from_double (SCM_COMPLEX_REAL (z
));
8779 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8782 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8787 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8789 "Return the imaginary part of the number @var{z}.")
8790 #define FUNC_NAME s_scm_imag_part
8792 if (SCM_COMPLEXP (z
))
8793 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8794 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8797 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8801 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8803 "Return the numerator of the number @var{z}.")
8804 #define FUNC_NAME s_scm_numerator
8806 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8808 else if (SCM_FRACTIONP (z
))
8809 return SCM_FRACTION_NUMERATOR (z
);
8810 else if (SCM_REALP (z
))
8811 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8813 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8818 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8820 "Return the denominator of the number @var{z}.")
8821 #define FUNC_NAME s_scm_denominator
8823 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8825 else if (SCM_FRACTIONP (z
))
8826 return SCM_FRACTION_DENOMINATOR (z
);
8827 else if (SCM_REALP (z
))
8828 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8830 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8835 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8837 "Return the magnitude of the number @var{z}. This is the same as\n"
8838 "@code{abs} for real arguments, but also allows complex numbers.")
8839 #define FUNC_NAME s_scm_magnitude
8841 if (SCM_I_INUMP (z
))
8843 scm_t_inum zz
= SCM_I_INUM (z
);
8846 else if (SCM_POSFIXABLE (-zz
))
8847 return SCM_I_MAKINUM (-zz
);
8849 return scm_i_inum2big (-zz
);
8851 else if (SCM_BIGP (z
))
8853 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8854 scm_remember_upto_here_1 (z
);
8856 return scm_i_clonebig (z
, 0);
8860 else if (SCM_REALP (z
))
8861 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8862 else if (SCM_COMPLEXP (z
))
8863 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8864 else if (SCM_FRACTIONP (z
))
8866 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8868 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8869 SCM_FRACTION_DENOMINATOR (z
));
8872 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8877 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8879 "Return the angle of the complex number @var{z}.")
8880 #define FUNC_NAME s_scm_angle
8882 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8883 flo0 to save allocating a new flonum with scm_from_double each time.
8884 But if atan2 follows the floating point rounding mode, then the value
8885 is not a constant. Maybe it'd be close enough though. */
8886 if (SCM_I_INUMP (z
))
8888 if (SCM_I_INUM (z
) >= 0)
8891 return scm_from_double (atan2 (0.0, -1.0));
8893 else if (SCM_BIGP (z
))
8895 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8896 scm_remember_upto_here_1 (z
);
8898 return scm_from_double (atan2 (0.0, -1.0));
8902 else if (SCM_REALP (z
))
8904 if (SCM_REAL_VALUE (z
) >= 0)
8907 return scm_from_double (atan2 (0.0, -1.0));
8909 else if (SCM_COMPLEXP (z
))
8910 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8911 else if (SCM_FRACTIONP (z
))
8913 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8915 else return scm_from_double (atan2 (0.0, -1.0));
8918 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8923 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8925 "Convert the number @var{z} to its inexact representation.\n")
8926 #define FUNC_NAME s_scm_exact_to_inexact
8928 if (SCM_I_INUMP (z
))
8929 return scm_from_double ((double) SCM_I_INUM (z
));
8930 else if (SCM_BIGP (z
))
8931 return scm_from_double (scm_i_big2dbl (z
));
8932 else if (SCM_FRACTIONP (z
))
8933 return scm_from_double (scm_i_fraction2double (z
));
8934 else if (SCM_INEXACTP (z
))
8937 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
8942 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8944 "Return an exact number that is numerically closest to @var{z}.")
8945 #define FUNC_NAME s_scm_inexact_to_exact
8947 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8954 val
= SCM_REAL_VALUE (z
);
8955 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8956 val
= SCM_COMPLEX_REAL (z
);
8958 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
8960 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8961 SCM_OUT_OF_RANGE (1, z
);
8968 mpq_set_d (frac
, val
);
8969 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8970 scm_i_mpz2num (mpq_denref (frac
)));
8972 /* When scm_i_make_ratio throws, we leak the memory allocated
8982 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8984 "Returns the @emph{simplest} rational number differing\n"
8985 "from @var{x} by no more than @var{eps}.\n"
8987 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8988 "exact result when both its arguments are exact. Thus, you might need\n"
8989 "to use @code{inexact->exact} on the arguments.\n"
8992 "(rationalize (inexact->exact 1.2) 1/100)\n"
8995 #define FUNC_NAME s_scm_rationalize
8997 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
8998 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
8999 eps
= scm_abs (eps
);
9000 if (scm_is_false (scm_positive_p (eps
)))
9002 /* eps is either zero or a NaN */
9003 if (scm_is_true (scm_nan_p (eps
)))
9005 else if (SCM_INEXACTP (eps
))
9006 return scm_exact_to_inexact (x
);
9010 else if (scm_is_false (scm_finite_p (eps
)))
9012 if (scm_is_true (scm_finite_p (x
)))
9017 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9019 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9020 scm_ceiling (scm_difference (x
, eps
)))))
9022 /* There's an integer within range; we want the one closest to zero */
9023 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9025 /* zero is within range */
9026 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9031 else if (scm_is_true (scm_positive_p (x
)))
9032 return scm_ceiling (scm_difference (x
, eps
));
9034 return scm_floor (scm_sum (x
, eps
));
9038 /* Use continued fractions to find closest ratio. All
9039 arithmetic is done with exact numbers.
9042 SCM ex
= scm_inexact_to_exact (x
);
9043 SCM int_part
= scm_floor (ex
);
9045 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9046 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9050 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9051 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9053 /* We stop after a million iterations just to be absolutely sure
9054 that we don't go into an infinite loop. The process normally
9055 converges after less than a dozen iterations.
9058 while (++i
< 1000000)
9060 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9061 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9062 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9064 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9065 eps
))) /* abs(x-a/b) <= eps */
9067 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9068 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9069 return scm_exact_to_inexact (res
);
9073 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9075 tt
= scm_floor (rx
); /* tt = floor (rx) */
9081 scm_num_overflow (s_scm_rationalize
);
9086 /* conversion functions */
9089 scm_is_integer (SCM val
)
9091 return scm_is_true (scm_integer_p (val
));
9095 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9097 if (SCM_I_INUMP (val
))
9099 scm_t_signed_bits n
= SCM_I_INUM (val
);
9100 return n
>= min
&& n
<= max
;
9102 else if (SCM_BIGP (val
))
9104 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9106 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9108 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9110 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9111 return n
>= min
&& n
<= max
;
9121 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9122 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9125 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9126 SCM_I_BIG_MPZ (val
));
9128 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9140 return n
>= min
&& n
<= max
;
9148 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9150 if (SCM_I_INUMP (val
))
9152 scm_t_signed_bits n
= SCM_I_INUM (val
);
9153 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9155 else if (SCM_BIGP (val
))
9157 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9159 else if (max
<= ULONG_MAX
)
9161 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9163 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9164 return n
>= min
&& n
<= max
;
9174 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9177 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9178 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9181 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9182 SCM_I_BIG_MPZ (val
));
9184 return n
>= min
&& n
<= max
;
9192 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9194 scm_error (scm_out_of_range_key
,
9196 "Value out of range ~S to ~S: ~S",
9197 scm_list_3 (min
, max
, bad_val
),
9198 scm_list_1 (bad_val
));
9201 #define TYPE scm_t_intmax
9202 #define TYPE_MIN min
9203 #define TYPE_MAX max
9204 #define SIZEOF_TYPE 0
9205 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9206 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9207 #include "libguile/conv-integer.i.c"
9209 #define TYPE scm_t_uintmax
9210 #define TYPE_MIN min
9211 #define TYPE_MAX max
9212 #define SIZEOF_TYPE 0
9213 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9214 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9215 #include "libguile/conv-uinteger.i.c"
9217 #define TYPE scm_t_int8
9218 #define TYPE_MIN SCM_T_INT8_MIN
9219 #define TYPE_MAX SCM_T_INT8_MAX
9220 #define SIZEOF_TYPE 1
9221 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9222 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9223 #include "libguile/conv-integer.i.c"
9225 #define TYPE scm_t_uint8
9227 #define TYPE_MAX SCM_T_UINT8_MAX
9228 #define SIZEOF_TYPE 1
9229 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9230 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9231 #include "libguile/conv-uinteger.i.c"
9233 #define TYPE scm_t_int16
9234 #define TYPE_MIN SCM_T_INT16_MIN
9235 #define TYPE_MAX SCM_T_INT16_MAX
9236 #define SIZEOF_TYPE 2
9237 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9238 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9239 #include "libguile/conv-integer.i.c"
9241 #define TYPE scm_t_uint16
9243 #define TYPE_MAX SCM_T_UINT16_MAX
9244 #define SIZEOF_TYPE 2
9245 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9246 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9247 #include "libguile/conv-uinteger.i.c"
9249 #define TYPE scm_t_int32
9250 #define TYPE_MIN SCM_T_INT32_MIN
9251 #define TYPE_MAX SCM_T_INT32_MAX
9252 #define SIZEOF_TYPE 4
9253 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9254 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9255 #include "libguile/conv-integer.i.c"
9257 #define TYPE scm_t_uint32
9259 #define TYPE_MAX SCM_T_UINT32_MAX
9260 #define SIZEOF_TYPE 4
9261 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9262 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9263 #include "libguile/conv-uinteger.i.c"
9265 #define TYPE scm_t_wchar
9266 #define TYPE_MIN (scm_t_int32)-1
9267 #define TYPE_MAX (scm_t_int32)0x10ffff
9268 #define SIZEOF_TYPE 4
9269 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9270 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9271 #include "libguile/conv-integer.i.c"
9273 #define TYPE scm_t_int64
9274 #define TYPE_MIN SCM_T_INT64_MIN
9275 #define TYPE_MAX SCM_T_INT64_MAX
9276 #define SIZEOF_TYPE 8
9277 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9278 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9279 #include "libguile/conv-integer.i.c"
9281 #define TYPE scm_t_uint64
9283 #define TYPE_MAX SCM_T_UINT64_MAX
9284 #define SIZEOF_TYPE 8
9285 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9286 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9287 #include "libguile/conv-uinteger.i.c"
9290 scm_to_mpz (SCM val
, mpz_t rop
)
9292 if (SCM_I_INUMP (val
))
9293 mpz_set_si (rop
, SCM_I_INUM (val
));
9294 else if (SCM_BIGP (val
))
9295 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9297 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9301 scm_from_mpz (mpz_t val
)
9303 return scm_i_mpz2num (val
);
9307 scm_is_real (SCM val
)
9309 return scm_is_true (scm_real_p (val
));
9313 scm_is_rational (SCM val
)
9315 return scm_is_true (scm_rational_p (val
));
9319 scm_to_double (SCM val
)
9321 if (SCM_I_INUMP (val
))
9322 return SCM_I_INUM (val
);
9323 else if (SCM_BIGP (val
))
9324 return scm_i_big2dbl (val
);
9325 else if (SCM_FRACTIONP (val
))
9326 return scm_i_fraction2double (val
);
9327 else if (SCM_REALP (val
))
9328 return SCM_REAL_VALUE (val
);
9330 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9334 scm_from_double (double val
)
9338 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9340 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9341 SCM_REAL_VALUE (z
) = val
;
9346 #if SCM_ENABLE_DEPRECATED == 1
9349 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9351 scm_c_issue_deprecation_warning
9352 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9356 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9360 scm_out_of_range (NULL
, num
);
9363 return scm_to_double (num
);
9367 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9369 scm_c_issue_deprecation_warning
9370 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9374 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9378 scm_out_of_range (NULL
, num
);
9381 return scm_to_double (num
);
9387 scm_is_complex (SCM val
)
9389 return scm_is_true (scm_complex_p (val
));
9393 scm_c_real_part (SCM z
)
9395 if (SCM_COMPLEXP (z
))
9396 return SCM_COMPLEX_REAL (z
);
9399 /* Use the scm_real_part to get proper error checking and
9402 return scm_to_double (scm_real_part (z
));
9407 scm_c_imag_part (SCM z
)
9409 if (SCM_COMPLEXP (z
))
9410 return SCM_COMPLEX_IMAG (z
);
9413 /* Use the scm_imag_part to get proper error checking and
9414 dispatching. The result will almost always be 0.0, but not
9417 return scm_to_double (scm_imag_part (z
));
9422 scm_c_magnitude (SCM z
)
9424 return scm_to_double (scm_magnitude (z
));
9430 return scm_to_double (scm_angle (z
));
9434 scm_is_number (SCM z
)
9436 return scm_is_true (scm_number_p (z
));
9440 /* Returns log(x * 2^shift) */
9442 log_of_shifted_double (double x
, long shift
)
9444 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9446 if (x
> 0.0 || double_is_non_negative_zero (x
))
9447 return scm_from_double (ans
);
9449 return scm_c_make_rectangular (ans
, M_PI
);
9452 /* Returns log(n), for exact integer n of integer-length size */
9454 log_of_exact_integer_with_size (SCM n
, long size
)
9456 long shift
= size
- 2 * scm_dblprec
[0];
9459 return log_of_shifted_double
9460 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9463 return log_of_shifted_double (scm_to_double (n
), 0);
9466 /* Returns log(n), for exact integer n */
9468 log_of_exact_integer (SCM n
)
9470 return log_of_exact_integer_with_size
9471 (n
, scm_to_long (scm_integer_length (n
)));
9474 /* Returns log(n/d), for exact non-zero integers n and d */
9476 log_of_fraction (SCM n
, SCM d
)
9478 long n_size
= scm_to_long (scm_integer_length (n
));
9479 long d_size
= scm_to_long (scm_integer_length (d
));
9481 if (abs (n_size
- d_size
) > 1)
9482 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9483 log_of_exact_integer_with_size (d
, d_size
)));
9484 else if (scm_is_false (scm_negative_p (n
)))
9485 return scm_from_double
9486 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9488 return scm_c_make_rectangular
9489 (log1p (scm_to_double (scm_divide2real
9490 (scm_difference (scm_abs (n
), d
),
9496 /* In the following functions we dispatch to the real-arg funcs like log()
9497 when we know the arg is real, instead of just handing everything to
9498 clog() for instance. This is in case clog() doesn't optimize for a
9499 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9500 well use it to go straight to the applicable C func. */
9502 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9504 "Return the natural logarithm of @var{z}.")
9505 #define FUNC_NAME s_scm_log
9507 if (SCM_COMPLEXP (z
))
9509 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9510 && defined (SCM_COMPLEX_VALUE)
9511 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9513 double re
= SCM_COMPLEX_REAL (z
);
9514 double im
= SCM_COMPLEX_IMAG (z
);
9515 return scm_c_make_rectangular (log (hypot (re
, im
)),
9519 else if (SCM_REALP (z
))
9520 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9521 else if (SCM_I_INUMP (z
))
9523 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9524 if (scm_is_eq (z
, SCM_INUM0
))
9525 scm_num_overflow (s_scm_log
);
9527 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9529 else if (SCM_BIGP (z
))
9530 return log_of_exact_integer (z
);
9531 else if (SCM_FRACTIONP (z
))
9532 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9533 SCM_FRACTION_DENOMINATOR (z
));
9535 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9540 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9542 "Return the base 10 logarithm of @var{z}.")
9543 #define FUNC_NAME s_scm_log10
9545 if (SCM_COMPLEXP (z
))
9547 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9548 clog() and a multiply by M_LOG10E, rather than the fallback
9549 log10+hypot+atan2.) */
9550 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9551 && defined SCM_COMPLEX_VALUE
9552 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9554 double re
= SCM_COMPLEX_REAL (z
);
9555 double im
= SCM_COMPLEX_IMAG (z
);
9556 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9557 M_LOG10E
* atan2 (im
, re
));
9560 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9562 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9563 if (scm_is_eq (z
, SCM_INUM0
))
9564 scm_num_overflow (s_scm_log10
);
9567 double re
= scm_to_double (z
);
9568 double l
= log10 (fabs (re
));
9569 if (re
> 0.0 || double_is_non_negative_zero (re
))
9570 return scm_from_double (l
);
9572 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9575 else if (SCM_BIGP (z
))
9576 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9577 else if (SCM_FRACTIONP (z
))
9578 return scm_product (flo_log10e
,
9579 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9580 SCM_FRACTION_DENOMINATOR (z
)));
9582 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9587 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9589 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9590 "base of natural logarithms (2.71828@dots{}).")
9591 #define FUNC_NAME s_scm_exp
9593 if (SCM_COMPLEXP (z
))
9595 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9596 && defined (SCM_COMPLEX_VALUE)
9597 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9599 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9600 SCM_COMPLEX_IMAG (z
));
9603 else if (SCM_NUMBERP (z
))
9605 /* When z is a negative bignum the conversion to double overflows,
9606 giving -infinity, but that's ok, the exp is still 0.0. */
9607 return scm_from_double (exp (scm_to_double (z
)));
9610 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9615 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9617 "Return two exact non-negative integers @var{s} and @var{r}\n"
9618 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9619 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9620 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9623 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9625 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9629 scm_exact_integer_sqrt (k
, &s
, &r
);
9630 return scm_values (scm_list_2 (s
, r
));
9635 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9637 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9639 scm_t_inum kk
= SCM_I_INUM (k
);
9643 if (SCM_LIKELY (kk
> 0))
9648 uu
= (ss
+ kk
/ss
) / 2;
9650 *sp
= SCM_I_MAKINUM (ss
);
9651 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9653 else if (SCM_LIKELY (kk
== 0))
9654 *sp
= *rp
= SCM_INUM0
;
9656 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9657 "exact non-negative integer");
9659 else if (SCM_LIKELY (SCM_BIGP (k
)))
9663 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9664 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9665 "exact non-negative integer");
9668 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9669 scm_remember_upto_here_1 (k
);
9670 *sp
= scm_i_normbig (s
);
9671 *rp
= scm_i_normbig (r
);
9674 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9675 "exact non-negative integer");
9679 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9681 "Return the square root of @var{z}. Of the two possible roots\n"
9682 "(positive and negative), the one with positive real part\n"
9683 "is returned, or if that's zero then a positive imaginary part.\n"
9687 "(sqrt 9.0) @result{} 3.0\n"
9688 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9689 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9690 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9692 #define FUNC_NAME s_scm_sqrt
9694 if (SCM_COMPLEXP (z
))
9696 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9697 && defined SCM_COMPLEX_VALUE
9698 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9700 double re
= SCM_COMPLEX_REAL (z
);
9701 double im
= SCM_COMPLEX_IMAG (z
);
9702 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9703 0.5 * atan2 (im
, re
));
9706 else if (SCM_NUMBERP (z
))
9708 double xx
= scm_to_double (z
);
9710 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9712 return scm_from_double (sqrt (xx
));
9715 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9726 if (scm_install_gmp_memory_functions
)
9727 mp_set_memory_functions (custom_gmp_malloc
,
9731 mpz_init_set_si (z_negative_one
, -1);
9733 /* It may be possible to tune the performance of some algorithms by using
9734 * the following constants to avoid the creation of bignums. Please, before
9735 * using these values, remember the two rules of program optimization:
9736 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9737 scm_c_define ("most-positive-fixnum",
9738 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9739 scm_c_define ("most-negative-fixnum",
9740 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9742 scm_add_feature ("complex");
9743 scm_add_feature ("inexact");
9744 flo0
= scm_from_double (0.0);
9745 flo_log10e
= scm_from_double (M_LOG10E
);
9747 /* determine floating point precision */
9748 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9750 init_dblprec(&scm_dblprec
[i
-2],i
);
9751 init_fx_radix(fx_per_radix
[i
-2],i
);
9754 /* hard code precision for base 10 if the preprocessor tells us to... */
9755 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9758 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9759 #include "libguile/numbers.x"