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
= SCM_PACK_POINTER (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 return 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 return 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 return 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 return 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 return 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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
845 return 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 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
866 return 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 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
888 return 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
)
909 SCM vals
= scm_wta_dispatch_2 (gf
, a1
, a2
, pos
, subr
);
911 scm_i_extract_values_2 (vals
, rp1
, rp2
);
914 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
916 "Return the integer @var{q} such that\n"
917 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
918 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
920 "(euclidean-quotient 123 10) @result{} 12\n"
921 "(euclidean-quotient 123 -10) @result{} -12\n"
922 "(euclidean-quotient -123 10) @result{} -13\n"
923 "(euclidean-quotient -123 -10) @result{} 13\n"
924 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
925 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
927 #define FUNC_NAME s_scm_euclidean_quotient
929 if (scm_is_false (scm_negative_p (y
)))
930 return scm_floor_quotient (x
, y
);
932 return scm_ceiling_quotient (x
, y
);
936 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
938 "Return the real number @var{r} such that\n"
939 "@math{0 <= @var{r} < abs(@var{y})} and\n"
940 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
941 "for some integer @var{q}.\n"
943 "(euclidean-remainder 123 10) @result{} 3\n"
944 "(euclidean-remainder 123 -10) @result{} 3\n"
945 "(euclidean-remainder -123 10) @result{} 7\n"
946 "(euclidean-remainder -123 -10) @result{} 7\n"
947 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
948 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
950 #define FUNC_NAME s_scm_euclidean_remainder
952 if (scm_is_false (scm_negative_p (y
)))
953 return scm_floor_remainder (x
, y
);
955 return scm_ceiling_remainder (x
, y
);
959 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
961 "Return the integer @var{q} and the real number @var{r}\n"
962 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
963 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
965 "(euclidean/ 123 10) @result{} 12 and 3\n"
966 "(euclidean/ 123 -10) @result{} -12 and 3\n"
967 "(euclidean/ -123 10) @result{} -13 and 7\n"
968 "(euclidean/ -123 -10) @result{} 13 and 7\n"
969 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
970 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
972 #define FUNC_NAME s_scm_i_euclidean_divide
974 if (scm_is_false (scm_negative_p (y
)))
975 return scm_i_floor_divide (x
, y
);
977 return scm_i_ceiling_divide (x
, y
);
982 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
984 if (scm_is_false (scm_negative_p (y
)))
985 return scm_floor_divide (x
, y
, qp
, rp
);
987 return scm_ceiling_divide (x
, y
, qp
, rp
);
990 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
991 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
993 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
995 "Return the floor of @math{@var{x} / @var{y}}.\n"
997 "(floor-quotient 123 10) @result{} 12\n"
998 "(floor-quotient 123 -10) @result{} -13\n"
999 "(floor-quotient -123 10) @result{} -13\n"
1000 "(floor-quotient -123 -10) @result{} 12\n"
1001 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1002 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1004 #define FUNC_NAME s_scm_floor_quotient
1006 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1008 scm_t_inum xx
= SCM_I_INUM (x
);
1009 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1011 scm_t_inum yy
= SCM_I_INUM (y
);
1012 scm_t_inum xx1
= xx
;
1014 if (SCM_LIKELY (yy
> 0))
1016 if (SCM_UNLIKELY (xx
< 0))
1019 else if (SCM_UNLIKELY (yy
== 0))
1020 scm_num_overflow (s_scm_floor_quotient
);
1024 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1025 return SCM_I_MAKINUM (qq
);
1027 return scm_i_inum2big (qq
);
1029 else if (SCM_BIGP (y
))
1031 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1032 scm_remember_upto_here_1 (y
);
1034 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1036 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1038 else if (SCM_REALP (y
))
1039 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1040 else if (SCM_FRACTIONP (y
))
1041 return scm_i_exact_rational_floor_quotient (x
, y
);
1043 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1044 s_scm_floor_quotient
);
1046 else if (SCM_BIGP (x
))
1048 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1050 scm_t_inum yy
= SCM_I_INUM (y
);
1051 if (SCM_UNLIKELY (yy
== 0))
1052 scm_num_overflow (s_scm_floor_quotient
);
1053 else if (SCM_UNLIKELY (yy
== 1))
1057 SCM q
= scm_i_mkbig ();
1059 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1062 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1063 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1065 scm_remember_upto_here_1 (x
);
1066 return scm_i_normbig (q
);
1069 else if (SCM_BIGP (y
))
1071 SCM q
= scm_i_mkbig ();
1072 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1075 scm_remember_upto_here_2 (x
, y
);
1076 return scm_i_normbig (q
);
1078 else if (SCM_REALP (y
))
1079 return scm_i_inexact_floor_quotient
1080 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1081 else if (SCM_FRACTIONP (y
))
1082 return scm_i_exact_rational_floor_quotient (x
, y
);
1084 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1085 s_scm_floor_quotient
);
1087 else if (SCM_REALP (x
))
1089 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1090 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1091 return scm_i_inexact_floor_quotient
1092 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1094 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1095 s_scm_floor_quotient
);
1097 else if (SCM_FRACTIONP (x
))
1100 return scm_i_inexact_floor_quotient
1101 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1102 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1103 return scm_i_exact_rational_floor_quotient (x
, y
);
1105 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1106 s_scm_floor_quotient
);
1109 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1110 s_scm_floor_quotient
);
1115 scm_i_inexact_floor_quotient (double x
, double y
)
1117 if (SCM_UNLIKELY (y
== 0))
1118 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1120 return scm_from_double (floor (x
/ y
));
1124 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1126 return scm_floor_quotient
1127 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1128 scm_product (scm_numerator (y
), scm_denominator (x
)));
1131 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1132 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1134 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1136 "Return the real number @var{r} such that\n"
1137 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1138 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1140 "(floor-remainder 123 10) @result{} 3\n"
1141 "(floor-remainder 123 -10) @result{} -7\n"
1142 "(floor-remainder -123 10) @result{} 7\n"
1143 "(floor-remainder -123 -10) @result{} -3\n"
1144 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1145 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1147 #define FUNC_NAME s_scm_floor_remainder
1149 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1151 scm_t_inum xx
= SCM_I_INUM (x
);
1152 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1154 scm_t_inum yy
= SCM_I_INUM (y
);
1155 if (SCM_UNLIKELY (yy
== 0))
1156 scm_num_overflow (s_scm_floor_remainder
);
1159 scm_t_inum rr
= xx
% yy
;
1160 int needs_adjustment
;
1162 if (SCM_LIKELY (yy
> 0))
1163 needs_adjustment
= (rr
< 0);
1165 needs_adjustment
= (rr
> 0);
1167 if (needs_adjustment
)
1169 return SCM_I_MAKINUM (rr
);
1172 else if (SCM_BIGP (y
))
1174 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1175 scm_remember_upto_here_1 (y
);
1180 SCM r
= scm_i_mkbig ();
1181 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1182 scm_remember_upto_here_1 (y
);
1183 return scm_i_normbig (r
);
1192 SCM r
= scm_i_mkbig ();
1193 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1194 scm_remember_upto_here_1 (y
);
1195 return scm_i_normbig (r
);
1198 else if (SCM_REALP (y
))
1199 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1200 else if (SCM_FRACTIONP (y
))
1201 return scm_i_exact_rational_floor_remainder (x
, y
);
1203 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1204 s_scm_floor_remainder
);
1206 else if (SCM_BIGP (x
))
1208 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1210 scm_t_inum yy
= SCM_I_INUM (y
);
1211 if (SCM_UNLIKELY (yy
== 0))
1212 scm_num_overflow (s_scm_floor_remainder
);
1217 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1219 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1220 scm_remember_upto_here_1 (x
);
1221 return SCM_I_MAKINUM (rr
);
1224 else if (SCM_BIGP (y
))
1226 SCM r
= scm_i_mkbig ();
1227 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1230 scm_remember_upto_here_2 (x
, y
);
1231 return scm_i_normbig (r
);
1233 else if (SCM_REALP (y
))
1234 return scm_i_inexact_floor_remainder
1235 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1236 else if (SCM_FRACTIONP (y
))
1237 return scm_i_exact_rational_floor_remainder (x
, y
);
1239 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1240 s_scm_floor_remainder
);
1242 else if (SCM_REALP (x
))
1244 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1245 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1246 return scm_i_inexact_floor_remainder
1247 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1249 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1250 s_scm_floor_remainder
);
1252 else if (SCM_FRACTIONP (x
))
1255 return scm_i_inexact_floor_remainder
1256 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1257 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1258 return scm_i_exact_rational_floor_remainder (x
, y
);
1260 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1261 s_scm_floor_remainder
);
1264 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1265 s_scm_floor_remainder
);
1270 scm_i_inexact_floor_remainder (double x
, double y
)
1272 /* Although it would be more efficient to use fmod here, we can't
1273 because it would in some cases produce results inconsistent with
1274 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1275 close). In particular, when x is very close to a multiple of y,
1276 then r might be either 0.0 or y, but those two cases must
1277 correspond to different choices of q. If r = 0.0 then q must be
1278 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1279 and remainder chooses the other, it would be bad. */
1280 if (SCM_UNLIKELY (y
== 0))
1281 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1283 return scm_from_double (x
- y
* floor (x
/ y
));
1287 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1289 SCM xd
= scm_denominator (x
);
1290 SCM yd
= scm_denominator (y
);
1291 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1292 scm_product (scm_numerator (y
), xd
));
1293 return scm_divide (r1
, scm_product (xd
, yd
));
1297 static void scm_i_inexact_floor_divide (double x
, double y
,
1299 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1302 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1304 "Return the integer @var{q} and the real number @var{r}\n"
1305 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1306 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1308 "(floor/ 123 10) @result{} 12 and 3\n"
1309 "(floor/ 123 -10) @result{} -13 and -7\n"
1310 "(floor/ -123 10) @result{} -13 and 7\n"
1311 "(floor/ -123 -10) @result{} 12 and -3\n"
1312 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1313 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1315 #define FUNC_NAME s_scm_i_floor_divide
1319 scm_floor_divide(x
, y
, &q
, &r
);
1320 return scm_values (scm_list_2 (q
, r
));
1324 #define s_scm_floor_divide s_scm_i_floor_divide
1325 #define g_scm_floor_divide g_scm_i_floor_divide
1328 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1330 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1332 scm_t_inum xx
= SCM_I_INUM (x
);
1333 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1335 scm_t_inum yy
= SCM_I_INUM (y
);
1336 if (SCM_UNLIKELY (yy
== 0))
1337 scm_num_overflow (s_scm_floor_divide
);
1340 scm_t_inum qq
= xx
/ yy
;
1341 scm_t_inum rr
= xx
% yy
;
1342 int needs_adjustment
;
1344 if (SCM_LIKELY (yy
> 0))
1345 needs_adjustment
= (rr
< 0);
1347 needs_adjustment
= (rr
> 0);
1349 if (needs_adjustment
)
1355 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1356 *qp
= SCM_I_MAKINUM (qq
);
1358 *qp
= scm_i_inum2big (qq
);
1359 *rp
= SCM_I_MAKINUM (rr
);
1363 else if (SCM_BIGP (y
))
1365 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1366 scm_remember_upto_here_1 (y
);
1371 SCM r
= scm_i_mkbig ();
1372 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1373 scm_remember_upto_here_1 (y
);
1374 *qp
= SCM_I_MAKINUM (-1);
1375 *rp
= scm_i_normbig (r
);
1390 SCM r
= scm_i_mkbig ();
1391 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1392 scm_remember_upto_here_1 (y
);
1393 *qp
= SCM_I_MAKINUM (-1);
1394 *rp
= scm_i_normbig (r
);
1398 else if (SCM_REALP (y
))
1399 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1400 else if (SCM_FRACTIONP (y
))
1401 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1403 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1404 s_scm_floor_divide
, qp
, rp
);
1406 else if (SCM_BIGP (x
))
1408 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1410 scm_t_inum yy
= SCM_I_INUM (y
);
1411 if (SCM_UNLIKELY (yy
== 0))
1412 scm_num_overflow (s_scm_floor_divide
);
1415 SCM q
= scm_i_mkbig ();
1416 SCM r
= scm_i_mkbig ();
1418 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1419 SCM_I_BIG_MPZ (x
), yy
);
1422 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1423 SCM_I_BIG_MPZ (x
), -yy
);
1424 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1426 scm_remember_upto_here_1 (x
);
1427 *qp
= scm_i_normbig (q
);
1428 *rp
= scm_i_normbig (r
);
1432 else if (SCM_BIGP (y
))
1434 SCM q
= scm_i_mkbig ();
1435 SCM r
= scm_i_mkbig ();
1436 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1437 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1438 scm_remember_upto_here_2 (x
, y
);
1439 *qp
= scm_i_normbig (q
);
1440 *rp
= scm_i_normbig (r
);
1443 else if (SCM_REALP (y
))
1444 return scm_i_inexact_floor_divide
1445 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1446 else if (SCM_FRACTIONP (y
))
1447 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1449 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1450 s_scm_floor_divide
, qp
, rp
);
1452 else if (SCM_REALP (x
))
1454 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1455 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1456 return scm_i_inexact_floor_divide
1457 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1459 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1460 s_scm_floor_divide
, qp
, rp
);
1462 else if (SCM_FRACTIONP (x
))
1465 return scm_i_inexact_floor_divide
1466 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1467 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1468 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1470 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1471 s_scm_floor_divide
, qp
, rp
);
1474 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1475 s_scm_floor_divide
, qp
, rp
);
1479 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1481 if (SCM_UNLIKELY (y
== 0))
1482 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1485 double q
= floor (x
/ y
);
1486 double r
= x
- q
* y
;
1487 *qp
= scm_from_double (q
);
1488 *rp
= scm_from_double (r
);
1493 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1496 SCM xd
= scm_denominator (x
);
1497 SCM yd
= scm_denominator (y
);
1499 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1500 scm_product (scm_numerator (y
), xd
),
1502 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1505 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1506 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1508 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1510 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1512 "(ceiling-quotient 123 10) @result{} 13\n"
1513 "(ceiling-quotient 123 -10) @result{} -12\n"
1514 "(ceiling-quotient -123 10) @result{} -12\n"
1515 "(ceiling-quotient -123 -10) @result{} 13\n"
1516 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1517 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1519 #define FUNC_NAME s_scm_ceiling_quotient
1521 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1523 scm_t_inum xx
= SCM_I_INUM (x
);
1524 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1526 scm_t_inum yy
= SCM_I_INUM (y
);
1527 if (SCM_UNLIKELY (yy
== 0))
1528 scm_num_overflow (s_scm_ceiling_quotient
);
1531 scm_t_inum xx1
= xx
;
1533 if (SCM_LIKELY (yy
> 0))
1535 if (SCM_LIKELY (xx
>= 0))
1541 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1542 return SCM_I_MAKINUM (qq
);
1544 return scm_i_inum2big (qq
);
1547 else if (SCM_BIGP (y
))
1549 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1550 scm_remember_upto_here_1 (y
);
1551 if (SCM_LIKELY (sign
> 0))
1553 if (SCM_LIKELY (xx
> 0))
1555 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1556 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1557 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1559 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1560 scm_remember_upto_here_1 (y
);
1561 return SCM_I_MAKINUM (-1);
1571 else if (SCM_REALP (y
))
1572 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1573 else if (SCM_FRACTIONP (y
))
1574 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1576 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1577 s_scm_ceiling_quotient
);
1579 else if (SCM_BIGP (x
))
1581 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1583 scm_t_inum yy
= SCM_I_INUM (y
);
1584 if (SCM_UNLIKELY (yy
== 0))
1585 scm_num_overflow (s_scm_ceiling_quotient
);
1586 else if (SCM_UNLIKELY (yy
== 1))
1590 SCM q
= scm_i_mkbig ();
1592 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1595 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1596 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1598 scm_remember_upto_here_1 (x
);
1599 return scm_i_normbig (q
);
1602 else if (SCM_BIGP (y
))
1604 SCM q
= scm_i_mkbig ();
1605 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1608 scm_remember_upto_here_2 (x
, y
);
1609 return scm_i_normbig (q
);
1611 else if (SCM_REALP (y
))
1612 return scm_i_inexact_ceiling_quotient
1613 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1614 else if (SCM_FRACTIONP (y
))
1615 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1617 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1618 s_scm_ceiling_quotient
);
1620 else if (SCM_REALP (x
))
1622 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1623 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1624 return scm_i_inexact_ceiling_quotient
1625 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1627 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1628 s_scm_ceiling_quotient
);
1630 else if (SCM_FRACTIONP (x
))
1633 return scm_i_inexact_ceiling_quotient
1634 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1635 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1636 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1638 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1639 s_scm_ceiling_quotient
);
1642 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1643 s_scm_ceiling_quotient
);
1648 scm_i_inexact_ceiling_quotient (double x
, double y
)
1650 if (SCM_UNLIKELY (y
== 0))
1651 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1653 return scm_from_double (ceil (x
/ y
));
1657 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1659 return scm_ceiling_quotient
1660 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1661 scm_product (scm_numerator (y
), scm_denominator (x
)));
1664 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1665 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1667 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1669 "Return the real number @var{r} such that\n"
1670 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1671 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1673 "(ceiling-remainder 123 10) @result{} -7\n"
1674 "(ceiling-remainder 123 -10) @result{} 3\n"
1675 "(ceiling-remainder -123 10) @result{} -3\n"
1676 "(ceiling-remainder -123 -10) @result{} 7\n"
1677 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1678 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1680 #define FUNC_NAME s_scm_ceiling_remainder
1682 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1684 scm_t_inum xx
= SCM_I_INUM (x
);
1685 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1687 scm_t_inum yy
= SCM_I_INUM (y
);
1688 if (SCM_UNLIKELY (yy
== 0))
1689 scm_num_overflow (s_scm_ceiling_remainder
);
1692 scm_t_inum rr
= xx
% yy
;
1693 int needs_adjustment
;
1695 if (SCM_LIKELY (yy
> 0))
1696 needs_adjustment
= (rr
> 0);
1698 needs_adjustment
= (rr
< 0);
1700 if (needs_adjustment
)
1702 return SCM_I_MAKINUM (rr
);
1705 else if (SCM_BIGP (y
))
1707 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1708 scm_remember_upto_here_1 (y
);
1709 if (SCM_LIKELY (sign
> 0))
1711 if (SCM_LIKELY (xx
> 0))
1713 SCM r
= scm_i_mkbig ();
1714 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1715 scm_remember_upto_here_1 (y
);
1716 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1717 return scm_i_normbig (r
);
1719 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1720 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1721 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1723 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1724 scm_remember_upto_here_1 (y
);
1734 SCM r
= scm_i_mkbig ();
1735 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1736 scm_remember_upto_here_1 (y
);
1737 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1738 return scm_i_normbig (r
);
1741 else if (SCM_REALP (y
))
1742 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1743 else if (SCM_FRACTIONP (y
))
1744 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1746 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1747 s_scm_ceiling_remainder
);
1749 else if (SCM_BIGP (x
))
1751 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1753 scm_t_inum yy
= SCM_I_INUM (y
);
1754 if (SCM_UNLIKELY (yy
== 0))
1755 scm_num_overflow (s_scm_ceiling_remainder
);
1760 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1762 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1763 scm_remember_upto_here_1 (x
);
1764 return SCM_I_MAKINUM (rr
);
1767 else if (SCM_BIGP (y
))
1769 SCM r
= scm_i_mkbig ();
1770 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1773 scm_remember_upto_here_2 (x
, y
);
1774 return scm_i_normbig (r
);
1776 else if (SCM_REALP (y
))
1777 return scm_i_inexact_ceiling_remainder
1778 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1779 else if (SCM_FRACTIONP (y
))
1780 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1782 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1783 s_scm_ceiling_remainder
);
1785 else if (SCM_REALP (x
))
1787 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1788 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1789 return scm_i_inexact_ceiling_remainder
1790 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1792 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1793 s_scm_ceiling_remainder
);
1795 else if (SCM_FRACTIONP (x
))
1798 return scm_i_inexact_ceiling_remainder
1799 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1800 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1801 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1803 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1804 s_scm_ceiling_remainder
);
1807 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1808 s_scm_ceiling_remainder
);
1813 scm_i_inexact_ceiling_remainder (double x
, double y
)
1815 /* Although it would be more efficient to use fmod here, we can't
1816 because it would in some cases produce results inconsistent with
1817 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1818 close). In particular, when x is very close to a multiple of y,
1819 then r might be either 0.0 or -y, but those two cases must
1820 correspond to different choices of q. If r = 0.0 then q must be
1821 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1822 and remainder chooses the other, it would be bad. */
1823 if (SCM_UNLIKELY (y
== 0))
1824 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1826 return scm_from_double (x
- y
* ceil (x
/ y
));
1830 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1832 SCM xd
= scm_denominator (x
);
1833 SCM yd
= scm_denominator (y
);
1834 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1835 scm_product (scm_numerator (y
), xd
));
1836 return scm_divide (r1
, scm_product (xd
, yd
));
1839 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1841 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1844 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1846 "Return the integer @var{q} and the real number @var{r}\n"
1847 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1848 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1850 "(ceiling/ 123 10) @result{} 13 and -7\n"
1851 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1852 "(ceiling/ -123 10) @result{} -12 and -3\n"
1853 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1854 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1855 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1857 #define FUNC_NAME s_scm_i_ceiling_divide
1861 scm_ceiling_divide(x
, y
, &q
, &r
);
1862 return scm_values (scm_list_2 (q
, r
));
1866 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1867 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1870 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1872 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1874 scm_t_inum xx
= SCM_I_INUM (x
);
1875 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1877 scm_t_inum yy
= SCM_I_INUM (y
);
1878 if (SCM_UNLIKELY (yy
== 0))
1879 scm_num_overflow (s_scm_ceiling_divide
);
1882 scm_t_inum qq
= xx
/ yy
;
1883 scm_t_inum rr
= xx
% yy
;
1884 int needs_adjustment
;
1886 if (SCM_LIKELY (yy
> 0))
1887 needs_adjustment
= (rr
> 0);
1889 needs_adjustment
= (rr
< 0);
1891 if (needs_adjustment
)
1896 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1897 *qp
= SCM_I_MAKINUM (qq
);
1899 *qp
= scm_i_inum2big (qq
);
1900 *rp
= SCM_I_MAKINUM (rr
);
1904 else if (SCM_BIGP (y
))
1906 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1907 scm_remember_upto_here_1 (y
);
1908 if (SCM_LIKELY (sign
> 0))
1910 if (SCM_LIKELY (xx
> 0))
1912 SCM r
= scm_i_mkbig ();
1913 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1914 scm_remember_upto_here_1 (y
);
1915 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1917 *rp
= scm_i_normbig (r
);
1919 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1920 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1921 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1923 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1924 scm_remember_upto_here_1 (y
);
1925 *qp
= SCM_I_MAKINUM (-1);
1941 SCM r
= scm_i_mkbig ();
1942 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1943 scm_remember_upto_here_1 (y
);
1944 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1946 *rp
= scm_i_normbig (r
);
1950 else if (SCM_REALP (y
))
1951 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1952 else if (SCM_FRACTIONP (y
))
1953 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1955 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1956 s_scm_ceiling_divide
, qp
, rp
);
1958 else if (SCM_BIGP (x
))
1960 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1962 scm_t_inum yy
= SCM_I_INUM (y
);
1963 if (SCM_UNLIKELY (yy
== 0))
1964 scm_num_overflow (s_scm_ceiling_divide
);
1967 SCM q
= scm_i_mkbig ();
1968 SCM r
= scm_i_mkbig ();
1970 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1971 SCM_I_BIG_MPZ (x
), yy
);
1974 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1975 SCM_I_BIG_MPZ (x
), -yy
);
1976 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1978 scm_remember_upto_here_1 (x
);
1979 *qp
= scm_i_normbig (q
);
1980 *rp
= scm_i_normbig (r
);
1984 else if (SCM_BIGP (y
))
1986 SCM q
= scm_i_mkbig ();
1987 SCM r
= scm_i_mkbig ();
1988 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1989 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1990 scm_remember_upto_here_2 (x
, y
);
1991 *qp
= scm_i_normbig (q
);
1992 *rp
= scm_i_normbig (r
);
1995 else if (SCM_REALP (y
))
1996 return scm_i_inexact_ceiling_divide
1997 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1998 else if (SCM_FRACTIONP (y
))
1999 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2001 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2002 s_scm_ceiling_divide
, qp
, rp
);
2004 else if (SCM_REALP (x
))
2006 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2007 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2008 return scm_i_inexact_ceiling_divide
2009 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2011 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2012 s_scm_ceiling_divide
, qp
, rp
);
2014 else if (SCM_FRACTIONP (x
))
2017 return scm_i_inexact_ceiling_divide
2018 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2019 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2020 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2022 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2023 s_scm_ceiling_divide
, qp
, rp
);
2026 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2027 s_scm_ceiling_divide
, qp
, rp
);
2031 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2033 if (SCM_UNLIKELY (y
== 0))
2034 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2037 double q
= ceil (x
/ y
);
2038 double r
= x
- q
* y
;
2039 *qp
= scm_from_double (q
);
2040 *rp
= scm_from_double (r
);
2045 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2048 SCM xd
= scm_denominator (x
);
2049 SCM yd
= scm_denominator (y
);
2051 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2052 scm_product (scm_numerator (y
), xd
),
2054 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2057 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2058 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2060 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2062 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2064 "(truncate-quotient 123 10) @result{} 12\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.2 -63.5) @result{} 1.0\n"
2069 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2071 #define FUNC_NAME s_scm_truncate_quotient
2073 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2075 scm_t_inum xx
= SCM_I_INUM (x
);
2076 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2078 scm_t_inum yy
= SCM_I_INUM (y
);
2079 if (SCM_UNLIKELY (yy
== 0))
2080 scm_num_overflow (s_scm_truncate_quotient
);
2083 scm_t_inum qq
= xx
/ yy
;
2084 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2085 return SCM_I_MAKINUM (qq
);
2087 return scm_i_inum2big (qq
);
2090 else if (SCM_BIGP (y
))
2092 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2093 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2094 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2096 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2097 scm_remember_upto_here_1 (y
);
2098 return SCM_I_MAKINUM (-1);
2103 else if (SCM_REALP (y
))
2104 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2105 else if (SCM_FRACTIONP (y
))
2106 return scm_i_exact_rational_truncate_quotient (x
, y
);
2108 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2109 s_scm_truncate_quotient
);
2111 else if (SCM_BIGP (x
))
2113 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2115 scm_t_inum yy
= SCM_I_INUM (y
);
2116 if (SCM_UNLIKELY (yy
== 0))
2117 scm_num_overflow (s_scm_truncate_quotient
);
2118 else if (SCM_UNLIKELY (yy
== 1))
2122 SCM q
= scm_i_mkbig ();
2124 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2127 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2128 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2130 scm_remember_upto_here_1 (x
);
2131 return scm_i_normbig (q
);
2134 else if (SCM_BIGP (y
))
2136 SCM q
= scm_i_mkbig ();
2137 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2140 scm_remember_upto_here_2 (x
, y
);
2141 return scm_i_normbig (q
);
2143 else if (SCM_REALP (y
))
2144 return scm_i_inexact_truncate_quotient
2145 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2146 else if (SCM_FRACTIONP (y
))
2147 return scm_i_exact_rational_truncate_quotient (x
, y
);
2149 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2150 s_scm_truncate_quotient
);
2152 else if (SCM_REALP (x
))
2154 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2155 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2156 return scm_i_inexact_truncate_quotient
2157 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2159 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2160 s_scm_truncate_quotient
);
2162 else if (SCM_FRACTIONP (x
))
2165 return scm_i_inexact_truncate_quotient
2166 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2167 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2168 return scm_i_exact_rational_truncate_quotient (x
, y
);
2170 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2171 s_scm_truncate_quotient
);
2174 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2175 s_scm_truncate_quotient
);
2180 scm_i_inexact_truncate_quotient (double x
, double y
)
2182 if (SCM_UNLIKELY (y
== 0))
2183 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2185 return scm_from_double (trunc (x
/ y
));
2189 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2191 return scm_truncate_quotient
2192 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2193 scm_product (scm_numerator (y
), scm_denominator (x
)));
2196 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2197 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2199 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2201 "Return the real number @var{r} such that\n"
2202 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2203 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2205 "(truncate-remainder 123 10) @result{} 3\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.2 -63.5) @result{} -59.7\n"
2210 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2212 #define FUNC_NAME s_scm_truncate_remainder
2214 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2216 scm_t_inum xx
= SCM_I_INUM (x
);
2217 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2219 scm_t_inum yy
= SCM_I_INUM (y
);
2220 if (SCM_UNLIKELY (yy
== 0))
2221 scm_num_overflow (s_scm_truncate_remainder
);
2223 return SCM_I_MAKINUM (xx
% yy
);
2225 else if (SCM_BIGP (y
))
2227 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2228 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2229 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2231 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2232 scm_remember_upto_here_1 (y
);
2238 else if (SCM_REALP (y
))
2239 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2240 else if (SCM_FRACTIONP (y
))
2241 return scm_i_exact_rational_truncate_remainder (x
, y
);
2243 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2244 s_scm_truncate_remainder
);
2246 else if (SCM_BIGP (x
))
2248 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2250 scm_t_inum yy
= SCM_I_INUM (y
);
2251 if (SCM_UNLIKELY (yy
== 0))
2252 scm_num_overflow (s_scm_truncate_remainder
);
2255 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2256 (yy
> 0) ? yy
: -yy
)
2257 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2258 scm_remember_upto_here_1 (x
);
2259 return SCM_I_MAKINUM (rr
);
2262 else if (SCM_BIGP (y
))
2264 SCM r
= scm_i_mkbig ();
2265 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2268 scm_remember_upto_here_2 (x
, y
);
2269 return scm_i_normbig (r
);
2271 else if (SCM_REALP (y
))
2272 return scm_i_inexact_truncate_remainder
2273 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2274 else if (SCM_FRACTIONP (y
))
2275 return scm_i_exact_rational_truncate_remainder (x
, y
);
2277 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2278 s_scm_truncate_remainder
);
2280 else if (SCM_REALP (x
))
2282 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2283 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2284 return scm_i_inexact_truncate_remainder
2285 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2287 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2288 s_scm_truncate_remainder
);
2290 else if (SCM_FRACTIONP (x
))
2293 return scm_i_inexact_truncate_remainder
2294 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2295 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2296 return scm_i_exact_rational_truncate_remainder (x
, y
);
2298 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2299 s_scm_truncate_remainder
);
2302 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2303 s_scm_truncate_remainder
);
2308 scm_i_inexact_truncate_remainder (double x
, double y
)
2310 /* Although it would be more efficient to use fmod here, we can't
2311 because it would in some cases produce results inconsistent with
2312 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2313 close). In particular, when x is very close to a multiple of y,
2314 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2315 correspond to different choices of q. If quotient chooses one and
2316 remainder chooses the other, it would be bad. */
2317 if (SCM_UNLIKELY (y
== 0))
2318 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2320 return scm_from_double (x
- y
* trunc (x
/ y
));
2324 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2326 SCM xd
= scm_denominator (x
);
2327 SCM yd
= scm_denominator (y
);
2328 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2329 scm_product (scm_numerator (y
), xd
));
2330 return scm_divide (r1
, scm_product (xd
, yd
));
2334 static void scm_i_inexact_truncate_divide (double x
, double y
,
2336 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2339 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2341 "Return the integer @var{q} and the real number @var{r}\n"
2342 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2343 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2345 "(truncate/ 123 10) @result{} 12 and 3\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.2 -63.5) @result{} 1.0 and -59.7\n"
2350 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2352 #define FUNC_NAME s_scm_i_truncate_divide
2356 scm_truncate_divide(x
, y
, &q
, &r
);
2357 return scm_values (scm_list_2 (q
, r
));
2361 #define s_scm_truncate_divide s_scm_i_truncate_divide
2362 #define g_scm_truncate_divide g_scm_i_truncate_divide
2365 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2367 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2369 scm_t_inum xx
= SCM_I_INUM (x
);
2370 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2372 scm_t_inum yy
= SCM_I_INUM (y
);
2373 if (SCM_UNLIKELY (yy
== 0))
2374 scm_num_overflow (s_scm_truncate_divide
);
2377 scm_t_inum qq
= xx
/ yy
;
2378 scm_t_inum rr
= xx
% yy
;
2379 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2380 *qp
= SCM_I_MAKINUM (qq
);
2382 *qp
= scm_i_inum2big (qq
);
2383 *rp
= SCM_I_MAKINUM (rr
);
2387 else if (SCM_BIGP (y
))
2389 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2390 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2391 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2393 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2394 scm_remember_upto_here_1 (y
);
2395 *qp
= SCM_I_MAKINUM (-1);
2405 else if (SCM_REALP (y
))
2406 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2407 else if (SCM_FRACTIONP (y
))
2408 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2410 return two_valued_wta_dispatch_2
2411 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2412 s_scm_truncate_divide
, qp
, rp
);
2414 else if (SCM_BIGP (x
))
2416 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2418 scm_t_inum yy
= SCM_I_INUM (y
);
2419 if (SCM_UNLIKELY (yy
== 0))
2420 scm_num_overflow (s_scm_truncate_divide
);
2423 SCM q
= scm_i_mkbig ();
2426 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2427 SCM_I_BIG_MPZ (x
), yy
);
2430 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2431 SCM_I_BIG_MPZ (x
), -yy
);
2432 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2434 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2435 scm_remember_upto_here_1 (x
);
2436 *qp
= scm_i_normbig (q
);
2437 *rp
= SCM_I_MAKINUM (rr
);
2441 else if (SCM_BIGP (y
))
2443 SCM q
= scm_i_mkbig ();
2444 SCM r
= scm_i_mkbig ();
2445 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2446 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2447 scm_remember_upto_here_2 (x
, y
);
2448 *qp
= scm_i_normbig (q
);
2449 *rp
= scm_i_normbig (r
);
2451 else if (SCM_REALP (y
))
2452 return scm_i_inexact_truncate_divide
2453 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2454 else if (SCM_FRACTIONP (y
))
2455 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2457 return two_valued_wta_dispatch_2
2458 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2459 s_scm_truncate_divide
, qp
, rp
);
2461 else if (SCM_REALP (x
))
2463 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2464 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2465 return scm_i_inexact_truncate_divide
2466 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2468 return two_valued_wta_dispatch_2
2469 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2470 s_scm_truncate_divide
, qp
, rp
);
2472 else if (SCM_FRACTIONP (x
))
2475 return scm_i_inexact_truncate_divide
2476 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2477 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2478 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2480 return two_valued_wta_dispatch_2
2481 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2482 s_scm_truncate_divide
, qp
, rp
);
2485 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2486 s_scm_truncate_divide
, qp
, rp
);
2490 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2492 if (SCM_UNLIKELY (y
== 0))
2493 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2496 double q
= trunc (x
/ y
);
2497 double r
= x
- q
* y
;
2498 *qp
= scm_from_double (q
);
2499 *rp
= scm_from_double (r
);
2504 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2507 SCM xd
= scm_denominator (x
);
2508 SCM yd
= scm_denominator (y
);
2510 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2511 scm_product (scm_numerator (y
), xd
),
2513 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2516 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2517 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2518 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2520 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2522 "Return the integer @var{q} such that\n"
2523 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2524 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2526 "(centered-quotient 123 10) @result{} 12\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.2 -63.5) @result{} 2.0\n"
2531 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2533 #define FUNC_NAME s_scm_centered_quotient
2535 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2537 scm_t_inum xx
= SCM_I_INUM (x
);
2538 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2540 scm_t_inum yy
= SCM_I_INUM (y
);
2541 if (SCM_UNLIKELY (yy
== 0))
2542 scm_num_overflow (s_scm_centered_quotient
);
2545 scm_t_inum qq
= xx
/ yy
;
2546 scm_t_inum rr
= xx
% yy
;
2547 if (SCM_LIKELY (xx
> 0))
2549 if (SCM_LIKELY (yy
> 0))
2551 if (rr
>= (yy
+ 1) / 2)
2556 if (rr
>= (1 - yy
) / 2)
2562 if (SCM_LIKELY (yy
> 0))
2573 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2574 return SCM_I_MAKINUM (qq
);
2576 return scm_i_inum2big (qq
);
2579 else if (SCM_BIGP (y
))
2581 /* Pass a denormalized bignum version of x (even though it
2582 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2583 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2585 else if (SCM_REALP (y
))
2586 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2587 else if (SCM_FRACTIONP (y
))
2588 return scm_i_exact_rational_centered_quotient (x
, y
);
2590 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2591 s_scm_centered_quotient
);
2593 else if (SCM_BIGP (x
))
2595 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2597 scm_t_inum yy
= SCM_I_INUM (y
);
2598 if (SCM_UNLIKELY (yy
== 0))
2599 scm_num_overflow (s_scm_centered_quotient
);
2600 else if (SCM_UNLIKELY (yy
== 1))
2604 SCM q
= scm_i_mkbig ();
2606 /* Arrange for rr to initially be non-positive,
2607 because that simplifies the test to see
2608 if it is within the needed bounds. */
2611 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2612 SCM_I_BIG_MPZ (x
), yy
);
2613 scm_remember_upto_here_1 (x
);
2615 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2616 SCM_I_BIG_MPZ (q
), 1);
2620 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2621 SCM_I_BIG_MPZ (x
), -yy
);
2622 scm_remember_upto_here_1 (x
);
2623 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2625 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2626 SCM_I_BIG_MPZ (q
), 1);
2628 return scm_i_normbig (q
);
2631 else if (SCM_BIGP (y
))
2632 return scm_i_bigint_centered_quotient (x
, y
);
2633 else if (SCM_REALP (y
))
2634 return scm_i_inexact_centered_quotient
2635 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2636 else if (SCM_FRACTIONP (y
))
2637 return scm_i_exact_rational_centered_quotient (x
, y
);
2639 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2640 s_scm_centered_quotient
);
2642 else if (SCM_REALP (x
))
2644 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2645 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2646 return scm_i_inexact_centered_quotient
2647 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2649 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2650 s_scm_centered_quotient
);
2652 else if (SCM_FRACTIONP (x
))
2655 return scm_i_inexact_centered_quotient
2656 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2657 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2658 return scm_i_exact_rational_centered_quotient (x
, y
);
2660 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2661 s_scm_centered_quotient
);
2664 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2665 s_scm_centered_quotient
);
2670 scm_i_inexact_centered_quotient (double x
, double y
)
2672 if (SCM_LIKELY (y
> 0))
2673 return scm_from_double (floor (x
/y
+ 0.5));
2674 else if (SCM_LIKELY (y
< 0))
2675 return scm_from_double (ceil (x
/y
- 0.5));
2677 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2682 /* Assumes that both x and y are bigints, though
2683 x might be able to fit into a fixnum. */
2685 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2689 /* Note that x might be small enough to fit into a
2690 fixnum, so we must not let it escape into the wild */
2694 /* min_r will eventually become -abs(y)/2 */
2695 min_r
= scm_i_mkbig ();
2696 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2697 SCM_I_BIG_MPZ (y
), 1);
2699 /* Arrange for rr to initially be non-positive,
2700 because that simplifies the test to see
2701 if it is within the needed bounds. */
2702 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2704 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2705 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2706 scm_remember_upto_here_2 (x
, y
);
2707 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2708 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2709 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2710 SCM_I_BIG_MPZ (q
), 1);
2714 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2715 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2716 scm_remember_upto_here_2 (x
, y
);
2717 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2718 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2719 SCM_I_BIG_MPZ (q
), 1);
2721 scm_remember_upto_here_2 (r
, min_r
);
2722 return scm_i_normbig (q
);
2726 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2728 return scm_centered_quotient
2729 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2730 scm_product (scm_numerator (y
), scm_denominator (x
)));
2733 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2734 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2735 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2737 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2739 "Return the real number @var{r} such that\n"
2740 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2741 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2742 "for some integer @var{q}.\n"
2744 "(centered-remainder 123 10) @result{} 3\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.2 -63.5) @result{} 3.8\n"
2749 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2751 #define FUNC_NAME s_scm_centered_remainder
2753 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2755 scm_t_inum xx
= SCM_I_INUM (x
);
2756 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2758 scm_t_inum yy
= SCM_I_INUM (y
);
2759 if (SCM_UNLIKELY (yy
== 0))
2760 scm_num_overflow (s_scm_centered_remainder
);
2763 scm_t_inum rr
= xx
% yy
;
2764 if (SCM_LIKELY (xx
> 0))
2766 if (SCM_LIKELY (yy
> 0))
2768 if (rr
>= (yy
+ 1) / 2)
2773 if (rr
>= (1 - yy
) / 2)
2779 if (SCM_LIKELY (yy
> 0))
2790 return SCM_I_MAKINUM (rr
);
2793 else if (SCM_BIGP (y
))
2795 /* Pass a denormalized bignum version of x (even though it
2796 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2797 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2799 else if (SCM_REALP (y
))
2800 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2801 else if (SCM_FRACTIONP (y
))
2802 return scm_i_exact_rational_centered_remainder (x
, y
);
2804 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2805 s_scm_centered_remainder
);
2807 else if (SCM_BIGP (x
))
2809 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2811 scm_t_inum yy
= SCM_I_INUM (y
);
2812 if (SCM_UNLIKELY (yy
== 0))
2813 scm_num_overflow (s_scm_centered_remainder
);
2817 /* Arrange for rr to initially be non-positive,
2818 because that simplifies the test to see
2819 if it is within the needed bounds. */
2822 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2823 scm_remember_upto_here_1 (x
);
2829 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2830 scm_remember_upto_here_1 (x
);
2834 return SCM_I_MAKINUM (rr
);
2837 else if (SCM_BIGP (y
))
2838 return scm_i_bigint_centered_remainder (x
, y
);
2839 else if (SCM_REALP (y
))
2840 return scm_i_inexact_centered_remainder
2841 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2842 else if (SCM_FRACTIONP (y
))
2843 return scm_i_exact_rational_centered_remainder (x
, y
);
2845 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2846 s_scm_centered_remainder
);
2848 else if (SCM_REALP (x
))
2850 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2851 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2852 return scm_i_inexact_centered_remainder
2853 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2855 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2856 s_scm_centered_remainder
);
2858 else if (SCM_FRACTIONP (x
))
2861 return scm_i_inexact_centered_remainder
2862 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2863 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2864 return scm_i_exact_rational_centered_remainder (x
, y
);
2866 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2867 s_scm_centered_remainder
);
2870 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2871 s_scm_centered_remainder
);
2876 scm_i_inexact_centered_remainder (double x
, double y
)
2880 /* Although it would be more efficient to use fmod here, we can't
2881 because it would in some cases produce results inconsistent with
2882 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2883 close). In particular, when x-y/2 is very close to a multiple of
2884 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2885 two cases must correspond to different choices of q. If quotient
2886 chooses one and remainder chooses the other, it would be bad. */
2887 if (SCM_LIKELY (y
> 0))
2888 q
= floor (x
/y
+ 0.5);
2889 else if (SCM_LIKELY (y
< 0))
2890 q
= ceil (x
/y
- 0.5);
2892 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2895 return scm_from_double (x
- q
* y
);
2898 /* Assumes that both x and y are bigints, though
2899 x might be able to fit into a fixnum. */
2901 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2905 /* Note that x might be small enough to fit into a
2906 fixnum, so we must not let it escape into the wild */
2909 /* min_r will eventually become -abs(y)/2 */
2910 min_r
= scm_i_mkbig ();
2911 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2912 SCM_I_BIG_MPZ (y
), 1);
2914 /* Arrange for rr to initially be non-positive,
2915 because that simplifies the test to see
2916 if it is within the needed bounds. */
2917 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2919 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2920 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2921 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2922 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2923 mpz_add (SCM_I_BIG_MPZ (r
),
2929 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2930 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2931 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2932 mpz_sub (SCM_I_BIG_MPZ (r
),
2936 scm_remember_upto_here_2 (x
, y
);
2937 return scm_i_normbig (r
);
2941 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2943 SCM xd
= scm_denominator (x
);
2944 SCM yd
= scm_denominator (y
);
2945 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2946 scm_product (scm_numerator (y
), xd
));
2947 return scm_divide (r1
, scm_product (xd
, yd
));
2951 static void scm_i_inexact_centered_divide (double x
, double y
,
2953 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2954 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2957 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2959 "Return the integer @var{q} and the real number @var{r}\n"
2960 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2961 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2963 "(centered/ 123 10) @result{} 12 and 3\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.2 -63.5) @result{} 2.0 and 3.8\n"
2968 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2970 #define FUNC_NAME s_scm_i_centered_divide
2974 scm_centered_divide(x
, y
, &q
, &r
);
2975 return scm_values (scm_list_2 (q
, r
));
2979 #define s_scm_centered_divide s_scm_i_centered_divide
2980 #define g_scm_centered_divide g_scm_i_centered_divide
2983 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2985 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2987 scm_t_inum xx
= SCM_I_INUM (x
);
2988 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2990 scm_t_inum yy
= SCM_I_INUM (y
);
2991 if (SCM_UNLIKELY (yy
== 0))
2992 scm_num_overflow (s_scm_centered_divide
);
2995 scm_t_inum qq
= xx
/ yy
;
2996 scm_t_inum rr
= xx
% yy
;
2997 if (SCM_LIKELY (xx
> 0))
2999 if (SCM_LIKELY (yy
> 0))
3001 if (rr
>= (yy
+ 1) / 2)
3006 if (rr
>= (1 - yy
) / 2)
3012 if (SCM_LIKELY (yy
> 0))
3023 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3024 *qp
= SCM_I_MAKINUM (qq
);
3026 *qp
= scm_i_inum2big (qq
);
3027 *rp
= SCM_I_MAKINUM (rr
);
3031 else if (SCM_BIGP (y
))
3033 /* Pass a denormalized bignum version of x (even though it
3034 can fit in a fixnum) to scm_i_bigint_centered_divide */
3035 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3037 else if (SCM_REALP (y
))
3038 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3039 else if (SCM_FRACTIONP (y
))
3040 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3042 return two_valued_wta_dispatch_2
3043 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3044 s_scm_centered_divide
, qp
, rp
);
3046 else if (SCM_BIGP (x
))
3048 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3050 scm_t_inum yy
= SCM_I_INUM (y
);
3051 if (SCM_UNLIKELY (yy
== 0))
3052 scm_num_overflow (s_scm_centered_divide
);
3055 SCM q
= scm_i_mkbig ();
3057 /* Arrange for rr to initially be non-positive,
3058 because that simplifies the test to see
3059 if it is within the needed bounds. */
3062 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3063 SCM_I_BIG_MPZ (x
), yy
);
3064 scm_remember_upto_here_1 (x
);
3067 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3068 SCM_I_BIG_MPZ (q
), 1);
3074 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3075 SCM_I_BIG_MPZ (x
), -yy
);
3076 scm_remember_upto_here_1 (x
);
3077 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3080 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3081 SCM_I_BIG_MPZ (q
), 1);
3085 *qp
= scm_i_normbig (q
);
3086 *rp
= SCM_I_MAKINUM (rr
);
3090 else if (SCM_BIGP (y
))
3091 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3092 else if (SCM_REALP (y
))
3093 return scm_i_inexact_centered_divide
3094 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3095 else if (SCM_FRACTIONP (y
))
3096 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3098 return two_valued_wta_dispatch_2
3099 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3100 s_scm_centered_divide
, qp
, rp
);
3102 else if (SCM_REALP (x
))
3104 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3105 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3106 return scm_i_inexact_centered_divide
3107 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3109 return two_valued_wta_dispatch_2
3110 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3111 s_scm_centered_divide
, qp
, rp
);
3113 else if (SCM_FRACTIONP (x
))
3116 return scm_i_inexact_centered_divide
3117 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3118 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3119 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3121 return two_valued_wta_dispatch_2
3122 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3123 s_scm_centered_divide
, qp
, rp
);
3126 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3127 s_scm_centered_divide
, qp
, rp
);
3131 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3135 if (SCM_LIKELY (y
> 0))
3136 q
= floor (x
/y
+ 0.5);
3137 else if (SCM_LIKELY (y
< 0))
3138 q
= ceil (x
/y
- 0.5);
3140 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3144 *qp
= scm_from_double (q
);
3145 *rp
= scm_from_double (r
);
3148 /* Assumes that both x and y are bigints, though
3149 x might be able to fit into a fixnum. */
3151 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3155 /* Note that x might be small enough to fit into a
3156 fixnum, so we must not let it escape into the wild */
3160 /* min_r will eventually become -abs(y/2) */
3161 min_r
= scm_i_mkbig ();
3162 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3163 SCM_I_BIG_MPZ (y
), 1);
3165 /* Arrange for rr to initially be non-positive,
3166 because that simplifies the test to see
3167 if it is within the needed bounds. */
3168 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3170 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3171 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3172 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3173 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3175 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3176 SCM_I_BIG_MPZ (q
), 1);
3177 mpz_add (SCM_I_BIG_MPZ (r
),
3184 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3185 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3186 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3188 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3189 SCM_I_BIG_MPZ (q
), 1);
3190 mpz_sub (SCM_I_BIG_MPZ (r
),
3195 scm_remember_upto_here_2 (x
, y
);
3196 *qp
= scm_i_normbig (q
);
3197 *rp
= scm_i_normbig (r
);
3201 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3204 SCM xd
= scm_denominator (x
);
3205 SCM yd
= scm_denominator (y
);
3207 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3208 scm_product (scm_numerator (y
), xd
),
3210 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3213 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3214 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3215 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3217 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3219 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3220 "with ties going to the nearest even integer.\n"
3222 "(round-quotient 123 10) @result{} 12\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 125 10) @result{} 12\n"
3227 "(round-quotient 127 10) @result{} 13\n"
3228 "(round-quotient 135 10) @result{} 14\n"
3229 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3230 "(round-quotient 16/3 -10/7) @result{} -4\n"
3232 #define FUNC_NAME s_scm_round_quotient
3234 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3236 scm_t_inum xx
= SCM_I_INUM (x
);
3237 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3239 scm_t_inum yy
= SCM_I_INUM (y
);
3240 if (SCM_UNLIKELY (yy
== 0))
3241 scm_num_overflow (s_scm_round_quotient
);
3244 scm_t_inum qq
= xx
/ yy
;
3245 scm_t_inum rr
= xx
% yy
;
3247 scm_t_inum r2
= 2 * rr
;
3249 if (SCM_LIKELY (yy
< 0))
3269 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3270 return SCM_I_MAKINUM (qq
);
3272 return scm_i_inum2big (qq
);
3275 else if (SCM_BIGP (y
))
3277 /* Pass a denormalized bignum version of x (even though it
3278 can fit in a fixnum) to scm_i_bigint_round_quotient */
3279 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3281 else if (SCM_REALP (y
))
3282 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3283 else if (SCM_FRACTIONP (y
))
3284 return scm_i_exact_rational_round_quotient (x
, y
);
3286 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3287 s_scm_round_quotient
);
3289 else if (SCM_BIGP (x
))
3291 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3293 scm_t_inum yy
= SCM_I_INUM (y
);
3294 if (SCM_UNLIKELY (yy
== 0))
3295 scm_num_overflow (s_scm_round_quotient
);
3296 else if (SCM_UNLIKELY (yy
== 1))
3300 SCM q
= scm_i_mkbig ();
3302 int needs_adjustment
;
3306 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3307 SCM_I_BIG_MPZ (x
), yy
);
3308 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3309 needs_adjustment
= (2*rr
>= yy
);
3311 needs_adjustment
= (2*rr
> yy
);
3315 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3316 SCM_I_BIG_MPZ (x
), -yy
);
3317 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3318 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3319 needs_adjustment
= (2*rr
<= yy
);
3321 needs_adjustment
= (2*rr
< yy
);
3323 scm_remember_upto_here_1 (x
);
3324 if (needs_adjustment
)
3325 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3326 return scm_i_normbig (q
);
3329 else if (SCM_BIGP (y
))
3330 return scm_i_bigint_round_quotient (x
, y
);
3331 else if (SCM_REALP (y
))
3332 return scm_i_inexact_round_quotient
3333 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3334 else if (SCM_FRACTIONP (y
))
3335 return scm_i_exact_rational_round_quotient (x
, y
);
3337 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3338 s_scm_round_quotient
);
3340 else if (SCM_REALP (x
))
3342 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3343 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3344 return scm_i_inexact_round_quotient
3345 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3347 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3348 s_scm_round_quotient
);
3350 else if (SCM_FRACTIONP (x
))
3353 return scm_i_inexact_round_quotient
3354 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3355 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3356 return scm_i_exact_rational_round_quotient (x
, y
);
3358 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3359 s_scm_round_quotient
);
3362 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3363 s_scm_round_quotient
);
3368 scm_i_inexact_round_quotient (double x
, double y
)
3370 if (SCM_UNLIKELY (y
== 0))
3371 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3373 return scm_from_double (scm_c_round (x
/ y
));
3376 /* Assumes that both x and y are bigints, though
3377 x might be able to fit into a fixnum. */
3379 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3382 int cmp
, needs_adjustment
;
3384 /* Note that x might be small enough to fit into a
3385 fixnum, so we must not let it escape into the wild */
3388 r2
= scm_i_mkbig ();
3390 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3391 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3392 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3393 scm_remember_upto_here_2 (x
, r
);
3395 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3396 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3397 needs_adjustment
= (cmp
>= 0);
3399 needs_adjustment
= (cmp
> 0);
3400 scm_remember_upto_here_2 (r2
, y
);
3402 if (needs_adjustment
)
3403 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3405 return scm_i_normbig (q
);
3409 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3411 return scm_round_quotient
3412 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3413 scm_product (scm_numerator (y
), scm_denominator (x
)));
3416 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3417 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3418 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3420 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3422 "Return the real number @var{r} such that\n"
3423 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3424 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3425 "nearest integer, with ties going to the nearest\n"
3428 "(round-remainder 123 10) @result{} 3\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 125 10) @result{} 5\n"
3433 "(round-remainder 127 10) @result{} -3\n"
3434 "(round-remainder 135 10) @result{} -5\n"
3435 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3436 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3438 #define FUNC_NAME s_scm_round_remainder
3440 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3442 scm_t_inum xx
= SCM_I_INUM (x
);
3443 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3445 scm_t_inum yy
= SCM_I_INUM (y
);
3446 if (SCM_UNLIKELY (yy
== 0))
3447 scm_num_overflow (s_scm_round_remainder
);
3450 scm_t_inum qq
= xx
/ yy
;
3451 scm_t_inum rr
= xx
% yy
;
3453 scm_t_inum r2
= 2 * rr
;
3455 if (SCM_LIKELY (yy
< 0))
3475 return SCM_I_MAKINUM (rr
);
3478 else if (SCM_BIGP (y
))
3480 /* Pass a denormalized bignum version of x (even though it
3481 can fit in a fixnum) to scm_i_bigint_round_remainder */
3482 return scm_i_bigint_round_remainder
3483 (scm_i_long2big (xx
), y
);
3485 else if (SCM_REALP (y
))
3486 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3487 else if (SCM_FRACTIONP (y
))
3488 return scm_i_exact_rational_round_remainder (x
, y
);
3490 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3491 s_scm_round_remainder
);
3493 else if (SCM_BIGP (x
))
3495 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3497 scm_t_inum yy
= SCM_I_INUM (y
);
3498 if (SCM_UNLIKELY (yy
== 0))
3499 scm_num_overflow (s_scm_round_remainder
);
3502 SCM q
= scm_i_mkbig ();
3504 int needs_adjustment
;
3508 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3509 SCM_I_BIG_MPZ (x
), yy
);
3510 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3511 needs_adjustment
= (2*rr
>= yy
);
3513 needs_adjustment
= (2*rr
> yy
);
3517 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3518 SCM_I_BIG_MPZ (x
), -yy
);
3519 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3520 needs_adjustment
= (2*rr
<= yy
);
3522 needs_adjustment
= (2*rr
< yy
);
3524 scm_remember_upto_here_2 (x
, q
);
3525 if (needs_adjustment
)
3527 return SCM_I_MAKINUM (rr
);
3530 else if (SCM_BIGP (y
))
3531 return scm_i_bigint_round_remainder (x
, y
);
3532 else if (SCM_REALP (y
))
3533 return scm_i_inexact_round_remainder
3534 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3535 else if (SCM_FRACTIONP (y
))
3536 return scm_i_exact_rational_round_remainder (x
, y
);
3538 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3539 s_scm_round_remainder
);
3541 else if (SCM_REALP (x
))
3543 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3544 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3545 return scm_i_inexact_round_remainder
3546 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3548 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3549 s_scm_round_remainder
);
3551 else if (SCM_FRACTIONP (x
))
3554 return scm_i_inexact_round_remainder
3555 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3556 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3557 return scm_i_exact_rational_round_remainder (x
, y
);
3559 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3560 s_scm_round_remainder
);
3563 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3564 s_scm_round_remainder
);
3569 scm_i_inexact_round_remainder (double x
, double y
)
3571 /* Although it would be more efficient to use fmod here, we can't
3572 because it would in some cases produce results inconsistent with
3573 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3574 close). In particular, when x-y/2 is very close to a multiple of
3575 y, then r might be either -abs(y/2) or abs(y/2), but those two
3576 cases must correspond to different choices of q. If quotient
3577 chooses one and remainder chooses the other, it would be bad. */
3579 if (SCM_UNLIKELY (y
== 0))
3580 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3583 double q
= scm_c_round (x
/ y
);
3584 return scm_from_double (x
- q
* y
);
3588 /* Assumes that both x and y are bigints, though
3589 x might be able to fit into a fixnum. */
3591 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3594 int cmp
, needs_adjustment
;
3596 /* Note that x might be small enough to fit into a
3597 fixnum, so we must not let it escape into the wild */
3600 r2
= scm_i_mkbig ();
3602 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3603 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3604 scm_remember_upto_here_1 (x
);
3605 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3607 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3608 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3609 needs_adjustment
= (cmp
>= 0);
3611 needs_adjustment
= (cmp
> 0);
3612 scm_remember_upto_here_2 (q
, r2
);
3614 if (needs_adjustment
)
3615 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3617 scm_remember_upto_here_1 (y
);
3618 return scm_i_normbig (r
);
3622 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3624 SCM xd
= scm_denominator (x
);
3625 SCM yd
= scm_denominator (y
);
3626 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3627 scm_product (scm_numerator (y
), xd
));
3628 return scm_divide (r1
, scm_product (xd
, yd
));
3632 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3633 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3634 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3636 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3638 "Return the integer @var{q} and the real number @var{r}\n"
3639 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3640 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3641 "nearest integer, with ties going to the nearest even integer.\n"
3643 "(round/ 123 10) @result{} 12 and 3\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/ 125 10) @result{} 12 and 5\n"
3648 "(round/ 127 10) @result{} 13 and -3\n"
3649 "(round/ 135 10) @result{} 14 and -5\n"
3650 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3651 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3653 #define FUNC_NAME s_scm_i_round_divide
3657 scm_round_divide(x
, y
, &q
, &r
);
3658 return scm_values (scm_list_2 (q
, r
));
3662 #define s_scm_round_divide s_scm_i_round_divide
3663 #define g_scm_round_divide g_scm_i_round_divide
3666 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3668 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3670 scm_t_inum xx
= SCM_I_INUM (x
);
3671 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3673 scm_t_inum yy
= SCM_I_INUM (y
);
3674 if (SCM_UNLIKELY (yy
== 0))
3675 scm_num_overflow (s_scm_round_divide
);
3678 scm_t_inum qq
= xx
/ yy
;
3679 scm_t_inum rr
= xx
% yy
;
3681 scm_t_inum r2
= 2 * rr
;
3683 if (SCM_LIKELY (yy
< 0))
3703 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3704 *qp
= SCM_I_MAKINUM (qq
);
3706 *qp
= scm_i_inum2big (qq
);
3707 *rp
= SCM_I_MAKINUM (rr
);
3711 else if (SCM_BIGP (y
))
3713 /* Pass a denormalized bignum version of x (even though it
3714 can fit in a fixnum) to scm_i_bigint_round_divide */
3715 return scm_i_bigint_round_divide
3716 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3718 else if (SCM_REALP (y
))
3719 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3720 else if (SCM_FRACTIONP (y
))
3721 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3723 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3724 s_scm_round_divide
, qp
, rp
);
3726 else if (SCM_BIGP (x
))
3728 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3730 scm_t_inum yy
= SCM_I_INUM (y
);
3731 if (SCM_UNLIKELY (yy
== 0))
3732 scm_num_overflow (s_scm_round_divide
);
3735 SCM q
= scm_i_mkbig ();
3737 int needs_adjustment
;
3741 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3742 SCM_I_BIG_MPZ (x
), yy
);
3743 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3744 needs_adjustment
= (2*rr
>= yy
);
3746 needs_adjustment
= (2*rr
> yy
);
3750 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3751 SCM_I_BIG_MPZ (x
), -yy
);
3752 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3753 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3754 needs_adjustment
= (2*rr
<= yy
);
3756 needs_adjustment
= (2*rr
< yy
);
3758 scm_remember_upto_here_1 (x
);
3759 if (needs_adjustment
)
3761 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3764 *qp
= scm_i_normbig (q
);
3765 *rp
= SCM_I_MAKINUM (rr
);
3769 else if (SCM_BIGP (y
))
3770 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3771 else if (SCM_REALP (y
))
3772 return scm_i_inexact_round_divide
3773 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3774 else if (SCM_FRACTIONP (y
))
3775 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3777 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3778 s_scm_round_divide
, qp
, rp
);
3780 else if (SCM_REALP (x
))
3782 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3783 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3784 return scm_i_inexact_round_divide
3785 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3787 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3788 s_scm_round_divide
, qp
, rp
);
3790 else if (SCM_FRACTIONP (x
))
3793 return scm_i_inexact_round_divide
3794 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3795 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3796 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3798 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3799 s_scm_round_divide
, qp
, rp
);
3802 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3803 s_scm_round_divide
, qp
, rp
);
3807 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3809 if (SCM_UNLIKELY (y
== 0))
3810 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3813 double q
= scm_c_round (x
/ y
);
3814 double r
= x
- q
* y
;
3815 *qp
= scm_from_double (q
);
3816 *rp
= scm_from_double (r
);
3820 /* Assumes that both x and y are bigints, though
3821 x might be able to fit into a fixnum. */
3823 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3826 int cmp
, needs_adjustment
;
3828 /* Note that x might be small enough to fit into a
3829 fixnum, so we must not let it escape into the wild */
3832 r2
= scm_i_mkbig ();
3834 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3835 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3836 scm_remember_upto_here_1 (x
);
3837 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3839 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3840 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3841 needs_adjustment
= (cmp
>= 0);
3843 needs_adjustment
= (cmp
> 0);
3845 if (needs_adjustment
)
3847 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3848 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3851 scm_remember_upto_here_2 (r2
, y
);
3852 *qp
= scm_i_normbig (q
);
3853 *rp
= scm_i_normbig (r
);
3857 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3860 SCM xd
= scm_denominator (x
);
3861 SCM yd
= scm_denominator (y
);
3863 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3864 scm_product (scm_numerator (y
), xd
),
3866 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3870 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3871 (SCM x
, SCM y
, SCM rest
),
3872 "Return the greatest common divisor of all parameter values.\n"
3873 "If called without arguments, 0 is returned.")
3874 #define FUNC_NAME s_scm_i_gcd
3876 while (!scm_is_null (rest
))
3877 { x
= scm_gcd (x
, y
);
3879 rest
= scm_cdr (rest
);
3881 return scm_gcd (x
, y
);
3885 #define s_gcd s_scm_i_gcd
3886 #define g_gcd g_scm_i_gcd
3889 scm_gcd (SCM x
, SCM y
)
3892 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3894 if (SCM_I_INUMP (x
))
3896 if (SCM_I_INUMP (y
))
3898 scm_t_inum xx
= SCM_I_INUM (x
);
3899 scm_t_inum yy
= SCM_I_INUM (y
);
3900 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3901 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3911 /* Determine a common factor 2^k */
3912 while (!(1 & (u
| v
)))
3918 /* Now, any factor 2^n can be eliminated */
3938 return (SCM_POSFIXABLE (result
)
3939 ? SCM_I_MAKINUM (result
)
3940 : scm_i_inum2big (result
));
3942 else if (SCM_BIGP (y
))
3948 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3950 else if (SCM_BIGP (x
))
3952 if (SCM_I_INUMP (y
))
3957 yy
= SCM_I_INUM (y
);
3962 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3963 scm_remember_upto_here_1 (x
);
3964 return (SCM_POSFIXABLE (result
)
3965 ? SCM_I_MAKINUM (result
)
3966 : scm_from_unsigned_integer (result
));
3968 else if (SCM_BIGP (y
))
3970 SCM result
= scm_i_mkbig ();
3971 mpz_gcd (SCM_I_BIG_MPZ (result
),
3974 scm_remember_upto_here_2 (x
, y
);
3975 return scm_i_normbig (result
);
3978 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3981 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3984 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3985 (SCM x
, SCM y
, SCM rest
),
3986 "Return the least common multiple of the arguments.\n"
3987 "If called without arguments, 1 is returned.")
3988 #define FUNC_NAME s_scm_i_lcm
3990 while (!scm_is_null (rest
))
3991 { x
= scm_lcm (x
, y
);
3993 rest
= scm_cdr (rest
);
3995 return scm_lcm (x
, y
);
3999 #define s_lcm s_scm_i_lcm
4000 #define g_lcm g_scm_i_lcm
4003 scm_lcm (SCM n1
, SCM n2
)
4005 if (SCM_UNBNDP (n2
))
4007 if (SCM_UNBNDP (n1
))
4008 return SCM_I_MAKINUM (1L);
4009 n2
= SCM_I_MAKINUM (1L);
4012 if (SCM_UNLIKELY (!(SCM_I_INUMP (n1
) || SCM_BIGP (n1
))))
4013 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4015 if (SCM_UNLIKELY (!(SCM_I_INUMP (n2
) || SCM_BIGP (n2
))))
4016 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, 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
)
5146 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5167 a
[ch
++] = number_chars
[d
];
5170 if (f
+ fx
[wp
] >= 1.0)
5172 a
[ch
- 1] = number_chars
[d
+1];
5183 if ((dpt
> 4) && (exp
> 6))
5185 d
= (a
[0] == '-' ? 2 : 1);
5186 for (i
= ch
++; i
> d
; i
--)
5198 if (a
[ch
- 1] == '.')
5199 a
[ch
++] = '0'; /* trailing zero */
5208 for (i
= radix
; i
<= exp
; i
*= radix
);
5209 for (i
/= radix
; i
; i
/= radix
)
5211 a
[ch
++] = number_chars
[exp
/ i
];
5220 icmplx2str (double real
, double imag
, char *str
, int radix
)
5225 i
= idbl2str (real
, str
, radix
);
5226 #ifdef HAVE_COPYSIGN
5227 sgn
= copysign (1.0, imag
);
5231 /* Don't output a '+' for negative numbers or for Inf and
5232 NaN. They will provide their own sign. */
5233 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5235 i
+= idbl2str (imag
, &str
[i
], radix
);
5241 iflo2str (SCM flt
, char *str
, int radix
)
5244 if (SCM_REALP (flt
))
5245 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5247 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5252 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5253 characters in the result.
5255 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5257 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5262 return scm_iuint2str (-num
, rad
, p
) + 1;
5265 return scm_iuint2str (num
, rad
, p
);
5268 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5269 characters in the result.
5271 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5273 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5277 scm_t_uintmax n
= num
;
5279 if (rad
< 2 || rad
> 36)
5280 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5282 for (n
/= rad
; n
> 0; n
/= rad
)
5292 p
[i
] = number_chars
[d
];
5297 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5299 "Return a string holding the external representation of the\n"
5300 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5301 "inexact, a radix of 10 will be used.")
5302 #define FUNC_NAME s_scm_number_to_string
5306 if (SCM_UNBNDP (radix
))
5309 base
= scm_to_signed_integer (radix
, 2, 36);
5311 if (SCM_I_INUMP (n
))
5313 char num_buf
[SCM_INTBUFLEN
];
5314 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5315 return scm_from_locale_stringn (num_buf
, length
);
5317 else if (SCM_BIGP (n
))
5319 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5320 size_t len
= strlen (str
);
5321 void (*freefunc
) (void *, size_t);
5323 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5324 scm_remember_upto_here_1 (n
);
5325 ret
= scm_from_latin1_stringn (str
, len
);
5326 freefunc (str
, len
+ 1);
5329 else if (SCM_FRACTIONP (n
))
5331 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5332 scm_from_locale_string ("/"),
5333 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5335 else if (SCM_INEXACTP (n
))
5337 char num_buf
[FLOBUFLEN
];
5338 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5341 SCM_WRONG_TYPE_ARG (1, n
);
5346 /* These print routines used to be stubbed here so that scm_repl.c
5347 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5350 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5352 char num_buf
[FLOBUFLEN
];
5353 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5358 scm_i_print_double (double val
, SCM port
)
5360 char num_buf
[FLOBUFLEN
];
5361 scm_lfwrite_unlocked (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5365 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5368 char num_buf
[FLOBUFLEN
];
5369 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5374 scm_i_print_complex (double real
, double imag
, SCM port
)
5376 char num_buf
[FLOBUFLEN
];
5377 scm_lfwrite_unlocked (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5381 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5384 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5385 scm_display (str
, port
);
5386 scm_remember_upto_here_1 (str
);
5391 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5393 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5394 size_t len
= strlen (str
);
5395 void (*freefunc
) (void *, size_t);
5396 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5397 scm_remember_upto_here_1 (exp
);
5398 scm_lfwrite_unlocked (str
, len
, port
);
5399 freefunc (str
, len
+ 1);
5402 /*** END nums->strs ***/
5405 /*** STRINGS -> NUMBERS ***/
5407 /* The following functions implement the conversion from strings to numbers.
5408 * The implementation somehow follows the grammar for numbers as it is given
5409 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5410 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5411 * points should be noted about the implementation:
5413 * * Each function keeps a local index variable 'idx' that points at the
5414 * current position within the parsed string. The global index is only
5415 * updated if the function could parse the corresponding syntactic unit
5418 * * Similarly, the functions keep track of indicators of inexactness ('#',
5419 * '.' or exponents) using local variables ('hash_seen', 'x').
5421 * * Sequences of digits are parsed into temporary variables holding fixnums.
5422 * Only if these fixnums would overflow, the result variables are updated
5423 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5424 * the temporary variables holding the fixnums are cleared, and the process
5425 * starts over again. If for example fixnums were able to store five decimal
5426 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5427 * and the result was computed as 12345 * 100000 + 67890. In other words,
5428 * only every five digits two bignum operations were performed.
5430 * Notes on the handling of exactness specifiers:
5432 * When parsing non-real complex numbers, we apply exactness specifiers on
5433 * per-component basis, as is done in PLT Scheme. For complex numbers
5434 * written in rectangular form, exactness specifiers are applied to the
5435 * real and imaginary parts before calling scm_make_rectangular. For
5436 * complex numbers written in polar form, exactness specifiers are applied
5437 * to the magnitude and angle before calling scm_make_polar.
5439 * There are two kinds of exactness specifiers: forced and implicit. A
5440 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5441 * the entire number, and applies to both components of a complex number.
5442 * "#e" causes each component to be made exact, and "#i" causes each
5443 * component to be made inexact. If no forced exactness specifier is
5444 * present, then the exactness of each component is determined
5445 * independently by the presence or absence of a decimal point or hash mark
5446 * within that component. If a decimal point or hash mark is present, the
5447 * component is made inexact, otherwise it is made exact.
5449 * After the exactness specifiers have been applied to each component, they
5450 * are passed to either scm_make_rectangular or scm_make_polar to produce
5451 * the final result. Note that this will result in a real number if the
5452 * imaginary part, magnitude, or angle is an exact 0.
5454 * For example, (string->number "#i5.0+0i") does the equivalent of:
5456 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5459 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5461 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5463 /* Caller is responsible for checking that the return value is in range
5464 for the given radix, which should be <= 36. */
5466 char_decimal_value (scm_t_uint32 c
)
5468 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5469 that's certainly above any valid decimal, so we take advantage of
5470 that to elide some tests. */
5471 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5473 /* If that failed, try extended hexadecimals, then. Only accept ascii
5478 if (c
>= (scm_t_uint32
) 'a')
5479 d
= c
- (scm_t_uint32
)'a' + 10U;
5484 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5485 in base RADIX. Upon success, return the unsigned integer and update
5486 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5488 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5489 unsigned int radix
, enum t_exactness
*p_exactness
)
5491 unsigned int idx
= *p_idx
;
5492 unsigned int hash_seen
= 0;
5493 scm_t_bits shift
= 1;
5495 unsigned int digit_value
;
5498 size_t len
= scm_i_string_length (mem
);
5503 c
= scm_i_string_ref (mem
, idx
);
5504 digit_value
= char_decimal_value (c
);
5505 if (digit_value
>= radix
)
5509 result
= SCM_I_MAKINUM (digit_value
);
5512 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5522 digit_value
= char_decimal_value (c
);
5523 /* This check catches non-decimals in addition to out-of-range
5525 if (digit_value
>= radix
)
5530 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5532 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5534 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5541 shift
= shift
* radix
;
5542 add
= add
* radix
+ digit_value
;
5547 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5549 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5553 *p_exactness
= INEXACT
;
5559 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5560 * covers the parts of the rules that start at a potential point. The value
5561 * of the digits up to the point have been parsed by the caller and are given
5562 * in variable result. The content of *p_exactness indicates, whether a hash
5563 * has already been seen in the digits before the point.
5566 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5569 mem2decimal_from_point (SCM result
, SCM mem
,
5570 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5572 unsigned int idx
= *p_idx
;
5573 enum t_exactness x
= *p_exactness
;
5574 size_t len
= scm_i_string_length (mem
);
5579 if (scm_i_string_ref (mem
, idx
) == '.')
5581 scm_t_bits shift
= 1;
5583 unsigned int digit_value
;
5584 SCM big_shift
= SCM_INUM1
;
5589 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5590 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5595 digit_value
= DIGIT2UINT (c
);
5606 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5608 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5609 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5611 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5619 add
= add
* 10 + digit_value
;
5625 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5626 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5627 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5630 result
= scm_divide (result
, big_shift
);
5632 /* We've seen a decimal point, thus the value is implicitly inexact. */
5644 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5646 switch (scm_i_string_ref (mem
, idx
))
5658 c
= scm_i_string_ref (mem
, idx
);
5666 c
= scm_i_string_ref (mem
, idx
);
5675 c
= scm_i_string_ref (mem
, idx
);
5680 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5684 exponent
= DIGIT2UINT (c
);
5687 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5688 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5691 if (exponent
<= SCM_MAXEXP
)
5692 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5698 if (exponent
> SCM_MAXEXP
)
5700 size_t exp_len
= idx
- start
;
5701 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5702 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5703 scm_out_of_range ("string->number", exp_num
);
5706 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5708 result
= scm_product (result
, e
);
5710 result
= scm_divide (result
, e
);
5712 /* We've seen an exponent, thus the value is implicitly inexact. */
5730 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5733 mem2ureal (SCM mem
, unsigned int *p_idx
,
5734 unsigned int radix
, enum t_exactness forced_x
)
5736 unsigned int idx
= *p_idx
;
5738 size_t len
= scm_i_string_length (mem
);
5740 /* Start off believing that the number will be exact. This changes
5741 to INEXACT if we see a decimal point or a hash. */
5742 enum t_exactness implicit_x
= EXACT
;
5747 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5753 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5755 /* Cobble up the fractional part. We might want to set the
5756 NaN's mantissa from it. */
5758 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
), SCM_INUM0
))
5760 #if SCM_ENABLE_DEPRECATED == 1
5761 scm_c_issue_deprecation_warning
5762 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5772 if (scm_i_string_ref (mem
, idx
) == '.')
5776 else if (idx
+ 1 == len
)
5778 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5781 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5782 p_idx
, &implicit_x
);
5788 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5789 if (scm_is_false (uinteger
))
5794 else if (scm_i_string_ref (mem
, idx
) == '/')
5802 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5803 if (scm_is_false (divisor
))
5806 /* both are int/big here, I assume */
5807 result
= scm_i_make_ratio (uinteger
, divisor
);
5809 else if (radix
== 10)
5811 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5812 if (scm_is_false (result
))
5824 if (SCM_INEXACTP (result
))
5825 return scm_inexact_to_exact (result
);
5829 if (SCM_INEXACTP (result
))
5832 return scm_exact_to_inexact (result
);
5834 if (implicit_x
== INEXACT
)
5836 if (SCM_INEXACTP (result
))
5839 return scm_exact_to_inexact (result
);
5845 /* We should never get here */
5846 scm_syserror ("mem2ureal");
5850 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5853 mem2complex (SCM mem
, unsigned int idx
,
5854 unsigned int radix
, enum t_exactness forced_x
)
5859 size_t len
= scm_i_string_length (mem
);
5864 c
= scm_i_string_ref (mem
, idx
);
5879 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5880 if (scm_is_false (ureal
))
5882 /* input must be either +i or -i */
5887 if (scm_i_string_ref (mem
, idx
) == 'i'
5888 || scm_i_string_ref (mem
, idx
) == 'I')
5894 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5901 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5902 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5907 c
= scm_i_string_ref (mem
, idx
);
5911 /* either +<ureal>i or -<ureal>i */
5918 return scm_make_rectangular (SCM_INUM0
, ureal
);
5921 /* polar input: <real>@<real>. */
5932 c
= scm_i_string_ref (mem
, idx
);
5950 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5951 if (scm_is_false (angle
))
5956 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5957 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5959 result
= scm_make_polar (ureal
, angle
);
5964 /* expecting input matching <real>[+-]<ureal>?i */
5971 int sign
= (c
== '+') ? 1 : -1;
5972 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5974 if (scm_is_false (imag
))
5975 imag
= SCM_I_MAKINUM (sign
);
5976 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5977 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5981 if (scm_i_string_ref (mem
, idx
) != 'i'
5982 && scm_i_string_ref (mem
, idx
) != 'I')
5989 return scm_make_rectangular (ureal
, imag
);
5998 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6000 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6003 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6005 unsigned int idx
= 0;
6006 unsigned int radix
= NO_RADIX
;
6007 enum t_exactness forced_x
= NO_EXACTNESS
;
6008 size_t len
= scm_i_string_length (mem
);
6010 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6011 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6013 switch (scm_i_string_ref (mem
, idx
+ 1))
6016 if (radix
!= NO_RADIX
)
6021 if (radix
!= NO_RADIX
)
6026 if (forced_x
!= NO_EXACTNESS
)
6031 if (forced_x
!= NO_EXACTNESS
)
6036 if (radix
!= NO_RADIX
)
6041 if (radix
!= NO_RADIX
)
6051 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6052 if (radix
== NO_RADIX
)
6053 radix
= default_radix
;
6055 return mem2complex (mem
, idx
, radix
, forced_x
);
6059 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6060 unsigned int default_radix
)
6062 SCM str
= scm_from_locale_stringn (mem
, len
);
6064 return scm_i_string_to_number (str
, default_radix
);
6068 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6069 (SCM string
, SCM radix
),
6070 "Return a number of the maximally precise representation\n"
6071 "expressed by the given @var{string}. @var{radix} must be an\n"
6072 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6073 "is a default radix that may be overridden by an explicit radix\n"
6074 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6075 "supplied, then the default radix is 10. If string is not a\n"
6076 "syntactically valid notation for a number, then\n"
6077 "@code{string->number} returns @code{#f}.")
6078 #define FUNC_NAME s_scm_string_to_number
6082 SCM_VALIDATE_STRING (1, string
);
6084 if (SCM_UNBNDP (radix
))
6087 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6089 answer
= scm_i_string_to_number (string
, base
);
6090 scm_remember_upto_here_1 (string
);
6096 /*** END strs->nums ***/
6099 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6101 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6103 #define FUNC_NAME s_scm_number_p
6105 return scm_from_bool (SCM_NUMBERP (x
));
6109 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6111 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6112 "otherwise. Note that the sets of real, rational and integer\n"
6113 "values form subsets of the set of complex numbers, i. e. the\n"
6114 "predicate will also be fulfilled if @var{x} is a real,\n"
6115 "rational or integer number.")
6116 #define FUNC_NAME s_scm_complex_p
6118 /* all numbers are complex. */
6119 return scm_number_p (x
);
6123 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6125 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6126 "otherwise. Note that the set of integer values forms a subset of\n"
6127 "the set of real numbers, i. e. the predicate will also be\n"
6128 "fulfilled if @var{x} is an integer number.")
6129 #define FUNC_NAME s_scm_real_p
6131 return scm_from_bool
6132 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6136 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6138 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6139 "otherwise. Note that the set of integer values forms a subset of\n"
6140 "the set of rational numbers, i. e. the predicate will also be\n"
6141 "fulfilled if @var{x} is an integer number.")
6142 #define FUNC_NAME s_scm_rational_p
6144 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6146 else if (SCM_REALP (x
))
6147 /* due to their limited precision, finite floating point numbers are
6148 rational as well. (finite means neither infinity nor a NaN) */
6149 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6155 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6157 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6159 #define FUNC_NAME s_scm_integer_p
6161 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6163 else if (SCM_REALP (x
))
6165 double val
= SCM_REAL_VALUE (x
);
6166 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6174 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6175 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6176 (SCM x
, SCM y
, SCM rest
),
6177 "Return @code{#t} if all parameters are numerically equal.")
6178 #define FUNC_NAME s_scm_i_num_eq_p
6180 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6182 while (!scm_is_null (rest
))
6184 if (scm_is_false (scm_num_eq_p (x
, y
)))
6188 rest
= scm_cdr (rest
);
6190 return scm_num_eq_p (x
, y
);
6194 scm_num_eq_p (SCM x
, SCM y
)
6197 if (SCM_I_INUMP (x
))
6199 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6200 if (SCM_I_INUMP (y
))
6202 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6203 return scm_from_bool (xx
== yy
);
6205 else if (SCM_BIGP (y
))
6207 else if (SCM_REALP (y
))
6209 /* On a 32-bit system an inum fits a double, we can cast the inum
6210 to a double and compare.
6212 But on a 64-bit system an inum is bigger than a double and
6213 casting it to a double (call that dxx) will round. dxx is at
6214 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6215 an integer and fits a long. So we cast yy to a long and
6216 compare with plain xx.
6218 An alternative (for any size system actually) would be to check
6219 yy is an integer (with floor) and is in range of an inum
6220 (compare against appropriate powers of 2) then test
6221 xx==(scm_t_signed_bits)yy. It's just a matter of which
6222 casts/comparisons might be fastest or easiest for the cpu. */
6224 double yy
= SCM_REAL_VALUE (y
);
6225 return scm_from_bool ((double) xx
== yy
6226 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6227 || xx
== (scm_t_signed_bits
) yy
));
6229 else if (SCM_COMPLEXP (y
))
6230 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6231 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6232 else if (SCM_FRACTIONP (y
))
6235 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6238 else if (SCM_BIGP (x
))
6240 if (SCM_I_INUMP (y
))
6242 else if (SCM_BIGP (y
))
6244 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6245 scm_remember_upto_here_2 (x
, y
);
6246 return scm_from_bool (0 == cmp
);
6248 else if (SCM_REALP (y
))
6251 if (isnan (SCM_REAL_VALUE (y
)))
6253 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6254 scm_remember_upto_here_1 (x
);
6255 return scm_from_bool (0 == cmp
);
6257 else if (SCM_COMPLEXP (y
))
6260 if (0.0 != SCM_COMPLEX_IMAG (y
))
6262 if (isnan (SCM_COMPLEX_REAL (y
)))
6264 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6265 scm_remember_upto_here_1 (x
);
6266 return scm_from_bool (0 == cmp
);
6268 else if (SCM_FRACTIONP (y
))
6271 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6274 else if (SCM_REALP (x
))
6276 double xx
= SCM_REAL_VALUE (x
);
6277 if (SCM_I_INUMP (y
))
6279 /* see comments with inum/real above */
6280 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6281 return scm_from_bool (xx
== (double) yy
6282 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6283 || (scm_t_signed_bits
) xx
== yy
));
6285 else if (SCM_BIGP (y
))
6288 if (isnan (SCM_REAL_VALUE (x
)))
6290 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6291 scm_remember_upto_here_1 (y
);
6292 return scm_from_bool (0 == cmp
);
6294 else if (SCM_REALP (y
))
6295 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6296 else if (SCM_COMPLEXP (y
))
6297 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6298 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6299 else if (SCM_FRACTIONP (y
))
6301 double xx
= SCM_REAL_VALUE (x
);
6305 return scm_from_bool (xx
< 0.0);
6306 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6310 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6313 else if (SCM_COMPLEXP (x
))
6315 if (SCM_I_INUMP (y
))
6316 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6317 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6318 else if (SCM_BIGP (y
))
6321 if (0.0 != SCM_COMPLEX_IMAG (x
))
6323 if (isnan (SCM_COMPLEX_REAL (x
)))
6325 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6326 scm_remember_upto_here_1 (y
);
6327 return scm_from_bool (0 == cmp
);
6329 else if (SCM_REALP (y
))
6330 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6331 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6332 else if (SCM_COMPLEXP (y
))
6333 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6334 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6335 else if (SCM_FRACTIONP (y
))
6338 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6340 xx
= SCM_COMPLEX_REAL (x
);
6344 return scm_from_bool (xx
< 0.0);
6345 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6349 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6352 else if (SCM_FRACTIONP (x
))
6354 if (SCM_I_INUMP (y
))
6356 else if (SCM_BIGP (y
))
6358 else if (SCM_REALP (y
))
6360 double yy
= SCM_REAL_VALUE (y
);
6364 return scm_from_bool (0.0 < yy
);
6365 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6368 else if (SCM_COMPLEXP (y
))
6371 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6373 yy
= SCM_COMPLEX_REAL (y
);
6377 return scm_from_bool (0.0 < yy
);
6378 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6381 else if (SCM_FRACTIONP (y
))
6382 return scm_i_fraction_equalp (x
, y
);
6384 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6388 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6393 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6394 done are good for inums, but for bignums an answer can almost always be
6395 had by just examining a few high bits of the operands, as done by GMP in
6396 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6397 of the float exponent to take into account. */
6399 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6400 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6401 (SCM x
, SCM y
, SCM rest
),
6402 "Return @code{#t} if the list of parameters is monotonically\n"
6404 #define FUNC_NAME s_scm_i_num_less_p
6406 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6408 while (!scm_is_null (rest
))
6410 if (scm_is_false (scm_less_p (x
, y
)))
6414 rest
= scm_cdr (rest
);
6416 return scm_less_p (x
, y
);
6420 scm_less_p (SCM x
, SCM y
)
6423 if (SCM_I_INUMP (x
))
6425 scm_t_inum xx
= SCM_I_INUM (x
);
6426 if (SCM_I_INUMP (y
))
6428 scm_t_inum yy
= SCM_I_INUM (y
);
6429 return scm_from_bool (xx
< yy
);
6431 else if (SCM_BIGP (y
))
6433 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6434 scm_remember_upto_here_1 (y
);
6435 return scm_from_bool (sgn
> 0);
6437 else if (SCM_REALP (y
))
6438 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6439 else if (SCM_FRACTIONP (y
))
6441 /* "x < a/b" becomes "x*b < a" */
6443 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6444 y
= SCM_FRACTION_NUMERATOR (y
);
6448 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6449 s_scm_i_num_less_p
);
6451 else if (SCM_BIGP (x
))
6453 if (SCM_I_INUMP (y
))
6455 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6456 scm_remember_upto_here_1 (x
);
6457 return scm_from_bool (sgn
< 0);
6459 else if (SCM_BIGP (y
))
6461 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6462 scm_remember_upto_here_2 (x
, y
);
6463 return scm_from_bool (cmp
< 0);
6465 else if (SCM_REALP (y
))
6468 if (isnan (SCM_REAL_VALUE (y
)))
6470 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6471 scm_remember_upto_here_1 (x
);
6472 return scm_from_bool (cmp
< 0);
6474 else if (SCM_FRACTIONP (y
))
6477 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6478 s_scm_i_num_less_p
);
6480 else if (SCM_REALP (x
))
6482 if (SCM_I_INUMP (y
))
6483 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6484 else if (SCM_BIGP (y
))
6487 if (isnan (SCM_REAL_VALUE (x
)))
6489 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6490 scm_remember_upto_here_1 (y
);
6491 return scm_from_bool (cmp
> 0);
6493 else if (SCM_REALP (y
))
6494 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6495 else if (SCM_FRACTIONP (y
))
6497 double xx
= SCM_REAL_VALUE (x
);
6501 return scm_from_bool (xx
< 0.0);
6502 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6506 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6507 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 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6541 s_scm_i_num_less_p
);
6544 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6545 s_scm_i_num_less_p
);
6549 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6550 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6551 (SCM x
, SCM y
, SCM rest
),
6552 "Return @code{#t} if the list of parameters is monotonically\n"
6554 #define FUNC_NAME s_scm_i_num_gr_p
6556 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6558 while (!scm_is_null (rest
))
6560 if (scm_is_false (scm_gr_p (x
, y
)))
6564 rest
= scm_cdr (rest
);
6566 return scm_gr_p (x
, y
);
6569 #define FUNC_NAME s_scm_i_num_gr_p
6571 scm_gr_p (SCM x
, SCM y
)
6573 if (!SCM_NUMBERP (x
))
6574 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6575 else if (!SCM_NUMBERP (y
))
6576 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6578 return scm_less_p (y
, x
);
6583 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6584 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6585 (SCM x
, SCM y
, SCM rest
),
6586 "Return @code{#t} if the list of parameters is monotonically\n"
6588 #define FUNC_NAME s_scm_i_num_leq_p
6590 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6592 while (!scm_is_null (rest
))
6594 if (scm_is_false (scm_leq_p (x
, y
)))
6598 rest
= scm_cdr (rest
);
6600 return scm_leq_p (x
, y
);
6603 #define FUNC_NAME s_scm_i_num_leq_p
6605 scm_leq_p (SCM x
, SCM y
)
6607 if (!SCM_NUMBERP (x
))
6608 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6609 else if (!SCM_NUMBERP (y
))
6610 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6611 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6614 return scm_not (scm_less_p (y
, x
));
6619 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6620 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6621 (SCM x
, SCM y
, SCM rest
),
6622 "Return @code{#t} if the list of parameters is monotonically\n"
6624 #define FUNC_NAME s_scm_i_num_geq_p
6626 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6628 while (!scm_is_null (rest
))
6630 if (scm_is_false (scm_geq_p (x
, y
)))
6634 rest
= scm_cdr (rest
);
6636 return scm_geq_p (x
, y
);
6639 #define FUNC_NAME s_scm_i_num_geq_p
6641 scm_geq_p (SCM x
, SCM y
)
6643 if (!SCM_NUMBERP (x
))
6644 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6645 else if (!SCM_NUMBERP (y
))
6646 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6647 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6650 return scm_not (scm_less_p (x
, y
));
6655 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6657 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6659 #define FUNC_NAME s_scm_zero_p
6661 if (SCM_I_INUMP (z
))
6662 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6663 else if (SCM_BIGP (z
))
6665 else if (SCM_REALP (z
))
6666 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6667 else if (SCM_COMPLEXP (z
))
6668 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6669 && SCM_COMPLEX_IMAG (z
) == 0.0);
6670 else if (SCM_FRACTIONP (z
))
6673 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6678 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6680 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6682 #define FUNC_NAME s_scm_positive_p
6684 if (SCM_I_INUMP (x
))
6685 return scm_from_bool (SCM_I_INUM (x
) > 0);
6686 else if (SCM_BIGP (x
))
6688 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6689 scm_remember_upto_here_1 (x
);
6690 return scm_from_bool (sgn
> 0);
6692 else if (SCM_REALP (x
))
6693 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6694 else if (SCM_FRACTIONP (x
))
6695 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6697 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6702 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6704 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6706 #define FUNC_NAME s_scm_negative_p
6708 if (SCM_I_INUMP (x
))
6709 return scm_from_bool (SCM_I_INUM (x
) < 0);
6710 else if (SCM_BIGP (x
))
6712 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6713 scm_remember_upto_here_1 (x
);
6714 return scm_from_bool (sgn
< 0);
6716 else if (SCM_REALP (x
))
6717 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6718 else if (SCM_FRACTIONP (x
))
6719 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6721 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6726 /* scm_min and scm_max return an inexact when either argument is inexact, as
6727 required by r5rs. On that basis, for exact/inexact combinations the
6728 exact is converted to inexact to compare and possibly return. This is
6729 unlike scm_less_p above which takes some trouble to preserve all bits in
6730 its test, such trouble is not required for min and max. */
6732 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6733 (SCM x
, SCM y
, SCM rest
),
6734 "Return the maximum of all parameter values.")
6735 #define FUNC_NAME s_scm_i_max
6737 while (!scm_is_null (rest
))
6738 { x
= scm_max (x
, y
);
6740 rest
= scm_cdr (rest
);
6742 return scm_max (x
, y
);
6746 #define s_max s_scm_i_max
6747 #define g_max g_scm_i_max
6750 scm_max (SCM x
, SCM y
)
6755 return scm_wta_dispatch_0 (g_max
, s_max
);
6756 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6759 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
6762 if (SCM_I_INUMP (x
))
6764 scm_t_inum xx
= SCM_I_INUM (x
);
6765 if (SCM_I_INUMP (y
))
6767 scm_t_inum yy
= SCM_I_INUM (y
);
6768 return (xx
< yy
) ? y
: x
;
6770 else if (SCM_BIGP (y
))
6772 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6773 scm_remember_upto_here_1 (y
);
6774 return (sgn
< 0) ? x
: y
;
6776 else if (SCM_REALP (y
))
6779 double yyd
= SCM_REAL_VALUE (y
);
6782 return scm_from_double (xxd
);
6783 /* If y is a NaN, then "==" is false and we return the NaN */
6784 else if (SCM_LIKELY (!(xxd
== yyd
)))
6786 /* Handle signed zeroes properly */
6792 else if (SCM_FRACTIONP (y
))
6795 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6798 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6800 else if (SCM_BIGP (x
))
6802 if (SCM_I_INUMP (y
))
6804 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6805 scm_remember_upto_here_1 (x
);
6806 return (sgn
< 0) ? y
: x
;
6808 else if (SCM_BIGP (y
))
6810 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6811 scm_remember_upto_here_2 (x
, y
);
6812 return (cmp
> 0) ? x
: y
;
6814 else if (SCM_REALP (y
))
6816 /* if y==NaN then xx>yy is false, so we return the NaN y */
6819 xx
= scm_i_big2dbl (x
);
6820 yy
= SCM_REAL_VALUE (y
);
6821 return (xx
> yy
? scm_from_double (xx
) : y
);
6823 else if (SCM_FRACTIONP (y
))
6828 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6830 else if (SCM_REALP (x
))
6832 if (SCM_I_INUMP (y
))
6834 scm_t_inum yy
= SCM_I_INUM (y
);
6835 double xxd
= SCM_REAL_VALUE (x
);
6839 return scm_from_double (yyd
);
6840 /* If x is a NaN, then "==" is false and we return the NaN */
6841 else if (SCM_LIKELY (!(xxd
== yyd
)))
6843 /* Handle signed zeroes properly */
6849 else if (SCM_BIGP (y
))
6854 else if (SCM_REALP (y
))
6856 double xx
= SCM_REAL_VALUE (x
);
6857 double yy
= SCM_REAL_VALUE (y
);
6859 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6862 else if (SCM_LIKELY (xx
< yy
))
6864 /* If neither (xx > yy) nor (xx < yy), then
6865 either they're equal or one is a NaN */
6866 else if (SCM_UNLIKELY (isnan (xx
)))
6867 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6868 else if (SCM_UNLIKELY (isnan (yy
)))
6869 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6870 /* xx == yy, but handle signed zeroes properly */
6871 else if (double_is_non_negative_zero (yy
))
6876 else if (SCM_FRACTIONP (y
))
6878 double yy
= scm_i_fraction2double (y
);
6879 double xx
= SCM_REAL_VALUE (x
);
6880 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6883 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6885 else if (SCM_FRACTIONP (x
))
6887 if (SCM_I_INUMP (y
))
6891 else if (SCM_BIGP (y
))
6895 else if (SCM_REALP (y
))
6897 double xx
= scm_i_fraction2double (x
);
6898 /* if y==NaN then ">" is false, so we return the NaN y */
6899 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6901 else if (SCM_FRACTIONP (y
))
6906 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6909 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6913 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6914 (SCM x
, SCM y
, SCM rest
),
6915 "Return the minimum of all parameter values.")
6916 #define FUNC_NAME s_scm_i_min
6918 while (!scm_is_null (rest
))
6919 { x
= scm_min (x
, y
);
6921 rest
= scm_cdr (rest
);
6923 return scm_min (x
, y
);
6927 #define s_min s_scm_i_min
6928 #define g_min g_scm_i_min
6931 scm_min (SCM x
, SCM y
)
6936 return scm_wta_dispatch_0 (g_min
, s_min
);
6937 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6940 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
6943 if (SCM_I_INUMP (x
))
6945 scm_t_inum xx
= SCM_I_INUM (x
);
6946 if (SCM_I_INUMP (y
))
6948 scm_t_inum yy
= SCM_I_INUM (y
);
6949 return (xx
< yy
) ? x
: y
;
6951 else if (SCM_BIGP (y
))
6953 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6954 scm_remember_upto_here_1 (y
);
6955 return (sgn
< 0) ? y
: x
;
6957 else if (SCM_REALP (y
))
6960 /* if y==NaN then "<" is false and we return NaN */
6961 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6963 else if (SCM_FRACTIONP (y
))
6966 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6969 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6971 else if (SCM_BIGP (x
))
6973 if (SCM_I_INUMP (y
))
6975 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6976 scm_remember_upto_here_1 (x
);
6977 return (sgn
< 0) ? x
: y
;
6979 else if (SCM_BIGP (y
))
6981 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6982 scm_remember_upto_here_2 (x
, y
);
6983 return (cmp
> 0) ? y
: x
;
6985 else if (SCM_REALP (y
))
6987 /* if y==NaN then xx<yy is false, so we return the NaN y */
6990 xx
= scm_i_big2dbl (x
);
6991 yy
= SCM_REAL_VALUE (y
);
6992 return (xx
< yy
? scm_from_double (xx
) : y
);
6994 else if (SCM_FRACTIONP (y
))
6999 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7001 else if (SCM_REALP (x
))
7003 if (SCM_I_INUMP (y
))
7005 double z
= SCM_I_INUM (y
);
7006 /* if x==NaN then "<" is false and we return NaN */
7007 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7009 else if (SCM_BIGP (y
))
7014 else if (SCM_REALP (y
))
7016 double xx
= SCM_REAL_VALUE (x
);
7017 double yy
= SCM_REAL_VALUE (y
);
7019 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7022 else if (SCM_LIKELY (xx
> yy
))
7024 /* If neither (xx < yy) nor (xx > yy), then
7025 either they're equal or one is a NaN */
7026 else if (SCM_UNLIKELY (isnan (xx
)))
7027 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7028 else if (SCM_UNLIKELY (isnan (yy
)))
7029 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7030 /* xx == yy, but handle signed zeroes properly */
7031 else if (double_is_non_negative_zero (xx
))
7036 else if (SCM_FRACTIONP (y
))
7038 double yy
= scm_i_fraction2double (y
);
7039 double xx
= SCM_REAL_VALUE (x
);
7040 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7043 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7045 else if (SCM_FRACTIONP (x
))
7047 if (SCM_I_INUMP (y
))
7051 else if (SCM_BIGP (y
))
7055 else if (SCM_REALP (y
))
7057 double xx
= scm_i_fraction2double (x
);
7058 /* if y==NaN then "<" is false, so we return the NaN y */
7059 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7061 else if (SCM_FRACTIONP (y
))
7066 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7069 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7073 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7074 (SCM x
, SCM y
, SCM rest
),
7075 "Return the sum of all parameter values. Return 0 if called without\n"
7077 #define FUNC_NAME s_scm_i_sum
7079 while (!scm_is_null (rest
))
7080 { x
= scm_sum (x
, y
);
7082 rest
= scm_cdr (rest
);
7084 return scm_sum (x
, y
);
7088 #define s_sum s_scm_i_sum
7089 #define g_sum g_scm_i_sum
7092 scm_sum (SCM x
, SCM y
)
7094 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7096 if (SCM_NUMBERP (x
)) return x
;
7097 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7098 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7101 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7103 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7105 scm_t_inum xx
= SCM_I_INUM (x
);
7106 scm_t_inum yy
= SCM_I_INUM (y
);
7107 scm_t_inum z
= xx
+ yy
;
7108 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7110 else if (SCM_BIGP (y
))
7115 else if (SCM_REALP (y
))
7117 scm_t_inum xx
= SCM_I_INUM (x
);
7118 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7120 else if (SCM_COMPLEXP (y
))
7122 scm_t_inum xx
= SCM_I_INUM (x
);
7123 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7124 SCM_COMPLEX_IMAG (y
));
7126 else if (SCM_FRACTIONP (y
))
7127 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7128 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7129 SCM_FRACTION_DENOMINATOR (y
));
7131 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7132 } else if (SCM_BIGP (x
))
7134 if (SCM_I_INUMP (y
))
7139 inum
= SCM_I_INUM (y
);
7142 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7145 SCM result
= scm_i_mkbig ();
7146 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7147 scm_remember_upto_here_1 (x
);
7148 /* we know the result will have to be a bignum */
7151 return scm_i_normbig (result
);
7155 SCM result
= scm_i_mkbig ();
7156 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7157 scm_remember_upto_here_1 (x
);
7158 /* we know the result will have to be a bignum */
7161 return scm_i_normbig (result
);
7164 else if (SCM_BIGP (y
))
7166 SCM result
= scm_i_mkbig ();
7167 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7168 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7169 mpz_add (SCM_I_BIG_MPZ (result
),
7172 scm_remember_upto_here_2 (x
, y
);
7173 /* we know the result will have to be a bignum */
7176 return scm_i_normbig (result
);
7178 else if (SCM_REALP (y
))
7180 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7181 scm_remember_upto_here_1 (x
);
7182 return scm_from_double (result
);
7184 else if (SCM_COMPLEXP (y
))
7186 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7187 + SCM_COMPLEX_REAL (y
));
7188 scm_remember_upto_here_1 (x
);
7189 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7191 else if (SCM_FRACTIONP (y
))
7192 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7193 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7194 SCM_FRACTION_DENOMINATOR (y
));
7196 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7198 else if (SCM_REALP (x
))
7200 if (SCM_I_INUMP (y
))
7201 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7202 else if (SCM_BIGP (y
))
7204 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7205 scm_remember_upto_here_1 (y
);
7206 return scm_from_double (result
);
7208 else if (SCM_REALP (y
))
7209 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7210 else if (SCM_COMPLEXP (y
))
7211 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7212 SCM_COMPLEX_IMAG (y
));
7213 else if (SCM_FRACTIONP (y
))
7214 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7216 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7218 else if (SCM_COMPLEXP (x
))
7220 if (SCM_I_INUMP (y
))
7221 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7222 SCM_COMPLEX_IMAG (x
));
7223 else if (SCM_BIGP (y
))
7225 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7226 + SCM_COMPLEX_REAL (x
));
7227 scm_remember_upto_here_1 (y
);
7228 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7230 else if (SCM_REALP (y
))
7231 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7232 SCM_COMPLEX_IMAG (x
));
7233 else if (SCM_COMPLEXP (y
))
7234 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7235 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7236 else if (SCM_FRACTIONP (y
))
7237 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7238 SCM_COMPLEX_IMAG (x
));
7240 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7242 else if (SCM_FRACTIONP (x
))
7244 if (SCM_I_INUMP (y
))
7245 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7246 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7247 SCM_FRACTION_DENOMINATOR (x
));
7248 else if (SCM_BIGP (y
))
7249 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7250 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7251 SCM_FRACTION_DENOMINATOR (x
));
7252 else if (SCM_REALP (y
))
7253 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7254 else if (SCM_COMPLEXP (y
))
7255 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7256 SCM_COMPLEX_IMAG (y
));
7257 else if (SCM_FRACTIONP (y
))
7258 /* a/b + c/d = (ad + bc) / bd */
7259 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7260 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7261 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7263 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7266 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7270 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7272 "Return @math{@var{x}+1}.")
7273 #define FUNC_NAME s_scm_oneplus
7275 return scm_sum (x
, SCM_INUM1
);
7280 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7281 (SCM x
, SCM y
, SCM rest
),
7282 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7283 "the sum of all but the first argument are subtracted from the first\n"
7285 #define FUNC_NAME s_scm_i_difference
7287 while (!scm_is_null (rest
))
7288 { x
= scm_difference (x
, y
);
7290 rest
= scm_cdr (rest
);
7292 return scm_difference (x
, y
);
7296 #define s_difference s_scm_i_difference
7297 #define g_difference g_scm_i_difference
7300 scm_difference (SCM x
, SCM y
)
7301 #define FUNC_NAME s_difference
7303 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7306 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7308 if (SCM_I_INUMP (x
))
7310 scm_t_inum xx
= -SCM_I_INUM (x
);
7311 if (SCM_FIXABLE (xx
))
7312 return SCM_I_MAKINUM (xx
);
7314 return scm_i_inum2big (xx
);
7316 else if (SCM_BIGP (x
))
7317 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7318 bignum, but negating that gives a fixnum. */
7319 return scm_i_normbig (scm_i_clonebig (x
, 0));
7320 else if (SCM_REALP (x
))
7321 return scm_from_double (-SCM_REAL_VALUE (x
));
7322 else if (SCM_COMPLEXP (x
))
7323 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7324 -SCM_COMPLEX_IMAG (x
));
7325 else if (SCM_FRACTIONP (x
))
7326 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7327 SCM_FRACTION_DENOMINATOR (x
));
7329 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7332 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7334 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7336 scm_t_inum xx
= SCM_I_INUM (x
);
7337 scm_t_inum yy
= SCM_I_INUM (y
);
7338 scm_t_inum z
= xx
- yy
;
7339 if (SCM_FIXABLE (z
))
7340 return SCM_I_MAKINUM (z
);
7342 return scm_i_inum2big (z
);
7344 else if (SCM_BIGP (y
))
7346 /* inum-x - big-y */
7347 scm_t_inum xx
= SCM_I_INUM (x
);
7351 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7352 bignum, but negating that gives a fixnum. */
7353 return scm_i_normbig (scm_i_clonebig (y
, 0));
7357 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7358 SCM result
= scm_i_mkbig ();
7361 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7364 /* x - y == -(y + -x) */
7365 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7366 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7368 scm_remember_upto_here_1 (y
);
7370 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7371 /* we know the result will have to be a bignum */
7374 return scm_i_normbig (result
);
7377 else if (SCM_REALP (y
))
7379 scm_t_inum xx
= SCM_I_INUM (x
);
7382 * We need to handle x == exact 0
7383 * specially because R6RS states that:
7384 * (- 0.0) ==> -0.0 and
7385 * (- 0.0 0.0) ==> 0.0
7386 * and the scheme compiler changes
7387 * (- 0.0) into (- 0 0.0)
7388 * So we need to treat (- 0 0.0) like (- 0.0).
7389 * At the C level, (-x) is different than (0.0 - x).
7390 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7393 return scm_from_double (- SCM_REAL_VALUE (y
));
7395 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7397 else if (SCM_COMPLEXP (y
))
7399 scm_t_inum xx
= SCM_I_INUM (x
);
7401 /* We need to handle x == exact 0 specially.
7402 See the comment above (for SCM_REALP (y)) */
7404 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7405 - SCM_COMPLEX_IMAG (y
));
7407 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7408 - SCM_COMPLEX_IMAG (y
));
7410 else if (SCM_FRACTIONP (y
))
7411 /* a - b/c = (ac - b) / c */
7412 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7413 SCM_FRACTION_NUMERATOR (y
)),
7414 SCM_FRACTION_DENOMINATOR (y
));
7416 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7418 else if (SCM_BIGP (x
))
7420 if (SCM_I_INUMP (y
))
7422 /* big-x - inum-y */
7423 scm_t_inum yy
= SCM_I_INUM (y
);
7424 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7426 scm_remember_upto_here_1 (x
);
7428 return (SCM_FIXABLE (-yy
) ?
7429 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7432 SCM result
= scm_i_mkbig ();
7435 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7437 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7438 scm_remember_upto_here_1 (x
);
7440 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7441 /* we know the result will have to be a bignum */
7444 return scm_i_normbig (result
);
7447 else if (SCM_BIGP (y
))
7449 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7450 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7451 SCM result
= scm_i_mkbig ();
7452 mpz_sub (SCM_I_BIG_MPZ (result
),
7455 scm_remember_upto_here_2 (x
, y
);
7456 /* we know the result will have to be a bignum */
7457 if ((sgn_x
== 1) && (sgn_y
== -1))
7459 if ((sgn_x
== -1) && (sgn_y
== 1))
7461 return scm_i_normbig (result
);
7463 else if (SCM_REALP (y
))
7465 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7466 scm_remember_upto_here_1 (x
);
7467 return scm_from_double (result
);
7469 else if (SCM_COMPLEXP (y
))
7471 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7472 - SCM_COMPLEX_REAL (y
));
7473 scm_remember_upto_here_1 (x
);
7474 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7476 else if (SCM_FRACTIONP (y
))
7477 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7478 SCM_FRACTION_NUMERATOR (y
)),
7479 SCM_FRACTION_DENOMINATOR (y
));
7481 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7483 else if (SCM_REALP (x
))
7485 if (SCM_I_INUMP (y
))
7486 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7487 else if (SCM_BIGP (y
))
7489 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7490 scm_remember_upto_here_1 (x
);
7491 return scm_from_double (result
);
7493 else if (SCM_REALP (y
))
7494 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7495 else if (SCM_COMPLEXP (y
))
7496 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7497 -SCM_COMPLEX_IMAG (y
));
7498 else if (SCM_FRACTIONP (y
))
7499 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7501 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7503 else if (SCM_COMPLEXP (x
))
7505 if (SCM_I_INUMP (y
))
7506 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7507 SCM_COMPLEX_IMAG (x
));
7508 else if (SCM_BIGP (y
))
7510 double real_part
= (SCM_COMPLEX_REAL (x
)
7511 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7512 scm_remember_upto_here_1 (x
);
7513 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7515 else if (SCM_REALP (y
))
7516 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7517 SCM_COMPLEX_IMAG (x
));
7518 else if (SCM_COMPLEXP (y
))
7519 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7520 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7521 else if (SCM_FRACTIONP (y
))
7522 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7523 SCM_COMPLEX_IMAG (x
));
7525 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7527 else if (SCM_FRACTIONP (x
))
7529 if (SCM_I_INUMP (y
))
7530 /* a/b - c = (a - cb) / b */
7531 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7532 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7533 SCM_FRACTION_DENOMINATOR (x
));
7534 else if (SCM_BIGP (y
))
7535 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7536 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7537 SCM_FRACTION_DENOMINATOR (x
));
7538 else if (SCM_REALP (y
))
7539 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7540 else if (SCM_COMPLEXP (y
))
7541 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7542 -SCM_COMPLEX_IMAG (y
));
7543 else if (SCM_FRACTIONP (y
))
7544 /* a/b - c/d = (ad - bc) / bd */
7545 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7546 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7547 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7549 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7552 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7557 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7559 "Return @math{@var{x}-1}.")
7560 #define FUNC_NAME s_scm_oneminus
7562 return scm_difference (x
, SCM_INUM1
);
7567 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7568 (SCM x
, SCM y
, SCM rest
),
7569 "Return the product of all arguments. If called without arguments,\n"
7571 #define FUNC_NAME s_scm_i_product
7573 while (!scm_is_null (rest
))
7574 { x
= scm_product (x
, y
);
7576 rest
= scm_cdr (rest
);
7578 return scm_product (x
, y
);
7582 #define s_product s_scm_i_product
7583 #define g_product g_scm_i_product
7586 scm_product (SCM x
, SCM y
)
7588 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7591 return SCM_I_MAKINUM (1L);
7592 else if (SCM_NUMBERP (x
))
7595 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
7598 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7603 xx
= SCM_I_INUM (x
);
7608 /* exact1 is the universal multiplicative identity */
7612 /* exact0 times a fixnum is exact0: optimize this case */
7613 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7615 /* if the other argument is inexact, the result is inexact,
7616 and we must do the multiplication in order to handle
7617 infinities and NaNs properly. */
7618 else if (SCM_REALP (y
))
7619 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7620 else if (SCM_COMPLEXP (y
))
7621 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7622 0.0 * SCM_COMPLEX_IMAG (y
));
7623 /* we've already handled inexact numbers,
7624 so y must be exact, and we return exact0 */
7625 else if (SCM_NUMP (y
))
7628 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7632 * This case is important for more than just optimization.
7633 * It handles the case of negating
7634 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7635 * which is a bignum that must be changed back into a fixnum.
7636 * Failure to do so will cause the following to return #f:
7637 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7639 return scm_difference(y
, SCM_UNDEFINED
);
7643 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7645 scm_t_inum yy
= SCM_I_INUM (y
);
7646 scm_t_inum kk
= xx
* yy
;
7647 SCM k
= SCM_I_MAKINUM (kk
);
7648 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7652 SCM result
= scm_i_inum2big (xx
);
7653 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7654 return scm_i_normbig (result
);
7657 else if (SCM_BIGP (y
))
7659 SCM result
= scm_i_mkbig ();
7660 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7661 scm_remember_upto_here_1 (y
);
7664 else if (SCM_REALP (y
))
7665 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7666 else if (SCM_COMPLEXP (y
))
7667 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7668 xx
* SCM_COMPLEX_IMAG (y
));
7669 else if (SCM_FRACTIONP (y
))
7670 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7671 SCM_FRACTION_DENOMINATOR (y
));
7673 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7675 else if (SCM_BIGP (x
))
7677 if (SCM_I_INUMP (y
))
7682 else if (SCM_BIGP (y
))
7684 SCM result
= scm_i_mkbig ();
7685 mpz_mul (SCM_I_BIG_MPZ (result
),
7688 scm_remember_upto_here_2 (x
, y
);
7691 else if (SCM_REALP (y
))
7693 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7694 scm_remember_upto_here_1 (x
);
7695 return scm_from_double (result
);
7697 else if (SCM_COMPLEXP (y
))
7699 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7700 scm_remember_upto_here_1 (x
);
7701 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7702 z
* SCM_COMPLEX_IMAG (y
));
7704 else if (SCM_FRACTIONP (y
))
7705 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7706 SCM_FRACTION_DENOMINATOR (y
));
7708 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7710 else if (SCM_REALP (x
))
7712 if (SCM_I_INUMP (y
))
7717 else if (SCM_BIGP (y
))
7719 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7720 scm_remember_upto_here_1 (y
);
7721 return scm_from_double (result
);
7723 else if (SCM_REALP (y
))
7724 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7725 else if (SCM_COMPLEXP (y
))
7726 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7727 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7728 else if (SCM_FRACTIONP (y
))
7729 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7731 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7733 else if (SCM_COMPLEXP (x
))
7735 if (SCM_I_INUMP (y
))
7740 else if (SCM_BIGP (y
))
7742 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7743 scm_remember_upto_here_1 (y
);
7744 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7745 z
* SCM_COMPLEX_IMAG (x
));
7747 else if (SCM_REALP (y
))
7748 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7749 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7750 else if (SCM_COMPLEXP (y
))
7752 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7753 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7754 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7755 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7757 else if (SCM_FRACTIONP (y
))
7759 double yy
= scm_i_fraction2double (y
);
7760 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7761 yy
* SCM_COMPLEX_IMAG (x
));
7764 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7766 else if (SCM_FRACTIONP (x
))
7768 if (SCM_I_INUMP (y
))
7769 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7770 SCM_FRACTION_DENOMINATOR (x
));
7771 else if (SCM_BIGP (y
))
7772 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7773 SCM_FRACTION_DENOMINATOR (x
));
7774 else if (SCM_REALP (y
))
7775 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7776 else if (SCM_COMPLEXP (y
))
7778 double xx
= scm_i_fraction2double (x
);
7779 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7780 xx
* SCM_COMPLEX_IMAG (y
));
7782 else if (SCM_FRACTIONP (y
))
7783 /* a/b * c/d = ac / bd */
7784 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7785 SCM_FRACTION_NUMERATOR (y
)),
7786 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7787 SCM_FRACTION_DENOMINATOR (y
)));
7789 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7792 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7795 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7796 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7797 #define ALLOW_DIVIDE_BY_ZERO
7798 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7801 /* The code below for complex division is adapted from the GNU
7802 libstdc++, which adapted it from f2c's libF77, and is subject to
7805 /****************************************************************
7806 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7808 Permission to use, copy, modify, and distribute this software
7809 and its documentation for any purpose and without fee is hereby
7810 granted, provided that the above copyright notice appear in all
7811 copies and that both that the copyright notice and this
7812 permission notice and warranty disclaimer appear in supporting
7813 documentation, and that the names of AT&T Bell Laboratories or
7814 Bellcore or any of their entities not be used in advertising or
7815 publicity pertaining to distribution of the software without
7816 specific, written prior permission.
7818 AT&T and Bellcore disclaim all warranties with regard to this
7819 software, including all implied warranties of merchantability
7820 and fitness. In no event shall AT&T or Bellcore be liable for
7821 any special, indirect or consequential damages or any damages
7822 whatsoever resulting from loss of use, data or profits, whether
7823 in an action of contract, negligence or other tortious action,
7824 arising out of or in connection with the use or performance of
7826 ****************************************************************/
7828 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7829 (SCM x
, SCM y
, SCM rest
),
7830 "Divide the first argument by the product of the remaining\n"
7831 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7833 #define FUNC_NAME s_scm_i_divide
7835 while (!scm_is_null (rest
))
7836 { x
= scm_divide (x
, y
);
7838 rest
= scm_cdr (rest
);
7840 return scm_divide (x
, y
);
7844 #define s_divide s_scm_i_divide
7845 #define g_divide g_scm_i_divide
7848 do_divide (SCM x
, SCM y
, int inexact
)
7849 #define FUNC_NAME s_divide
7853 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7856 return scm_wta_dispatch_0 (g_divide
, s_divide
);
7857 else if (SCM_I_INUMP (x
))
7859 scm_t_inum xx
= SCM_I_INUM (x
);
7860 if (xx
== 1 || xx
== -1)
7862 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7864 scm_num_overflow (s_divide
);
7869 return scm_from_double (1.0 / (double) xx
);
7870 else return scm_i_make_ratio (SCM_INUM1
, x
);
7873 else if (SCM_BIGP (x
))
7876 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7877 else return scm_i_make_ratio (SCM_INUM1
, x
);
7879 else if (SCM_REALP (x
))
7881 double xx
= SCM_REAL_VALUE (x
);
7882 #ifndef ALLOW_DIVIDE_BY_ZERO
7884 scm_num_overflow (s_divide
);
7887 return scm_from_double (1.0 / xx
);
7889 else if (SCM_COMPLEXP (x
))
7891 double r
= SCM_COMPLEX_REAL (x
);
7892 double i
= SCM_COMPLEX_IMAG (x
);
7893 if (fabs(r
) <= fabs(i
))
7896 double d
= i
* (1.0 + t
* t
);
7897 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7902 double d
= r
* (1.0 + t
* t
);
7903 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7906 else if (SCM_FRACTIONP (x
))
7907 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7908 SCM_FRACTION_NUMERATOR (x
));
7910 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7913 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7915 scm_t_inum xx
= SCM_I_INUM (x
);
7916 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7918 scm_t_inum yy
= SCM_I_INUM (y
);
7921 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7922 scm_num_overflow (s_divide
);
7924 return scm_from_double ((double) xx
/ (double) yy
);
7927 else if (xx
% yy
!= 0)
7930 return scm_from_double ((double) xx
/ (double) yy
);
7931 else return scm_i_make_ratio (x
, y
);
7935 scm_t_inum z
= xx
/ yy
;
7936 if (SCM_FIXABLE (z
))
7937 return SCM_I_MAKINUM (z
);
7939 return scm_i_inum2big (z
);
7942 else if (SCM_BIGP (y
))
7945 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7946 else return scm_i_make_ratio (x
, y
);
7948 else if (SCM_REALP (y
))
7950 double yy
= SCM_REAL_VALUE (y
);
7951 #ifndef ALLOW_DIVIDE_BY_ZERO
7953 scm_num_overflow (s_divide
);
7956 return scm_from_double ((double) xx
/ yy
);
7958 else if (SCM_COMPLEXP (y
))
7961 complex_div
: /* y _must_ be a complex number */
7963 double r
= SCM_COMPLEX_REAL (y
);
7964 double i
= SCM_COMPLEX_IMAG (y
);
7965 if (fabs(r
) <= fabs(i
))
7968 double d
= i
* (1.0 + t
* t
);
7969 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7974 double d
= r
* (1.0 + t
* t
);
7975 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7979 else if (SCM_FRACTIONP (y
))
7980 /* a / b/c = ac / b */
7981 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7982 SCM_FRACTION_NUMERATOR (y
));
7984 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7986 else if (SCM_BIGP (x
))
7988 if (SCM_I_INUMP (y
))
7990 scm_t_inum yy
= SCM_I_INUM (y
);
7993 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7994 scm_num_overflow (s_divide
);
7996 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7997 scm_remember_upto_here_1 (x
);
7998 return (sgn
== 0) ? scm_nan () : scm_inf ();
8005 /* FIXME: HMM, what are the relative performance issues here?
8006 We need to test. Is it faster on average to test
8007 divisible_p, then perform whichever operation, or is it
8008 faster to perform the integer div opportunistically and
8009 switch to real if there's a remainder? For now we take the
8010 middle ground: test, then if divisible, use the faster div
8013 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8014 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8018 SCM result
= scm_i_mkbig ();
8019 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8020 scm_remember_upto_here_1 (x
);
8022 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8023 return scm_i_normbig (result
);
8028 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
8029 else return scm_i_make_ratio (x
, y
);
8033 else if (SCM_BIGP (y
))
8038 /* It's easily possible for the ratio x/y to fit a double
8039 but one or both x and y be too big to fit a double,
8040 hence the use of mpq_get_d rather than converting and
8043 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8044 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8045 return scm_from_double (mpq_get_d (q
));
8049 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8053 SCM result
= scm_i_mkbig ();
8054 mpz_divexact (SCM_I_BIG_MPZ (result
),
8057 scm_remember_upto_here_2 (x
, y
);
8058 return scm_i_normbig (result
);
8061 return scm_i_make_ratio (x
, y
);
8064 else if (SCM_REALP (y
))
8066 double yy
= SCM_REAL_VALUE (y
);
8067 #ifndef ALLOW_DIVIDE_BY_ZERO
8069 scm_num_overflow (s_divide
);
8072 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8074 else if (SCM_COMPLEXP (y
))
8076 a
= scm_i_big2dbl (x
);
8079 else if (SCM_FRACTIONP (y
))
8080 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8081 SCM_FRACTION_NUMERATOR (y
));
8083 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8085 else if (SCM_REALP (x
))
8087 double rx
= SCM_REAL_VALUE (x
);
8088 if (SCM_I_INUMP (y
))
8090 scm_t_inum yy
= SCM_I_INUM (y
);
8091 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8093 scm_num_overflow (s_divide
);
8096 return scm_from_double (rx
/ (double) yy
);
8098 else if (SCM_BIGP (y
))
8100 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8101 scm_remember_upto_here_1 (y
);
8102 return scm_from_double (rx
/ dby
);
8104 else if (SCM_REALP (y
))
8106 double yy
= SCM_REAL_VALUE (y
);
8107 #ifndef ALLOW_DIVIDE_BY_ZERO
8109 scm_num_overflow (s_divide
);
8112 return scm_from_double (rx
/ yy
);
8114 else if (SCM_COMPLEXP (y
))
8119 else if (SCM_FRACTIONP (y
))
8120 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8122 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8124 else if (SCM_COMPLEXP (x
))
8126 double rx
= SCM_COMPLEX_REAL (x
);
8127 double ix
= SCM_COMPLEX_IMAG (x
);
8128 if (SCM_I_INUMP (y
))
8130 scm_t_inum yy
= SCM_I_INUM (y
);
8131 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8133 scm_num_overflow (s_divide
);
8138 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8141 else if (SCM_BIGP (y
))
8143 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8144 scm_remember_upto_here_1 (y
);
8145 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8147 else if (SCM_REALP (y
))
8149 double yy
= SCM_REAL_VALUE (y
);
8150 #ifndef ALLOW_DIVIDE_BY_ZERO
8152 scm_num_overflow (s_divide
);
8155 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8157 else if (SCM_COMPLEXP (y
))
8159 double ry
= SCM_COMPLEX_REAL (y
);
8160 double iy
= SCM_COMPLEX_IMAG (y
);
8161 if (fabs(ry
) <= fabs(iy
))
8164 double d
= iy
* (1.0 + t
* t
);
8165 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8170 double d
= ry
* (1.0 + t
* t
);
8171 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8174 else if (SCM_FRACTIONP (y
))
8176 double yy
= scm_i_fraction2double (y
);
8177 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8180 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8182 else if (SCM_FRACTIONP (x
))
8184 if (SCM_I_INUMP (y
))
8186 scm_t_inum yy
= SCM_I_INUM (y
);
8187 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8189 scm_num_overflow (s_divide
);
8192 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8193 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8195 else if (SCM_BIGP (y
))
8197 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8198 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8200 else if (SCM_REALP (y
))
8202 double yy
= SCM_REAL_VALUE (y
);
8203 #ifndef ALLOW_DIVIDE_BY_ZERO
8205 scm_num_overflow (s_divide
);
8208 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8210 else if (SCM_COMPLEXP (y
))
8212 a
= scm_i_fraction2double (x
);
8215 else if (SCM_FRACTIONP (y
))
8216 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8217 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8219 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8222 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8226 scm_divide (SCM x
, SCM y
)
8228 return do_divide (x
, y
, 0);
8231 static SCM
scm_divide2real (SCM x
, SCM y
)
8233 return do_divide (x
, y
, 1);
8239 scm_c_truncate (double x
)
8244 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8245 half-way case (ie. when x is an integer plus 0.5) going upwards.
8246 Then half-way cases are identified and adjusted down if the
8247 round-upwards didn't give the desired even integer.
8249 "plus_half == result" identifies a half-way case. If plus_half, which is
8250 x + 0.5, is an integer then x must be an integer plus 0.5.
8252 An odd "result" value is identified with result/2 != floor(result/2).
8253 This is done with plus_half, since that value is ready for use sooner in
8254 a pipelined cpu, and we're already requiring plus_half == result.
8256 Note however that we need to be careful when x is big and already an
8257 integer. In that case "x+0.5" may round to an adjacent integer, causing
8258 us to return such a value, incorrectly. For instance if the hardware is
8259 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8260 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8261 returned. Or if the hardware is in round-upwards mode, then other bigger
8262 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8263 representable value, 2^128+2^76 (or whatever), again incorrect.
8265 These bad roundings of x+0.5 are avoided by testing at the start whether
8266 x is already an integer. If it is then clearly that's the desired result
8267 already. And if it's not then the exponent must be small enough to allow
8268 an 0.5 to be represented, and hence added without a bad rounding. */
8271 scm_c_round (double x
)
8273 double plus_half
, result
;
8278 plus_half
= x
+ 0.5;
8279 result
= floor (plus_half
);
8280 /* Adjust so that the rounding is towards even. */
8281 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8286 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8288 "Round the number @var{x} towards zero.")
8289 #define FUNC_NAME s_scm_truncate_number
8291 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8293 else if (SCM_REALP (x
))
8294 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8295 else if (SCM_FRACTIONP (x
))
8296 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8297 SCM_FRACTION_DENOMINATOR (x
));
8299 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8300 s_scm_truncate_number
);
8304 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8306 "Round the number @var{x} towards the nearest integer. "
8307 "When it is exactly halfway between two integers, "
8308 "round towards the even one.")
8309 #define FUNC_NAME s_scm_round_number
8311 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8313 else if (SCM_REALP (x
))
8314 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8315 else if (SCM_FRACTIONP (x
))
8316 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8317 SCM_FRACTION_DENOMINATOR (x
));
8319 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8320 s_scm_round_number
);
8324 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8326 "Round the number @var{x} towards minus infinity.")
8327 #define FUNC_NAME s_scm_floor
8329 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8331 else if (SCM_REALP (x
))
8332 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8333 else if (SCM_FRACTIONP (x
))
8334 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8335 SCM_FRACTION_DENOMINATOR (x
));
8337 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8341 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8343 "Round the number @var{x} towards infinity.")
8344 #define FUNC_NAME s_scm_ceiling
8346 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8348 else if (SCM_REALP (x
))
8349 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8350 else if (SCM_FRACTIONP (x
))
8351 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8352 SCM_FRACTION_DENOMINATOR (x
));
8354 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8358 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8360 "Return @var{x} raised to the power of @var{y}.")
8361 #define FUNC_NAME s_scm_expt
8363 if (scm_is_integer (y
))
8365 if (scm_is_true (scm_exact_p (y
)))
8366 return scm_integer_expt (x
, y
);
8369 /* Here we handle the case where the exponent is an inexact
8370 integer. We make the exponent exact in order to use
8371 scm_integer_expt, and thus avoid the spurious imaginary
8372 parts that may result from round-off errors in the general
8373 e^(y log x) method below (for example when squaring a large
8374 negative number). In this case, we must return an inexact
8375 result for correctness. We also make the base inexact so
8376 that scm_integer_expt will use fast inexact arithmetic
8377 internally. Note that making the base inexact is not
8378 sufficient to guarantee an inexact result, because
8379 scm_integer_expt will return an exact 1 when the exponent
8380 is 0, even if the base is inexact. */
8381 return scm_exact_to_inexact
8382 (scm_integer_expt (scm_exact_to_inexact (x
),
8383 scm_inexact_to_exact (y
)));
8386 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8388 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8390 else if (scm_is_complex (x
) && scm_is_complex (y
))
8391 return scm_exp (scm_product (scm_log (x
), y
));
8392 else if (scm_is_complex (x
))
8393 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8395 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8399 /* sin/cos/tan/asin/acos/atan
8400 sinh/cosh/tanh/asinh/acosh/atanh
8401 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8402 Written by Jerry D. Hedden, (C) FSF.
8403 See the file `COPYING' for terms applying to this program. */
8405 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8407 "Compute the sine of @var{z}.")
8408 #define FUNC_NAME s_scm_sin
8410 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8411 return z
; /* sin(exact0) = exact0 */
8412 else if (scm_is_real (z
))
8413 return scm_from_double (sin (scm_to_double (z
)));
8414 else if (SCM_COMPLEXP (z
))
8416 x
= SCM_COMPLEX_REAL (z
);
8417 y
= SCM_COMPLEX_IMAG (z
);
8418 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8419 cos (x
) * sinh (y
));
8422 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8426 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8428 "Compute the cosine of @var{z}.")
8429 #define FUNC_NAME s_scm_cos
8431 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8432 return SCM_INUM1
; /* cos(exact0) = exact1 */
8433 else if (scm_is_real (z
))
8434 return scm_from_double (cos (scm_to_double (z
)));
8435 else if (SCM_COMPLEXP (z
))
8437 x
= SCM_COMPLEX_REAL (z
);
8438 y
= SCM_COMPLEX_IMAG (z
);
8439 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8440 -sin (x
) * sinh (y
));
8443 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8447 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8449 "Compute the tangent of @var{z}.")
8450 #define FUNC_NAME s_scm_tan
8452 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8453 return z
; /* tan(exact0) = exact0 */
8454 else if (scm_is_real (z
))
8455 return scm_from_double (tan (scm_to_double (z
)));
8456 else if (SCM_COMPLEXP (z
))
8458 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8459 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8460 w
= cos (x
) + cosh (y
);
8461 #ifndef ALLOW_DIVIDE_BY_ZERO
8463 scm_num_overflow (s_scm_tan
);
8465 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8468 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8472 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8474 "Compute the hyperbolic sine of @var{z}.")
8475 #define FUNC_NAME s_scm_sinh
8477 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8478 return z
; /* sinh(exact0) = exact0 */
8479 else if (scm_is_real (z
))
8480 return scm_from_double (sinh (scm_to_double (z
)));
8481 else if (SCM_COMPLEXP (z
))
8483 x
= SCM_COMPLEX_REAL (z
);
8484 y
= SCM_COMPLEX_IMAG (z
);
8485 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8486 cosh (x
) * sin (y
));
8489 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8493 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8495 "Compute the hyperbolic cosine of @var{z}.")
8496 #define FUNC_NAME s_scm_cosh
8498 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8499 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8500 else if (scm_is_real (z
))
8501 return scm_from_double (cosh (scm_to_double (z
)));
8502 else if (SCM_COMPLEXP (z
))
8504 x
= SCM_COMPLEX_REAL (z
);
8505 y
= SCM_COMPLEX_IMAG (z
);
8506 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8507 sinh (x
) * sin (y
));
8510 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8514 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8516 "Compute the hyperbolic tangent of @var{z}.")
8517 #define FUNC_NAME s_scm_tanh
8519 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8520 return z
; /* tanh(exact0) = exact0 */
8521 else if (scm_is_real (z
))
8522 return scm_from_double (tanh (scm_to_double (z
)));
8523 else if (SCM_COMPLEXP (z
))
8525 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8526 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8527 w
= cosh (x
) + cos (y
);
8528 #ifndef ALLOW_DIVIDE_BY_ZERO
8530 scm_num_overflow (s_scm_tanh
);
8532 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8535 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8539 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8541 "Compute the arc sine of @var{z}.")
8542 #define FUNC_NAME s_scm_asin
8544 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8545 return z
; /* asin(exact0) = exact0 */
8546 else if (scm_is_real (z
))
8548 double w
= scm_to_double (z
);
8549 if (w
>= -1.0 && w
<= 1.0)
8550 return scm_from_double (asin (w
));
8552 return scm_product (scm_c_make_rectangular (0, -1),
8553 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8555 else if (SCM_COMPLEXP (z
))
8557 x
= SCM_COMPLEX_REAL (z
);
8558 y
= SCM_COMPLEX_IMAG (z
);
8559 return scm_product (scm_c_make_rectangular (0, -1),
8560 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8563 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8567 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8569 "Compute the arc cosine of @var{z}.")
8570 #define FUNC_NAME s_scm_acos
8572 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8573 return SCM_INUM0
; /* acos(exact1) = exact0 */
8574 else if (scm_is_real (z
))
8576 double w
= scm_to_double (z
);
8577 if (w
>= -1.0 && w
<= 1.0)
8578 return scm_from_double (acos (w
));
8580 return scm_sum (scm_from_double (acos (0.0)),
8581 scm_product (scm_c_make_rectangular (0, 1),
8582 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8584 else if (SCM_COMPLEXP (z
))
8586 x
= SCM_COMPLEX_REAL (z
);
8587 y
= SCM_COMPLEX_IMAG (z
);
8588 return scm_sum (scm_from_double (acos (0.0)),
8589 scm_product (scm_c_make_rectangular (0, 1),
8590 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8593 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8597 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8599 "With one argument, compute the arc tangent of @var{z}.\n"
8600 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8601 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8602 #define FUNC_NAME s_scm_atan
8606 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8607 return z
; /* atan(exact0) = exact0 */
8608 else if (scm_is_real (z
))
8609 return scm_from_double (atan (scm_to_double (z
)));
8610 else if (SCM_COMPLEXP (z
))
8613 v
= SCM_COMPLEX_REAL (z
);
8614 w
= SCM_COMPLEX_IMAG (z
);
8615 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8616 scm_c_make_rectangular (v
, w
+ 1.0))),
8617 scm_c_make_rectangular (0, 2));
8620 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8622 else if (scm_is_real (z
))
8624 if (scm_is_real (y
))
8625 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8627 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8630 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8634 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8636 "Compute the inverse hyperbolic sine of @var{z}.")
8637 #define FUNC_NAME s_scm_sys_asinh
8639 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8640 return z
; /* asinh(exact0) = exact0 */
8641 else if (scm_is_real (z
))
8642 return scm_from_double (asinh (scm_to_double (z
)));
8643 else if (scm_is_number (z
))
8644 return scm_log (scm_sum (z
,
8645 scm_sqrt (scm_sum (scm_product (z
, z
),
8648 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8652 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8654 "Compute the inverse hyperbolic cosine of @var{z}.")
8655 #define FUNC_NAME s_scm_sys_acosh
8657 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8658 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8659 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8660 return scm_from_double (acosh (scm_to_double (z
)));
8661 else if (scm_is_number (z
))
8662 return scm_log (scm_sum (z
,
8663 scm_sqrt (scm_difference (scm_product (z
, z
),
8666 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8670 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8672 "Compute the inverse hyperbolic tangent of @var{z}.")
8673 #define FUNC_NAME s_scm_sys_atanh
8675 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8676 return z
; /* atanh(exact0) = exact0 */
8677 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8678 return scm_from_double (atanh (scm_to_double (z
)));
8679 else if (scm_is_number (z
))
8680 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8681 scm_difference (SCM_INUM1
, z
))),
8684 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8689 scm_c_make_rectangular (double re
, double im
)
8693 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8695 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8696 SCM_COMPLEX_REAL (z
) = re
;
8697 SCM_COMPLEX_IMAG (z
) = im
;
8701 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8702 (SCM real_part
, SCM imaginary_part
),
8703 "Return a complex number constructed of the given @var{real_part} "
8704 "and @var{imaginary_part} parts.")
8705 #define FUNC_NAME s_scm_make_rectangular
8707 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8708 SCM_ARG1
, FUNC_NAME
, "real");
8709 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8710 SCM_ARG2
, FUNC_NAME
, "real");
8712 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8713 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8716 return scm_c_make_rectangular (scm_to_double (real_part
),
8717 scm_to_double (imaginary_part
));
8722 scm_c_make_polar (double mag
, double ang
)
8726 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8727 use it on Glibc-based systems that have it (it's a GNU extension). See
8728 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8730 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8731 sincos (ang
, &s
, &c
);
8737 /* If s and c are NaNs, this indicates that the angle is a NaN,
8738 infinite, or perhaps simply too large to determine its value
8739 mod 2*pi. However, we know something that the floating-point
8740 implementation doesn't know: We know that s and c are finite.
8741 Therefore, if the magnitude is zero, return a complex zero.
8743 The reason we check for the NaNs instead of using this case
8744 whenever mag == 0.0 is because when the angle is known, we'd
8745 like to return the correct kind of non-real complex zero:
8746 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8747 on which quadrant the angle is in.
8749 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8750 return scm_c_make_rectangular (0.0, 0.0);
8752 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8755 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8757 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8758 #define FUNC_NAME s_scm_make_polar
8760 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8761 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8763 /* If mag is exact0, return exact0 */
8764 if (scm_is_eq (mag
, SCM_INUM0
))
8766 /* Return a real if ang is exact0 */
8767 else if (scm_is_eq (ang
, SCM_INUM0
))
8770 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8775 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8777 "Return the real part of the number @var{z}.")
8778 #define FUNC_NAME s_scm_real_part
8780 if (SCM_COMPLEXP (z
))
8781 return scm_from_double (SCM_COMPLEX_REAL (z
));
8782 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8785 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8790 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8792 "Return the imaginary part of the number @var{z}.")
8793 #define FUNC_NAME s_scm_imag_part
8795 if (SCM_COMPLEXP (z
))
8796 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8797 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8800 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8804 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8806 "Return the numerator of the number @var{z}.")
8807 #define FUNC_NAME s_scm_numerator
8809 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8811 else if (SCM_FRACTIONP (z
))
8812 return SCM_FRACTION_NUMERATOR (z
);
8813 else if (SCM_REALP (z
))
8814 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8816 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8821 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8823 "Return the denominator of the number @var{z}.")
8824 #define FUNC_NAME s_scm_denominator
8826 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8828 else if (SCM_FRACTIONP (z
))
8829 return SCM_FRACTION_DENOMINATOR (z
);
8830 else if (SCM_REALP (z
))
8831 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8833 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
8839 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8841 "Return the magnitude of the number @var{z}. This is the same as\n"
8842 "@code{abs} for real arguments, but also allows complex numbers.")
8843 #define FUNC_NAME s_scm_magnitude
8845 if (SCM_I_INUMP (z
))
8847 scm_t_inum zz
= SCM_I_INUM (z
);
8850 else if (SCM_POSFIXABLE (-zz
))
8851 return SCM_I_MAKINUM (-zz
);
8853 return scm_i_inum2big (-zz
);
8855 else if (SCM_BIGP (z
))
8857 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8858 scm_remember_upto_here_1 (z
);
8860 return scm_i_clonebig (z
, 0);
8864 else if (SCM_REALP (z
))
8865 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8866 else if (SCM_COMPLEXP (z
))
8867 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8868 else if (SCM_FRACTIONP (z
))
8870 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8872 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8873 SCM_FRACTION_DENOMINATOR (z
));
8876 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
8882 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8884 "Return the angle of the complex number @var{z}.")
8885 #define FUNC_NAME s_scm_angle
8887 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8888 flo0 to save allocating a new flonum with scm_from_double each time.
8889 But if atan2 follows the floating point rounding mode, then the value
8890 is not a constant. Maybe it'd be close enough though. */
8891 if (SCM_I_INUMP (z
))
8893 if (SCM_I_INUM (z
) >= 0)
8896 return scm_from_double (atan2 (0.0, -1.0));
8898 else if (SCM_BIGP (z
))
8900 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8901 scm_remember_upto_here_1 (z
);
8903 return scm_from_double (atan2 (0.0, -1.0));
8907 else if (SCM_REALP (z
))
8909 double x
= SCM_REAL_VALUE (z
);
8910 if (x
> 0.0 || double_is_non_negative_zero (x
))
8913 return scm_from_double (atan2 (0.0, -1.0));
8915 else if (SCM_COMPLEXP (z
))
8916 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8917 else if (SCM_FRACTIONP (z
))
8919 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8921 else return scm_from_double (atan2 (0.0, -1.0));
8924 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8929 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8931 "Convert the number @var{z} to its inexact representation.\n")
8932 #define FUNC_NAME s_scm_exact_to_inexact
8934 if (SCM_I_INUMP (z
))
8935 return scm_from_double ((double) SCM_I_INUM (z
));
8936 else if (SCM_BIGP (z
))
8937 return scm_from_double (scm_i_big2dbl (z
));
8938 else if (SCM_FRACTIONP (z
))
8939 return scm_from_double (scm_i_fraction2double (z
));
8940 else if (SCM_INEXACTP (z
))
8943 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
8944 s_scm_exact_to_inexact
);
8949 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8951 "Return an exact number that is numerically closest to @var{z}.")
8952 #define FUNC_NAME s_scm_inexact_to_exact
8954 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8961 val
= SCM_REAL_VALUE (z
);
8962 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8963 val
= SCM_COMPLEX_REAL (z
);
8965 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
8966 s_scm_inexact_to_exact
);
8968 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8969 SCM_OUT_OF_RANGE (1, z
);
8976 mpq_set_d (frac
, val
);
8977 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8978 scm_i_mpz2num (mpq_denref (frac
)));
8980 /* When scm_i_make_ratio throws, we leak the memory allocated
8990 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8992 "Returns the @emph{simplest} rational number differing\n"
8993 "from @var{x} by no more than @var{eps}.\n"
8995 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8996 "exact result when both its arguments are exact. Thus, you might need\n"
8997 "to use @code{inexact->exact} on the arguments.\n"
9000 "(rationalize (inexact->exact 1.2) 1/100)\n"
9003 #define FUNC_NAME s_scm_rationalize
9005 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9006 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9007 eps
= scm_abs (eps
);
9008 if (scm_is_false (scm_positive_p (eps
)))
9010 /* eps is either zero or a NaN */
9011 if (scm_is_true (scm_nan_p (eps
)))
9013 else if (SCM_INEXACTP (eps
))
9014 return scm_exact_to_inexact (x
);
9018 else if (scm_is_false (scm_finite_p (eps
)))
9020 if (scm_is_true (scm_finite_p (x
)))
9025 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9027 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9028 scm_ceiling (scm_difference (x
, eps
)))))
9030 /* There's an integer within range; we want the one closest to zero */
9031 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9033 /* zero is within range */
9034 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9039 else if (scm_is_true (scm_positive_p (x
)))
9040 return scm_ceiling (scm_difference (x
, eps
));
9042 return scm_floor (scm_sum (x
, eps
));
9046 /* Use continued fractions to find closest ratio. All
9047 arithmetic is done with exact numbers.
9050 SCM ex
= scm_inexact_to_exact (x
);
9051 SCM int_part
= scm_floor (ex
);
9053 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9054 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9058 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9059 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9061 /* We stop after a million iterations just to be absolutely sure
9062 that we don't go into an infinite loop. The process normally
9063 converges after less than a dozen iterations.
9066 while (++i
< 1000000)
9068 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9069 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9070 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9072 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9073 eps
))) /* abs(x-a/b) <= eps */
9075 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9076 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9077 return scm_exact_to_inexact (res
);
9081 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9083 tt
= scm_floor (rx
); /* tt = floor (rx) */
9089 scm_num_overflow (s_scm_rationalize
);
9094 /* conversion functions */
9097 scm_is_integer (SCM val
)
9099 return scm_is_true (scm_integer_p (val
));
9103 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9105 if (SCM_I_INUMP (val
))
9107 scm_t_signed_bits n
= SCM_I_INUM (val
);
9108 return n
>= min
&& n
<= max
;
9110 else if (SCM_BIGP (val
))
9112 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9114 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9116 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9118 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9119 return n
>= min
&& n
<= max
;
9129 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9130 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9133 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9134 SCM_I_BIG_MPZ (val
));
9136 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9148 return n
>= min
&& n
<= max
;
9156 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9158 if (SCM_I_INUMP (val
))
9160 scm_t_signed_bits n
= SCM_I_INUM (val
);
9161 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9163 else if (SCM_BIGP (val
))
9165 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9167 else if (max
<= ULONG_MAX
)
9169 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9171 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9172 return n
>= min
&& n
<= max
;
9182 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9185 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9186 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9189 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9190 SCM_I_BIG_MPZ (val
));
9192 return n
>= min
&& n
<= max
;
9200 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9202 scm_error (scm_out_of_range_key
,
9204 "Value out of range ~S to ~S: ~S",
9205 scm_list_3 (min
, max
, bad_val
),
9206 scm_list_1 (bad_val
));
9209 #define TYPE scm_t_intmax
9210 #define TYPE_MIN min
9211 #define TYPE_MAX max
9212 #define SIZEOF_TYPE 0
9213 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9214 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9215 #include "libguile/conv-integer.i.c"
9217 #define TYPE scm_t_uintmax
9218 #define TYPE_MIN min
9219 #define TYPE_MAX max
9220 #define SIZEOF_TYPE 0
9221 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9222 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9223 #include "libguile/conv-uinteger.i.c"
9225 #define TYPE scm_t_int8
9226 #define TYPE_MIN SCM_T_INT8_MIN
9227 #define TYPE_MAX SCM_T_INT8_MAX
9228 #define SIZEOF_TYPE 1
9229 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9230 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9231 #include "libguile/conv-integer.i.c"
9233 #define TYPE scm_t_uint8
9235 #define TYPE_MAX SCM_T_UINT8_MAX
9236 #define SIZEOF_TYPE 1
9237 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9238 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9239 #include "libguile/conv-uinteger.i.c"
9241 #define TYPE scm_t_int16
9242 #define TYPE_MIN SCM_T_INT16_MIN
9243 #define TYPE_MAX SCM_T_INT16_MAX
9244 #define SIZEOF_TYPE 2
9245 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9246 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9247 #include "libguile/conv-integer.i.c"
9249 #define TYPE scm_t_uint16
9251 #define TYPE_MAX SCM_T_UINT16_MAX
9252 #define SIZEOF_TYPE 2
9253 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9254 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9255 #include "libguile/conv-uinteger.i.c"
9257 #define TYPE scm_t_int32
9258 #define TYPE_MIN SCM_T_INT32_MIN
9259 #define TYPE_MAX SCM_T_INT32_MAX
9260 #define SIZEOF_TYPE 4
9261 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9262 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9263 #include "libguile/conv-integer.i.c"
9265 #define TYPE scm_t_uint32
9267 #define TYPE_MAX SCM_T_UINT32_MAX
9268 #define SIZEOF_TYPE 4
9269 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9270 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9271 #include "libguile/conv-uinteger.i.c"
9273 #define TYPE scm_t_wchar
9274 #define TYPE_MIN (scm_t_int32)-1
9275 #define TYPE_MAX (scm_t_int32)0x10ffff
9276 #define SIZEOF_TYPE 4
9277 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9278 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9279 #include "libguile/conv-integer.i.c"
9281 #define TYPE scm_t_int64
9282 #define TYPE_MIN SCM_T_INT64_MIN
9283 #define TYPE_MAX SCM_T_INT64_MAX
9284 #define SIZEOF_TYPE 8
9285 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9286 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9287 #include "libguile/conv-integer.i.c"
9289 #define TYPE scm_t_uint64
9291 #define TYPE_MAX SCM_T_UINT64_MAX
9292 #define SIZEOF_TYPE 8
9293 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9294 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9295 #include "libguile/conv-uinteger.i.c"
9298 scm_to_mpz (SCM val
, mpz_t rop
)
9300 if (SCM_I_INUMP (val
))
9301 mpz_set_si (rop
, SCM_I_INUM (val
));
9302 else if (SCM_BIGP (val
))
9303 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9305 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9309 scm_from_mpz (mpz_t val
)
9311 return scm_i_mpz2num (val
);
9315 scm_is_real (SCM val
)
9317 return scm_is_true (scm_real_p (val
));
9321 scm_is_rational (SCM val
)
9323 return scm_is_true (scm_rational_p (val
));
9327 scm_to_double (SCM val
)
9329 if (SCM_I_INUMP (val
))
9330 return SCM_I_INUM (val
);
9331 else if (SCM_BIGP (val
))
9332 return scm_i_big2dbl (val
);
9333 else if (SCM_FRACTIONP (val
))
9334 return scm_i_fraction2double (val
);
9335 else if (SCM_REALP (val
))
9336 return SCM_REAL_VALUE (val
);
9338 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9342 scm_from_double (double val
)
9346 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9348 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9349 SCM_REAL_VALUE (z
) = val
;
9355 scm_is_complex (SCM val
)
9357 return scm_is_true (scm_complex_p (val
));
9361 scm_c_real_part (SCM z
)
9363 if (SCM_COMPLEXP (z
))
9364 return SCM_COMPLEX_REAL (z
);
9367 /* Use the scm_real_part to get proper error checking and
9370 return scm_to_double (scm_real_part (z
));
9375 scm_c_imag_part (SCM z
)
9377 if (SCM_COMPLEXP (z
))
9378 return SCM_COMPLEX_IMAG (z
);
9381 /* Use the scm_imag_part to get proper error checking and
9382 dispatching. The result will almost always be 0.0, but not
9385 return scm_to_double (scm_imag_part (z
));
9390 scm_c_magnitude (SCM z
)
9392 return scm_to_double (scm_magnitude (z
));
9398 return scm_to_double (scm_angle (z
));
9402 scm_is_number (SCM z
)
9404 return scm_is_true (scm_number_p (z
));
9408 /* Returns log(x * 2^shift) */
9410 log_of_shifted_double (double x
, long shift
)
9412 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9414 if (x
> 0.0 || double_is_non_negative_zero (x
))
9415 return scm_from_double (ans
);
9417 return scm_c_make_rectangular (ans
, M_PI
);
9420 /* Returns log(n), for exact integer n of integer-length size */
9422 log_of_exact_integer_with_size (SCM n
, long size
)
9424 long shift
= size
- 2 * scm_dblprec
[0];
9427 return log_of_shifted_double
9428 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9431 return log_of_shifted_double (scm_to_double (n
), 0);
9434 /* Returns log(n), for exact integer n */
9436 log_of_exact_integer (SCM n
)
9438 return log_of_exact_integer_with_size
9439 (n
, scm_to_long (scm_integer_length (n
)));
9442 /* Returns log(n/d), for exact non-zero integers n and d */
9444 log_of_fraction (SCM n
, SCM d
)
9446 long n_size
= scm_to_long (scm_integer_length (n
));
9447 long d_size
= scm_to_long (scm_integer_length (d
));
9449 if (abs (n_size
- d_size
) > 1)
9450 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9451 log_of_exact_integer_with_size (d
, d_size
)));
9452 else if (scm_is_false (scm_negative_p (n
)))
9453 return scm_from_double
9454 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9456 return scm_c_make_rectangular
9457 (log1p (scm_to_double (scm_divide2real
9458 (scm_difference (scm_abs (n
), d
),
9464 /* In the following functions we dispatch to the real-arg funcs like log()
9465 when we know the arg is real, instead of just handing everything to
9466 clog() for instance. This is in case clog() doesn't optimize for a
9467 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9468 well use it to go straight to the applicable C func. */
9470 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9472 "Return the natural logarithm of @var{z}.")
9473 #define FUNC_NAME s_scm_log
9475 if (SCM_COMPLEXP (z
))
9477 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9478 && defined (SCM_COMPLEX_VALUE)
9479 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9481 double re
= SCM_COMPLEX_REAL (z
);
9482 double im
= SCM_COMPLEX_IMAG (z
);
9483 return scm_c_make_rectangular (log (hypot (re
, im
)),
9487 else if (SCM_REALP (z
))
9488 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9489 else if (SCM_I_INUMP (z
))
9491 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9492 if (scm_is_eq (z
, SCM_INUM0
))
9493 scm_num_overflow (s_scm_log
);
9495 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9497 else if (SCM_BIGP (z
))
9498 return log_of_exact_integer (z
);
9499 else if (SCM_FRACTIONP (z
))
9500 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9501 SCM_FRACTION_DENOMINATOR (z
));
9503 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
9508 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9510 "Return the base 10 logarithm of @var{z}.")
9511 #define FUNC_NAME s_scm_log10
9513 if (SCM_COMPLEXP (z
))
9515 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9516 clog() and a multiply by M_LOG10E, rather than the fallback
9517 log10+hypot+atan2.) */
9518 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9519 && defined SCM_COMPLEX_VALUE
9520 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9522 double re
= SCM_COMPLEX_REAL (z
);
9523 double im
= SCM_COMPLEX_IMAG (z
);
9524 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9525 M_LOG10E
* atan2 (im
, re
));
9528 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9530 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9531 if (scm_is_eq (z
, SCM_INUM0
))
9532 scm_num_overflow (s_scm_log10
);
9535 double re
= scm_to_double (z
);
9536 double l
= log10 (fabs (re
));
9537 if (re
> 0.0 || double_is_non_negative_zero (re
))
9538 return scm_from_double (l
);
9540 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9543 else if (SCM_BIGP (z
))
9544 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9545 else if (SCM_FRACTIONP (z
))
9546 return scm_product (flo_log10e
,
9547 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9548 SCM_FRACTION_DENOMINATOR (z
)));
9550 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9555 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9557 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9558 "base of natural logarithms (2.71828@dots{}).")
9559 #define FUNC_NAME s_scm_exp
9561 if (SCM_COMPLEXP (z
))
9563 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9564 && defined (SCM_COMPLEX_VALUE)
9565 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9567 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9568 SCM_COMPLEX_IMAG (z
));
9571 else if (SCM_NUMBERP (z
))
9573 /* When z is a negative bignum the conversion to double overflows,
9574 giving -infinity, but that's ok, the exp is still 0.0. */
9575 return scm_from_double (exp (scm_to_double (z
)));
9578 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9583 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9585 "Return two exact non-negative integers @var{s} and @var{r}\n"
9586 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9587 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9588 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9591 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9593 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9597 scm_exact_integer_sqrt (k
, &s
, &r
);
9598 return scm_values (scm_list_2 (s
, r
));
9603 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9605 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9607 scm_t_inum kk
= SCM_I_INUM (k
);
9611 if (SCM_LIKELY (kk
> 0))
9616 uu
= (ss
+ kk
/ss
) / 2;
9618 *sp
= SCM_I_MAKINUM (ss
);
9619 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9621 else if (SCM_LIKELY (kk
== 0))
9622 *sp
= *rp
= SCM_INUM0
;
9624 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9625 "exact non-negative integer");
9627 else if (SCM_LIKELY (SCM_BIGP (k
)))
9631 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9632 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9633 "exact non-negative integer");
9636 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9637 scm_remember_upto_here_1 (k
);
9638 *sp
= scm_i_normbig (s
);
9639 *rp
= scm_i_normbig (r
);
9642 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9643 "exact non-negative integer");
9647 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9649 "Return the square root of @var{z}. Of the two possible roots\n"
9650 "(positive and negative), the one with positive real part\n"
9651 "is returned, or if that's zero then a positive imaginary part.\n"
9655 "(sqrt 9.0) @result{} 3.0\n"
9656 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9657 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9658 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9660 #define FUNC_NAME s_scm_sqrt
9662 if (SCM_COMPLEXP (z
))
9664 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9665 && defined SCM_COMPLEX_VALUE
9666 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9668 double re
= SCM_COMPLEX_REAL (z
);
9669 double im
= SCM_COMPLEX_IMAG (z
);
9670 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9671 0.5 * atan2 (im
, re
));
9674 else if (SCM_NUMBERP (z
))
9676 double xx
= scm_to_double (z
);
9678 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9680 return scm_from_double (sqrt (xx
));
9683 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9694 if (scm_install_gmp_memory_functions
)
9695 mp_set_memory_functions (custom_gmp_malloc
,
9699 mpz_init_set_si (z_negative_one
, -1);
9701 /* It may be possible to tune the performance of some algorithms by using
9702 * the following constants to avoid the creation of bignums. Please, before
9703 * using these values, remember the two rules of program optimization:
9704 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9705 scm_c_define ("most-positive-fixnum",
9706 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9707 scm_c_define ("most-negative-fixnum",
9708 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9710 scm_add_feature ("complex");
9711 scm_add_feature ("inexact");
9712 flo0
= scm_from_double (0.0);
9713 flo_log10e
= scm_from_double (M_LOG10E
);
9715 /* determine floating point precision */
9716 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9718 init_dblprec(&scm_dblprec
[i
-2],i
);
9719 init_fx_radix(fx_per_radix
[i
-2],i
);
9722 /* hard code precision for base 10 if the preprocessor tells us to... */
9723 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9726 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9727 #include "libguile/numbers.x"