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 /* FIXME: We assume that FLT_RADIX is 2 */
85 verify (FLT_RADIX
== 2);
87 typedef scm_t_signed_bits scm_t_inum
;
88 #define scm_from_inum(x) (scm_from_signed_integer (x))
90 /* Tests to see if a C double is neither infinite nor a NaN.
91 TODO: if it's available, use C99's isfinite(x) instead */
92 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
94 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
95 of the infinity, but other platforms return a boolean only. */
96 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
97 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
102 Wonder if this might be faster for some of our code? A switch on
103 the numtag would jump directly to the right case, and the
104 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
106 #define SCM_I_NUMTAG_NOTNUM 0
107 #define SCM_I_NUMTAG_INUM 1
108 #define SCM_I_NUMTAG_BIG scm_tc16_big
109 #define SCM_I_NUMTAG_REAL scm_tc16_real
110 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
111 #define SCM_I_NUMTAG(x) \
112 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
113 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
114 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
115 : SCM_I_NUMTAG_NOTNUM)))
117 /* the macro above will not work as is with fractions */
120 /* Default to 1, because as we used to hard-code `free' as the
121 deallocator, we know that overriding these functions with
122 instrumented `malloc' / `free' is OK. */
123 int scm_install_gmp_memory_functions
= 1;
125 static SCM exactly_one_half
;
126 static SCM flo_log10e
;
128 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
130 /* FLOBUFLEN is the maximum number of characters neccessary for the
131 * printed or scm_string representation of an inexact number.
133 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
136 #if !defined (HAVE_ASINH)
137 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
139 #if !defined (HAVE_ACOSH)
140 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
142 #if !defined (HAVE_ATANH)
143 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
146 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
147 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
148 in March 2006), mpz_cmp_d now handles infinities properly. */
150 #define xmpz_cmp_d(z, d) \
151 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
153 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
157 #if defined (GUILE_I)
158 #if defined HAVE_COMPLEX_DOUBLE
160 /* For an SCM object Z which is a complex number (ie. satisfies
161 SCM_COMPLEXP), return its value as a C level "complex double". */
162 #define SCM_COMPLEX_VALUE(z) \
163 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
165 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
167 /* Convert a C "complex double" to an SCM value. */
169 scm_from_complex_double (complex double z
)
171 return scm_c_make_rectangular (creal (z
), cimag (z
));
174 #endif /* HAVE_COMPLEX_DOUBLE */
179 static mpz_t z_negative_one
;
183 /* Clear the `mpz_t' embedded in bignum PTR. */
185 finalize_bignum (void *ptr
, void *data
)
189 bignum
= PTR2SCM (ptr
);
190 mpz_clear (SCM_I_BIG_MPZ (bignum
));
193 /* The next three functions (custom_libgmp_*) are passed to
194 mp_set_memory_functions (in GMP) so that memory used by the digits
195 themselves is known to the garbage collector. This is needed so
196 that GC will be run at appropriate times. Otherwise, a program which
197 creates many large bignums would malloc a huge amount of memory
198 before the GC runs. */
200 custom_gmp_malloc (size_t alloc_size
)
202 return scm_malloc (alloc_size
);
206 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
208 return scm_realloc (old_ptr
, new_size
);
212 custom_gmp_free (void *ptr
, size_t size
)
218 /* Return a new uninitialized bignum. */
224 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
225 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
229 scm_i_set_finalizer (p
, finalize_bignum
, NULL
);
238 /* Return a newly created bignum. */
239 SCM z
= make_bignum ();
240 mpz_init (SCM_I_BIG_MPZ (z
));
245 scm_i_inum2big (scm_t_inum x
)
247 /* Return a newly created bignum initialized to X. */
248 SCM z
= make_bignum ();
249 #if SIZEOF_VOID_P == SIZEOF_LONG
250 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
252 /* Note that in this case, you'll also have to check all mpz_*_ui and
253 mpz_*_si invocations in Guile. */
254 #error creation of mpz not implemented for this inum size
260 scm_i_long2big (long x
)
262 /* Return a newly created bignum initialized to X. */
263 SCM z
= make_bignum ();
264 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
269 scm_i_ulong2big (unsigned long x
)
271 /* Return a newly created bignum initialized to X. */
272 SCM z
= make_bignum ();
273 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
278 scm_i_clonebig (SCM src_big
, int same_sign_p
)
280 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
281 SCM z
= make_bignum ();
282 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
284 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
289 scm_i_bigcmp (SCM x
, SCM y
)
291 /* Return neg if x < y, pos if x > y, and 0 if x == y */
292 /* presume we already know x and y are bignums */
293 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
294 scm_remember_upto_here_2 (x
, y
);
299 scm_i_dbl2big (double d
)
301 /* results are only defined if d is an integer */
302 SCM z
= make_bignum ();
303 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
307 /* Convert a integer in double representation to a SCM number. */
310 scm_i_dbl2num (double u
)
312 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
313 powers of 2, so there's no rounding when making "double" values
314 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
315 get rounded on a 64-bit machine, hence the "+1".
317 The use of floor() to force to an integer value ensures we get a
318 "numerically closest" value without depending on how a
319 double->long cast or how mpz_set_d will round. For reference,
320 double->long probably follows the hardware rounding mode,
321 mpz_set_d truncates towards zero. */
323 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
324 representable as a double? */
326 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
327 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
328 return SCM_I_MAKINUM ((scm_t_inum
) u
);
330 return scm_i_dbl2big (u
);
333 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
334 with R5RS exact->inexact.
336 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
337 (ie. truncate towards zero), then adjust to get the closest double by
338 examining the next lower bit and adding 1 (to the absolute value) if
341 Bignums exactly half way between representable doubles are rounded to the
342 next higher absolute value (ie. away from zero). This seems like an
343 adequate interpretation of R5RS "numerically closest", and it's easier
344 and faster than a full "nearest-even" style.
346 The bit test must be done on the absolute value of the mpz_t, which means
347 we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
348 negatives as twos complement.
350 In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
351 following the hardware rounding mode, but applied to the absolute
352 value of the mpz_t operand. This is not what we want so we put the
353 high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
354 (released in March 2006) mpz_get_d now always truncates towards zero.
356 ENHANCE-ME: The temporary init+clear to force the rounding in GMP
357 before 4.2 is a slowdown. It'd be faster to pick out the relevant
358 high bits with mpz_getlimbn. */
361 scm_i_big2dbl (SCM b
)
366 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
370 /* For GMP earlier than 4.2, force truncation towards zero */
372 /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
373 _not_ the number of bits, so this code will break badly on a
374 system with non-binary doubles. */
377 if (bits
> DBL_MANT_DIG
)
379 size_t shift
= bits
- DBL_MANT_DIG
;
380 mpz_init2 (tmp
, DBL_MANT_DIG
);
381 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
382 result
= ldexp (mpz_get_d (tmp
), shift
);
387 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
391 /* GMP 4.2 or later */
392 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
395 if (bits
> DBL_MANT_DIG
)
397 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
398 /* test bit number "pos" in absolute value */
399 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
400 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
402 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
406 scm_remember_upto_here_1 (b
);
411 scm_i_normbig (SCM b
)
413 /* convert a big back to a fixnum if it'll fit */
414 /* presume b is a bignum */
415 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
417 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
418 if (SCM_FIXABLE (val
))
419 b
= SCM_I_MAKINUM (val
);
424 static SCM_C_INLINE_KEYWORD SCM
425 scm_i_mpz2num (mpz_t b
)
427 /* convert a mpz number to a SCM number. */
428 if (mpz_fits_slong_p (b
))
430 scm_t_inum val
= mpz_get_si (b
);
431 if (SCM_FIXABLE (val
))
432 return SCM_I_MAKINUM (val
);
436 SCM z
= make_bignum ();
437 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
442 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
443 static SCM
scm_divide2real (SCM x
, SCM y
);
446 scm_i_make_ratio (SCM numerator
, SCM denominator
)
447 #define FUNC_NAME "make-ratio"
449 /* First make sure the arguments are proper.
451 if (SCM_I_INUMP (denominator
))
453 if (scm_is_eq (denominator
, SCM_INUM0
))
454 scm_num_overflow ("make-ratio");
455 if (scm_is_eq (denominator
, SCM_INUM1
))
460 if (!(SCM_BIGP(denominator
)))
461 SCM_WRONG_TYPE_ARG (2, denominator
);
463 if (!SCM_I_INUMP (numerator
) && !SCM_BIGP (numerator
))
464 SCM_WRONG_TYPE_ARG (1, numerator
);
466 /* Then flip signs so that the denominator is positive.
468 if (scm_is_true (scm_negative_p (denominator
)))
470 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
471 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
474 /* Now consider for each of the four fixnum/bignum combinations
475 whether the rational number is really an integer.
477 if (SCM_I_INUMP (numerator
))
479 scm_t_inum x
= SCM_I_INUM (numerator
);
480 if (scm_is_eq (numerator
, SCM_INUM0
))
482 if (SCM_I_INUMP (denominator
))
485 y
= SCM_I_INUM (denominator
);
489 return SCM_I_MAKINUM (x
/ y
);
493 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
494 of that value for the denominator, as a bignum. Apart from
495 that case, abs(bignum) > abs(inum) so inum/bignum is not an
497 if (x
== SCM_MOST_NEGATIVE_FIXNUM
498 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
499 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
500 return SCM_I_MAKINUM(-1);
503 else if (SCM_BIGP (numerator
))
505 if (SCM_I_INUMP (denominator
))
507 scm_t_inum yy
= SCM_I_INUM (denominator
);
508 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
509 return scm_divide (numerator
, denominator
);
513 if (scm_is_eq (numerator
, denominator
))
515 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
516 SCM_I_BIG_MPZ (denominator
)))
517 return scm_divide(numerator
, denominator
);
521 /* No, it's a proper fraction.
524 SCM divisor
= scm_gcd (numerator
, denominator
);
525 if (!(scm_is_eq (divisor
, SCM_INUM1
)))
527 numerator
= scm_divide (numerator
, divisor
);
528 denominator
= scm_divide (denominator
, divisor
);
531 return scm_double_cell (scm_tc16_fraction
,
532 SCM_UNPACK (numerator
),
533 SCM_UNPACK (denominator
), 0);
539 scm_i_fraction2double (SCM z
)
541 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
542 SCM_FRACTION_DENOMINATOR (z
)));
546 double_is_non_negative_zero (double x
)
548 static double zero
= 0.0;
550 return !memcmp (&x
, &zero
, sizeof(double));
553 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
555 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
557 #define FUNC_NAME s_scm_exact_p
559 if (SCM_INEXACTP (x
))
561 else if (SCM_NUMBERP (x
))
564 SCM_WTA_DISPATCH_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
569 scm_is_exact (SCM val
)
571 return scm_is_true (scm_exact_p (val
));
574 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
576 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
578 #define FUNC_NAME s_scm_inexact_p
580 if (SCM_INEXACTP (x
))
582 else if (SCM_NUMBERP (x
))
585 SCM_WTA_DISPATCH_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
590 scm_is_inexact (SCM val
)
592 return scm_is_true (scm_inexact_p (val
));
595 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
597 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
599 #define FUNC_NAME s_scm_odd_p
603 scm_t_inum val
= SCM_I_INUM (n
);
604 return scm_from_bool ((val
& 1L) != 0);
606 else if (SCM_BIGP (n
))
608 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
609 scm_remember_upto_here_1 (n
);
610 return scm_from_bool (odd_p
);
612 else if (SCM_REALP (n
))
614 double val
= SCM_REAL_VALUE (n
);
615 if (DOUBLE_IS_FINITE (val
))
617 double rem
= fabs (fmod (val
, 2.0));
624 SCM_WTA_DISPATCH_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
629 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
631 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
633 #define FUNC_NAME s_scm_even_p
637 scm_t_inum val
= SCM_I_INUM (n
);
638 return scm_from_bool ((val
& 1L) == 0);
640 else if (SCM_BIGP (n
))
642 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
643 scm_remember_upto_here_1 (n
);
644 return scm_from_bool (even_p
);
646 else if (SCM_REALP (n
))
648 double val
= SCM_REAL_VALUE (n
);
649 if (DOUBLE_IS_FINITE (val
))
651 double rem
= fabs (fmod (val
, 2.0));
658 SCM_WTA_DISPATCH_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
662 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
664 "Return @code{#t} if the real number @var{x} is neither\n"
665 "infinite nor a NaN, @code{#f} otherwise.")
666 #define FUNC_NAME s_scm_finite_p
669 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
670 else if (scm_is_real (x
))
673 SCM_WTA_DISPATCH_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
677 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
679 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
680 "@samp{-inf.0}. Otherwise return @code{#f}.")
681 #define FUNC_NAME s_scm_inf_p
684 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
685 else if (scm_is_real (x
))
688 SCM_WTA_DISPATCH_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
692 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
694 "Return @code{#t} if the real number @var{x} is a NaN,\n"
695 "or @code{#f} otherwise.")
696 #define FUNC_NAME s_scm_nan_p
699 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
700 else if (scm_is_real (x
))
703 SCM_WTA_DISPATCH_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
707 /* Guile's idea of infinity. */
708 static double guile_Inf
;
710 /* Guile's idea of not a number. */
711 static double guile_NaN
;
714 guile_ieee_init (void)
716 /* Some version of gcc on some old version of Linux used to crash when
717 trying to make Inf and NaN. */
720 /* C99 INFINITY, when available.
721 FIXME: The standard allows for INFINITY to be something that overflows
722 at compile time. We ought to have a configure test to check for that
723 before trying to use it. (But in practice we believe this is not a
724 problem on any system guile is likely to target.) */
725 guile_Inf
= INFINITY
;
726 #elif defined HAVE_DINFINITY
728 extern unsigned int DINFINITY
[2];
729 guile_Inf
= (*((double *) (DINFINITY
)));
736 if (guile_Inf
== tmp
)
743 /* C99 NAN, when available */
745 #elif defined HAVE_DQNAN
748 extern unsigned int DQNAN
[2];
749 guile_NaN
= (*((double *)(DQNAN
)));
752 guile_NaN
= guile_Inf
/ guile_Inf
;
756 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
759 #define FUNC_NAME s_scm_inf
761 static int initialized
= 0;
767 return scm_from_double (guile_Inf
);
771 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
774 #define FUNC_NAME s_scm_nan
776 static int initialized
= 0;
782 return scm_from_double (guile_NaN
);
787 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
789 "Return the absolute value of @var{x}.")
790 #define FUNC_NAME s_scm_abs
794 scm_t_inum xx
= SCM_I_INUM (x
);
797 else if (SCM_POSFIXABLE (-xx
))
798 return SCM_I_MAKINUM (-xx
);
800 return scm_i_inum2big (-xx
);
802 else if (SCM_LIKELY (SCM_REALP (x
)))
804 double xx
= SCM_REAL_VALUE (x
);
805 /* If x is a NaN then xx<0 is false so we return x unchanged */
807 return scm_from_double (-xx
);
808 /* Handle signed zeroes properly */
809 else if (SCM_UNLIKELY (xx
== 0.0))
814 else if (SCM_BIGP (x
))
816 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
818 return scm_i_clonebig (x
, 0);
822 else if (SCM_FRACTIONP (x
))
824 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
826 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
827 SCM_FRACTION_DENOMINATOR (x
));
830 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
835 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
837 "Return the quotient of the numbers @var{x} and @var{y}.")
838 #define FUNC_NAME s_scm_quotient
840 if (SCM_LIKELY (scm_is_integer (x
)))
842 if (SCM_LIKELY (scm_is_integer (y
)))
843 return scm_truncate_quotient (x
, y
);
845 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
848 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
852 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
854 "Return the remainder of the numbers @var{x} and @var{y}.\n"
856 "(remainder 13 4) @result{} 1\n"
857 "(remainder -13 4) @result{} -1\n"
859 #define FUNC_NAME s_scm_remainder
861 if (SCM_LIKELY (scm_is_integer (x
)))
863 if (SCM_LIKELY (scm_is_integer (y
)))
864 return scm_truncate_remainder (x
, y
);
866 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
869 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
874 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
876 "Return the modulo of the numbers @var{x} and @var{y}.\n"
878 "(modulo 13 4) @result{} 1\n"
879 "(modulo -13 4) @result{} 3\n"
881 #define FUNC_NAME s_scm_modulo
883 if (SCM_LIKELY (scm_is_integer (x
)))
885 if (SCM_LIKELY (scm_is_integer (y
)))
886 return scm_floor_remainder (x
, y
);
888 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
891 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
895 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
896 two-valued functions. It is called from primitive generics that take
897 two arguments and return two values, when the core procedure is
898 unable to handle the given argument types. If there are GOOPS
899 methods for this primitive generic, it dispatches to GOOPS and, if
900 successful, expects two values to be returned, which are placed in
901 *rp1 and *rp2. If there are no GOOPS methods, it throws a
902 wrong-type-arg exception.
904 FIXME: This obviously belongs somewhere else, but until we decide on
905 the right API, it is here as a static function, because it is needed
906 by the *_divide functions below.
909 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
910 const char *subr
, SCM
*rp1
, SCM
*rp2
)
913 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
915 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
918 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
920 "Return the integer @var{q} such that\n"
921 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
922 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
924 "(euclidean-quotient 123 10) @result{} 12\n"
925 "(euclidean-quotient 123 -10) @result{} -12\n"
926 "(euclidean-quotient -123 10) @result{} -13\n"
927 "(euclidean-quotient -123 -10) @result{} 13\n"
928 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
929 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
931 #define FUNC_NAME s_scm_euclidean_quotient
933 if (scm_is_false (scm_negative_p (y
)))
934 return scm_floor_quotient (x
, y
);
936 return scm_ceiling_quotient (x
, y
);
940 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
942 "Return the real number @var{r} such that\n"
943 "@math{0 <= @var{r} < abs(@var{y})} and\n"
944 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
945 "for some integer @var{q}.\n"
947 "(euclidean-remainder 123 10) @result{} 3\n"
948 "(euclidean-remainder 123 -10) @result{} 3\n"
949 "(euclidean-remainder -123 10) @result{} 7\n"
950 "(euclidean-remainder -123 -10) @result{} 7\n"
951 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
952 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
954 #define FUNC_NAME s_scm_euclidean_remainder
956 if (scm_is_false (scm_negative_p (y
)))
957 return scm_floor_remainder (x
, y
);
959 return scm_ceiling_remainder (x
, y
);
963 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
965 "Return the integer @var{q} and the real number @var{r}\n"
966 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
967 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
969 "(euclidean/ 123 10) @result{} 12 and 3\n"
970 "(euclidean/ 123 -10) @result{} -12 and 3\n"
971 "(euclidean/ -123 10) @result{} -13 and 7\n"
972 "(euclidean/ -123 -10) @result{} 13 and 7\n"
973 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
974 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
976 #define FUNC_NAME s_scm_i_euclidean_divide
978 if (scm_is_false (scm_negative_p (y
)))
979 return scm_i_floor_divide (x
, y
);
981 return scm_i_ceiling_divide (x
, y
);
986 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
988 if (scm_is_false (scm_negative_p (y
)))
989 return scm_floor_divide (x
, y
, qp
, rp
);
991 return scm_ceiling_divide (x
, y
, qp
, rp
);
994 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
995 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
997 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
999 "Return the floor of @math{@var{x} / @var{y}}.\n"
1001 "(floor-quotient 123 10) @result{} 12\n"
1002 "(floor-quotient 123 -10) @result{} -13\n"
1003 "(floor-quotient -123 10) @result{} -13\n"
1004 "(floor-quotient -123 -10) @result{} 12\n"
1005 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1006 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1008 #define FUNC_NAME s_scm_floor_quotient
1010 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1012 scm_t_inum xx
= SCM_I_INUM (x
);
1013 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1015 scm_t_inum yy
= SCM_I_INUM (y
);
1016 scm_t_inum xx1
= xx
;
1018 if (SCM_LIKELY (yy
> 0))
1020 if (SCM_UNLIKELY (xx
< 0))
1023 else if (SCM_UNLIKELY (yy
== 0))
1024 scm_num_overflow (s_scm_floor_quotient
);
1028 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1029 return SCM_I_MAKINUM (qq
);
1031 return scm_i_inum2big (qq
);
1033 else if (SCM_BIGP (y
))
1035 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1036 scm_remember_upto_here_1 (y
);
1038 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1040 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1042 else if (SCM_REALP (y
))
1043 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1044 else if (SCM_FRACTIONP (y
))
1045 return scm_i_exact_rational_floor_quotient (x
, y
);
1047 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1048 s_scm_floor_quotient
);
1050 else if (SCM_BIGP (x
))
1052 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1054 scm_t_inum yy
= SCM_I_INUM (y
);
1055 if (SCM_UNLIKELY (yy
== 0))
1056 scm_num_overflow (s_scm_floor_quotient
);
1057 else if (SCM_UNLIKELY (yy
== 1))
1061 SCM q
= scm_i_mkbig ();
1063 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1066 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1067 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1069 scm_remember_upto_here_1 (x
);
1070 return scm_i_normbig (q
);
1073 else if (SCM_BIGP (y
))
1075 SCM q
= scm_i_mkbig ();
1076 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1079 scm_remember_upto_here_2 (x
, y
);
1080 return scm_i_normbig (q
);
1082 else if (SCM_REALP (y
))
1083 return scm_i_inexact_floor_quotient
1084 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1085 else if (SCM_FRACTIONP (y
))
1086 return scm_i_exact_rational_floor_quotient (x
, y
);
1088 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1089 s_scm_floor_quotient
);
1091 else if (SCM_REALP (x
))
1093 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1094 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1095 return scm_i_inexact_floor_quotient
1096 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1098 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1099 s_scm_floor_quotient
);
1101 else if (SCM_FRACTIONP (x
))
1104 return scm_i_inexact_floor_quotient
1105 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1106 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1107 return scm_i_exact_rational_floor_quotient (x
, y
);
1109 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1110 s_scm_floor_quotient
);
1113 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1114 s_scm_floor_quotient
);
1119 scm_i_inexact_floor_quotient (double x
, double y
)
1121 if (SCM_UNLIKELY (y
== 0))
1122 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1124 return scm_from_double (floor (x
/ y
));
1128 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1130 return scm_floor_quotient
1131 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1132 scm_product (scm_numerator (y
), scm_denominator (x
)));
1135 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1136 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1138 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1140 "Return the real number @var{r} such that\n"
1141 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1142 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1144 "(floor-remainder 123 10) @result{} 3\n"
1145 "(floor-remainder 123 -10) @result{} -7\n"
1146 "(floor-remainder -123 10) @result{} 7\n"
1147 "(floor-remainder -123 -10) @result{} -3\n"
1148 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1149 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1151 #define FUNC_NAME s_scm_floor_remainder
1153 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1155 scm_t_inum xx
= SCM_I_INUM (x
);
1156 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1158 scm_t_inum yy
= SCM_I_INUM (y
);
1159 if (SCM_UNLIKELY (yy
== 0))
1160 scm_num_overflow (s_scm_floor_remainder
);
1163 scm_t_inum rr
= xx
% yy
;
1164 int needs_adjustment
;
1166 if (SCM_LIKELY (yy
> 0))
1167 needs_adjustment
= (rr
< 0);
1169 needs_adjustment
= (rr
> 0);
1171 if (needs_adjustment
)
1173 return SCM_I_MAKINUM (rr
);
1176 else if (SCM_BIGP (y
))
1178 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1179 scm_remember_upto_here_1 (y
);
1184 SCM r
= scm_i_mkbig ();
1185 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1186 scm_remember_upto_here_1 (y
);
1187 return scm_i_normbig (r
);
1196 SCM r
= scm_i_mkbig ();
1197 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1198 scm_remember_upto_here_1 (y
);
1199 return scm_i_normbig (r
);
1202 else if (SCM_REALP (y
))
1203 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1204 else if (SCM_FRACTIONP (y
))
1205 return scm_i_exact_rational_floor_remainder (x
, y
);
1207 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1208 s_scm_floor_remainder
);
1210 else if (SCM_BIGP (x
))
1212 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1214 scm_t_inum yy
= SCM_I_INUM (y
);
1215 if (SCM_UNLIKELY (yy
== 0))
1216 scm_num_overflow (s_scm_floor_remainder
);
1221 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1223 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1224 scm_remember_upto_here_1 (x
);
1225 return SCM_I_MAKINUM (rr
);
1228 else if (SCM_BIGP (y
))
1230 SCM r
= scm_i_mkbig ();
1231 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1234 scm_remember_upto_here_2 (x
, y
);
1235 return scm_i_normbig (r
);
1237 else if (SCM_REALP (y
))
1238 return scm_i_inexact_floor_remainder
1239 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1240 else if (SCM_FRACTIONP (y
))
1241 return scm_i_exact_rational_floor_remainder (x
, y
);
1243 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1244 s_scm_floor_remainder
);
1246 else if (SCM_REALP (x
))
1248 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1249 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1250 return scm_i_inexact_floor_remainder
1251 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1253 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1254 s_scm_floor_remainder
);
1256 else if (SCM_FRACTIONP (x
))
1259 return scm_i_inexact_floor_remainder
1260 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1261 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1262 return scm_i_exact_rational_floor_remainder (x
, y
);
1264 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1265 s_scm_floor_remainder
);
1268 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1269 s_scm_floor_remainder
);
1274 scm_i_inexact_floor_remainder (double x
, double y
)
1276 /* Although it would be more efficient to use fmod here, we can't
1277 because it would in some cases produce results inconsistent with
1278 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1279 close). In particular, when x is very close to a multiple of y,
1280 then r might be either 0.0 or y, but those two cases must
1281 correspond to different choices of q. If r = 0.0 then q must be
1282 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1283 and remainder chooses the other, it would be bad. */
1284 if (SCM_UNLIKELY (y
== 0))
1285 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1287 return scm_from_double (x
- y
* floor (x
/ y
));
1291 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1293 SCM xd
= scm_denominator (x
);
1294 SCM yd
= scm_denominator (y
);
1295 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1296 scm_product (scm_numerator (y
), xd
));
1297 return scm_divide (r1
, scm_product (xd
, yd
));
1301 static void scm_i_inexact_floor_divide (double x
, double y
,
1303 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1306 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1308 "Return the integer @var{q} and the real number @var{r}\n"
1309 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1310 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1312 "(floor/ 123 10) @result{} 12 and 3\n"
1313 "(floor/ 123 -10) @result{} -13 and -7\n"
1314 "(floor/ -123 10) @result{} -13 and 7\n"
1315 "(floor/ -123 -10) @result{} 12 and -3\n"
1316 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1317 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1319 #define FUNC_NAME s_scm_i_floor_divide
1323 scm_floor_divide(x
, y
, &q
, &r
);
1324 return scm_values (scm_list_2 (q
, r
));
1328 #define s_scm_floor_divide s_scm_i_floor_divide
1329 #define g_scm_floor_divide g_scm_i_floor_divide
1332 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1334 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1336 scm_t_inum xx
= SCM_I_INUM (x
);
1337 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1339 scm_t_inum yy
= SCM_I_INUM (y
);
1340 if (SCM_UNLIKELY (yy
== 0))
1341 scm_num_overflow (s_scm_floor_divide
);
1344 scm_t_inum qq
= xx
/ yy
;
1345 scm_t_inum rr
= xx
% yy
;
1346 int needs_adjustment
;
1348 if (SCM_LIKELY (yy
> 0))
1349 needs_adjustment
= (rr
< 0);
1351 needs_adjustment
= (rr
> 0);
1353 if (needs_adjustment
)
1359 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1360 *qp
= SCM_I_MAKINUM (qq
);
1362 *qp
= scm_i_inum2big (qq
);
1363 *rp
= SCM_I_MAKINUM (rr
);
1367 else if (SCM_BIGP (y
))
1369 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1370 scm_remember_upto_here_1 (y
);
1375 SCM r
= scm_i_mkbig ();
1376 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1377 scm_remember_upto_here_1 (y
);
1378 *qp
= SCM_I_MAKINUM (-1);
1379 *rp
= scm_i_normbig (r
);
1394 SCM r
= scm_i_mkbig ();
1395 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1396 scm_remember_upto_here_1 (y
);
1397 *qp
= SCM_I_MAKINUM (-1);
1398 *rp
= scm_i_normbig (r
);
1402 else if (SCM_REALP (y
))
1403 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1404 else if (SCM_FRACTIONP (y
))
1405 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1407 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1408 s_scm_floor_divide
, qp
, rp
);
1410 else if (SCM_BIGP (x
))
1412 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1414 scm_t_inum yy
= SCM_I_INUM (y
);
1415 if (SCM_UNLIKELY (yy
== 0))
1416 scm_num_overflow (s_scm_floor_divide
);
1419 SCM q
= scm_i_mkbig ();
1420 SCM r
= scm_i_mkbig ();
1422 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1423 SCM_I_BIG_MPZ (x
), yy
);
1426 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1427 SCM_I_BIG_MPZ (x
), -yy
);
1428 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1430 scm_remember_upto_here_1 (x
);
1431 *qp
= scm_i_normbig (q
);
1432 *rp
= scm_i_normbig (r
);
1436 else if (SCM_BIGP (y
))
1438 SCM q
= scm_i_mkbig ();
1439 SCM r
= scm_i_mkbig ();
1440 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1441 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1442 scm_remember_upto_here_2 (x
, y
);
1443 *qp
= scm_i_normbig (q
);
1444 *rp
= scm_i_normbig (r
);
1447 else if (SCM_REALP (y
))
1448 return scm_i_inexact_floor_divide
1449 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1450 else if (SCM_FRACTIONP (y
))
1451 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1453 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1454 s_scm_floor_divide
, qp
, rp
);
1456 else if (SCM_REALP (x
))
1458 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1459 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1460 return scm_i_inexact_floor_divide
1461 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1463 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1464 s_scm_floor_divide
, qp
, rp
);
1466 else if (SCM_FRACTIONP (x
))
1469 return scm_i_inexact_floor_divide
1470 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1471 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1472 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1474 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1475 s_scm_floor_divide
, qp
, rp
);
1478 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1479 s_scm_floor_divide
, qp
, rp
);
1483 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1485 if (SCM_UNLIKELY (y
== 0))
1486 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1489 double q
= floor (x
/ y
);
1490 double r
= x
- q
* y
;
1491 *qp
= scm_from_double (q
);
1492 *rp
= scm_from_double (r
);
1497 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1500 SCM xd
= scm_denominator (x
);
1501 SCM yd
= scm_denominator (y
);
1503 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1504 scm_product (scm_numerator (y
), xd
),
1506 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1509 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1510 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1512 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1514 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1516 "(ceiling-quotient 123 10) @result{} 13\n"
1517 "(ceiling-quotient 123 -10) @result{} -12\n"
1518 "(ceiling-quotient -123 10) @result{} -12\n"
1519 "(ceiling-quotient -123 -10) @result{} 13\n"
1520 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1521 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1523 #define FUNC_NAME s_scm_ceiling_quotient
1525 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1527 scm_t_inum xx
= SCM_I_INUM (x
);
1528 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1530 scm_t_inum yy
= SCM_I_INUM (y
);
1531 if (SCM_UNLIKELY (yy
== 0))
1532 scm_num_overflow (s_scm_ceiling_quotient
);
1535 scm_t_inum xx1
= xx
;
1537 if (SCM_LIKELY (yy
> 0))
1539 if (SCM_LIKELY (xx
>= 0))
1545 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1546 return SCM_I_MAKINUM (qq
);
1548 return scm_i_inum2big (qq
);
1551 else if (SCM_BIGP (y
))
1553 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1554 scm_remember_upto_here_1 (y
);
1555 if (SCM_LIKELY (sign
> 0))
1557 if (SCM_LIKELY (xx
> 0))
1559 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1560 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1561 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1563 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1564 scm_remember_upto_here_1 (y
);
1565 return SCM_I_MAKINUM (-1);
1575 else if (SCM_REALP (y
))
1576 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1577 else if (SCM_FRACTIONP (y
))
1578 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1580 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1581 s_scm_ceiling_quotient
);
1583 else if (SCM_BIGP (x
))
1585 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1587 scm_t_inum yy
= SCM_I_INUM (y
);
1588 if (SCM_UNLIKELY (yy
== 0))
1589 scm_num_overflow (s_scm_ceiling_quotient
);
1590 else if (SCM_UNLIKELY (yy
== 1))
1594 SCM q
= scm_i_mkbig ();
1596 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1599 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1600 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1602 scm_remember_upto_here_1 (x
);
1603 return scm_i_normbig (q
);
1606 else if (SCM_BIGP (y
))
1608 SCM q
= scm_i_mkbig ();
1609 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1612 scm_remember_upto_here_2 (x
, y
);
1613 return scm_i_normbig (q
);
1615 else if (SCM_REALP (y
))
1616 return scm_i_inexact_ceiling_quotient
1617 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1618 else if (SCM_FRACTIONP (y
))
1619 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1621 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1622 s_scm_ceiling_quotient
);
1624 else if (SCM_REALP (x
))
1626 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1627 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1628 return scm_i_inexact_ceiling_quotient
1629 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1631 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1632 s_scm_ceiling_quotient
);
1634 else if (SCM_FRACTIONP (x
))
1637 return scm_i_inexact_ceiling_quotient
1638 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1639 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1640 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1642 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1643 s_scm_ceiling_quotient
);
1646 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1647 s_scm_ceiling_quotient
);
1652 scm_i_inexact_ceiling_quotient (double x
, double y
)
1654 if (SCM_UNLIKELY (y
== 0))
1655 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1657 return scm_from_double (ceil (x
/ y
));
1661 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1663 return scm_ceiling_quotient
1664 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1665 scm_product (scm_numerator (y
), scm_denominator (x
)));
1668 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1669 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1671 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1673 "Return the real number @var{r} such that\n"
1674 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1675 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1677 "(ceiling-remainder 123 10) @result{} -7\n"
1678 "(ceiling-remainder 123 -10) @result{} 3\n"
1679 "(ceiling-remainder -123 10) @result{} -3\n"
1680 "(ceiling-remainder -123 -10) @result{} 7\n"
1681 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1682 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1684 #define FUNC_NAME s_scm_ceiling_remainder
1686 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1688 scm_t_inum xx
= SCM_I_INUM (x
);
1689 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1691 scm_t_inum yy
= SCM_I_INUM (y
);
1692 if (SCM_UNLIKELY (yy
== 0))
1693 scm_num_overflow (s_scm_ceiling_remainder
);
1696 scm_t_inum rr
= xx
% yy
;
1697 int needs_adjustment
;
1699 if (SCM_LIKELY (yy
> 0))
1700 needs_adjustment
= (rr
> 0);
1702 needs_adjustment
= (rr
< 0);
1704 if (needs_adjustment
)
1706 return SCM_I_MAKINUM (rr
);
1709 else if (SCM_BIGP (y
))
1711 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1712 scm_remember_upto_here_1 (y
);
1713 if (SCM_LIKELY (sign
> 0))
1715 if (SCM_LIKELY (xx
> 0))
1717 SCM r
= scm_i_mkbig ();
1718 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1719 scm_remember_upto_here_1 (y
);
1720 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1721 return scm_i_normbig (r
);
1723 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1724 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1725 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1727 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1728 scm_remember_upto_here_1 (y
);
1738 SCM r
= scm_i_mkbig ();
1739 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1740 scm_remember_upto_here_1 (y
);
1741 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1742 return scm_i_normbig (r
);
1745 else if (SCM_REALP (y
))
1746 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1747 else if (SCM_FRACTIONP (y
))
1748 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1750 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1751 s_scm_ceiling_remainder
);
1753 else if (SCM_BIGP (x
))
1755 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1757 scm_t_inum yy
= SCM_I_INUM (y
);
1758 if (SCM_UNLIKELY (yy
== 0))
1759 scm_num_overflow (s_scm_ceiling_remainder
);
1764 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1766 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1767 scm_remember_upto_here_1 (x
);
1768 return SCM_I_MAKINUM (rr
);
1771 else if (SCM_BIGP (y
))
1773 SCM r
= scm_i_mkbig ();
1774 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1777 scm_remember_upto_here_2 (x
, y
);
1778 return scm_i_normbig (r
);
1780 else if (SCM_REALP (y
))
1781 return scm_i_inexact_ceiling_remainder
1782 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1783 else if (SCM_FRACTIONP (y
))
1784 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1786 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1787 s_scm_ceiling_remainder
);
1789 else if (SCM_REALP (x
))
1791 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1792 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1793 return scm_i_inexact_ceiling_remainder
1794 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1796 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1797 s_scm_ceiling_remainder
);
1799 else if (SCM_FRACTIONP (x
))
1802 return scm_i_inexact_ceiling_remainder
1803 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1804 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1805 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1807 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1808 s_scm_ceiling_remainder
);
1811 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1812 s_scm_ceiling_remainder
);
1817 scm_i_inexact_ceiling_remainder (double x
, double y
)
1819 /* Although it would be more efficient to use fmod here, we can't
1820 because it would in some cases produce results inconsistent with
1821 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1822 close). In particular, when x is very close to a multiple of y,
1823 then r might be either 0.0 or -y, but those two cases must
1824 correspond to different choices of q. If r = 0.0 then q must be
1825 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1826 and remainder chooses the other, it would be bad. */
1827 if (SCM_UNLIKELY (y
== 0))
1828 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1830 return scm_from_double (x
- y
* ceil (x
/ y
));
1834 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1836 SCM xd
= scm_denominator (x
);
1837 SCM yd
= scm_denominator (y
);
1838 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1839 scm_product (scm_numerator (y
), xd
));
1840 return scm_divide (r1
, scm_product (xd
, yd
));
1843 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1845 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1848 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1850 "Return the integer @var{q} and the real number @var{r}\n"
1851 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1852 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1854 "(ceiling/ 123 10) @result{} 13 and -7\n"
1855 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1856 "(ceiling/ -123 10) @result{} -12 and -3\n"
1857 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1858 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1859 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1861 #define FUNC_NAME s_scm_i_ceiling_divide
1865 scm_ceiling_divide(x
, y
, &q
, &r
);
1866 return scm_values (scm_list_2 (q
, r
));
1870 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1871 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1874 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1876 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1878 scm_t_inum xx
= SCM_I_INUM (x
);
1879 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1881 scm_t_inum yy
= SCM_I_INUM (y
);
1882 if (SCM_UNLIKELY (yy
== 0))
1883 scm_num_overflow (s_scm_ceiling_divide
);
1886 scm_t_inum qq
= xx
/ yy
;
1887 scm_t_inum rr
= xx
% yy
;
1888 int needs_adjustment
;
1890 if (SCM_LIKELY (yy
> 0))
1891 needs_adjustment
= (rr
> 0);
1893 needs_adjustment
= (rr
< 0);
1895 if (needs_adjustment
)
1900 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1901 *qp
= SCM_I_MAKINUM (qq
);
1903 *qp
= scm_i_inum2big (qq
);
1904 *rp
= SCM_I_MAKINUM (rr
);
1908 else if (SCM_BIGP (y
))
1910 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1911 scm_remember_upto_here_1 (y
);
1912 if (SCM_LIKELY (sign
> 0))
1914 if (SCM_LIKELY (xx
> 0))
1916 SCM r
= scm_i_mkbig ();
1917 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1918 scm_remember_upto_here_1 (y
);
1919 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1921 *rp
= scm_i_normbig (r
);
1923 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1924 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1925 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1927 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1928 scm_remember_upto_here_1 (y
);
1929 *qp
= SCM_I_MAKINUM (-1);
1945 SCM r
= scm_i_mkbig ();
1946 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1947 scm_remember_upto_here_1 (y
);
1948 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1950 *rp
= scm_i_normbig (r
);
1954 else if (SCM_REALP (y
))
1955 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1956 else if (SCM_FRACTIONP (y
))
1957 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1959 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1960 s_scm_ceiling_divide
, qp
, rp
);
1962 else if (SCM_BIGP (x
))
1964 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1966 scm_t_inum yy
= SCM_I_INUM (y
);
1967 if (SCM_UNLIKELY (yy
== 0))
1968 scm_num_overflow (s_scm_ceiling_divide
);
1971 SCM q
= scm_i_mkbig ();
1972 SCM r
= scm_i_mkbig ();
1974 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1975 SCM_I_BIG_MPZ (x
), yy
);
1978 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1979 SCM_I_BIG_MPZ (x
), -yy
);
1980 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1982 scm_remember_upto_here_1 (x
);
1983 *qp
= scm_i_normbig (q
);
1984 *rp
= scm_i_normbig (r
);
1988 else if (SCM_BIGP (y
))
1990 SCM q
= scm_i_mkbig ();
1991 SCM r
= scm_i_mkbig ();
1992 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1993 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1994 scm_remember_upto_here_2 (x
, y
);
1995 *qp
= scm_i_normbig (q
);
1996 *rp
= scm_i_normbig (r
);
1999 else if (SCM_REALP (y
))
2000 return scm_i_inexact_ceiling_divide
2001 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2002 else if (SCM_FRACTIONP (y
))
2003 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2005 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2006 s_scm_ceiling_divide
, qp
, rp
);
2008 else if (SCM_REALP (x
))
2010 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2011 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2012 return scm_i_inexact_ceiling_divide
2013 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2015 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2016 s_scm_ceiling_divide
, qp
, rp
);
2018 else if (SCM_FRACTIONP (x
))
2021 return scm_i_inexact_ceiling_divide
2022 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2023 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2024 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2026 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2027 s_scm_ceiling_divide
, qp
, rp
);
2030 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2031 s_scm_ceiling_divide
, qp
, rp
);
2035 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2037 if (SCM_UNLIKELY (y
== 0))
2038 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2041 double q
= ceil (x
/ y
);
2042 double r
= x
- q
* y
;
2043 *qp
= scm_from_double (q
);
2044 *rp
= scm_from_double (r
);
2049 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2052 SCM xd
= scm_denominator (x
);
2053 SCM yd
= scm_denominator (y
);
2055 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2056 scm_product (scm_numerator (y
), xd
),
2058 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2061 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2062 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2064 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2066 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2068 "(truncate-quotient 123 10) @result{} 12\n"
2069 "(truncate-quotient 123 -10) @result{} -12\n"
2070 "(truncate-quotient -123 10) @result{} -12\n"
2071 "(truncate-quotient -123 -10) @result{} 12\n"
2072 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2073 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2075 #define FUNC_NAME s_scm_truncate_quotient
2077 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2079 scm_t_inum xx
= SCM_I_INUM (x
);
2080 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2082 scm_t_inum yy
= SCM_I_INUM (y
);
2083 if (SCM_UNLIKELY (yy
== 0))
2084 scm_num_overflow (s_scm_truncate_quotient
);
2087 scm_t_inum qq
= xx
/ yy
;
2088 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2089 return SCM_I_MAKINUM (qq
);
2091 return scm_i_inum2big (qq
);
2094 else if (SCM_BIGP (y
))
2096 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2097 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2098 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2100 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2101 scm_remember_upto_here_1 (y
);
2102 return SCM_I_MAKINUM (-1);
2107 else if (SCM_REALP (y
))
2108 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2109 else if (SCM_FRACTIONP (y
))
2110 return scm_i_exact_rational_truncate_quotient (x
, y
);
2112 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2113 s_scm_truncate_quotient
);
2115 else if (SCM_BIGP (x
))
2117 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2119 scm_t_inum yy
= SCM_I_INUM (y
);
2120 if (SCM_UNLIKELY (yy
== 0))
2121 scm_num_overflow (s_scm_truncate_quotient
);
2122 else if (SCM_UNLIKELY (yy
== 1))
2126 SCM q
= scm_i_mkbig ();
2128 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2131 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2132 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2134 scm_remember_upto_here_1 (x
);
2135 return scm_i_normbig (q
);
2138 else if (SCM_BIGP (y
))
2140 SCM q
= scm_i_mkbig ();
2141 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2144 scm_remember_upto_here_2 (x
, y
);
2145 return scm_i_normbig (q
);
2147 else if (SCM_REALP (y
))
2148 return scm_i_inexact_truncate_quotient
2149 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2150 else if (SCM_FRACTIONP (y
))
2151 return scm_i_exact_rational_truncate_quotient (x
, y
);
2153 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2154 s_scm_truncate_quotient
);
2156 else if (SCM_REALP (x
))
2158 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2159 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2160 return scm_i_inexact_truncate_quotient
2161 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2163 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2164 s_scm_truncate_quotient
);
2166 else if (SCM_FRACTIONP (x
))
2169 return scm_i_inexact_truncate_quotient
2170 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2171 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2172 return scm_i_exact_rational_truncate_quotient (x
, y
);
2174 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2175 s_scm_truncate_quotient
);
2178 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2179 s_scm_truncate_quotient
);
2184 scm_i_inexact_truncate_quotient (double x
, double y
)
2186 if (SCM_UNLIKELY (y
== 0))
2187 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2189 return scm_from_double (trunc (x
/ y
));
2193 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2195 return scm_truncate_quotient
2196 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2197 scm_product (scm_numerator (y
), scm_denominator (x
)));
2200 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2201 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2203 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2205 "Return the real number @var{r} such that\n"
2206 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2207 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2209 "(truncate-remainder 123 10) @result{} 3\n"
2210 "(truncate-remainder 123 -10) @result{} 3\n"
2211 "(truncate-remainder -123 10) @result{} -3\n"
2212 "(truncate-remainder -123 -10) @result{} -3\n"
2213 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2214 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2216 #define FUNC_NAME s_scm_truncate_remainder
2218 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2220 scm_t_inum xx
= SCM_I_INUM (x
);
2221 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2223 scm_t_inum yy
= SCM_I_INUM (y
);
2224 if (SCM_UNLIKELY (yy
== 0))
2225 scm_num_overflow (s_scm_truncate_remainder
);
2227 return SCM_I_MAKINUM (xx
% yy
);
2229 else if (SCM_BIGP (y
))
2231 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2232 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2233 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2235 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2236 scm_remember_upto_here_1 (y
);
2242 else if (SCM_REALP (y
))
2243 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2244 else if (SCM_FRACTIONP (y
))
2245 return scm_i_exact_rational_truncate_remainder (x
, y
);
2247 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2248 s_scm_truncate_remainder
);
2250 else if (SCM_BIGP (x
))
2252 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2254 scm_t_inum yy
= SCM_I_INUM (y
);
2255 if (SCM_UNLIKELY (yy
== 0))
2256 scm_num_overflow (s_scm_truncate_remainder
);
2259 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2260 (yy
> 0) ? yy
: -yy
)
2261 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2262 scm_remember_upto_here_1 (x
);
2263 return SCM_I_MAKINUM (rr
);
2266 else if (SCM_BIGP (y
))
2268 SCM r
= scm_i_mkbig ();
2269 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2272 scm_remember_upto_here_2 (x
, y
);
2273 return scm_i_normbig (r
);
2275 else if (SCM_REALP (y
))
2276 return scm_i_inexact_truncate_remainder
2277 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2278 else if (SCM_FRACTIONP (y
))
2279 return scm_i_exact_rational_truncate_remainder (x
, y
);
2281 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2282 s_scm_truncate_remainder
);
2284 else if (SCM_REALP (x
))
2286 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2287 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2288 return scm_i_inexact_truncate_remainder
2289 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2291 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2292 s_scm_truncate_remainder
);
2294 else if (SCM_FRACTIONP (x
))
2297 return scm_i_inexact_truncate_remainder
2298 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2299 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2300 return scm_i_exact_rational_truncate_remainder (x
, y
);
2302 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2303 s_scm_truncate_remainder
);
2306 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2307 s_scm_truncate_remainder
);
2312 scm_i_inexact_truncate_remainder (double x
, double y
)
2314 /* Although it would be more efficient to use fmod here, we can't
2315 because it would in some cases produce results inconsistent with
2316 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2317 close). In particular, when x is very close to a multiple of y,
2318 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2319 correspond to different choices of q. If quotient chooses one and
2320 remainder chooses the other, it would be bad. */
2321 if (SCM_UNLIKELY (y
== 0))
2322 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2324 return scm_from_double (x
- y
* trunc (x
/ y
));
2328 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2330 SCM xd
= scm_denominator (x
);
2331 SCM yd
= scm_denominator (y
);
2332 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2333 scm_product (scm_numerator (y
), xd
));
2334 return scm_divide (r1
, scm_product (xd
, yd
));
2338 static void scm_i_inexact_truncate_divide (double x
, double y
,
2340 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2343 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2345 "Return the integer @var{q} and the real number @var{r}\n"
2346 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2347 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2349 "(truncate/ 123 10) @result{} 12 and 3\n"
2350 "(truncate/ 123 -10) @result{} -12 and 3\n"
2351 "(truncate/ -123 10) @result{} -12 and -3\n"
2352 "(truncate/ -123 -10) @result{} 12 and -3\n"
2353 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2354 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2356 #define FUNC_NAME s_scm_i_truncate_divide
2360 scm_truncate_divide(x
, y
, &q
, &r
);
2361 return scm_values (scm_list_2 (q
, r
));
2365 #define s_scm_truncate_divide s_scm_i_truncate_divide
2366 #define g_scm_truncate_divide g_scm_i_truncate_divide
2369 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2371 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2373 scm_t_inum xx
= SCM_I_INUM (x
);
2374 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2376 scm_t_inum yy
= SCM_I_INUM (y
);
2377 if (SCM_UNLIKELY (yy
== 0))
2378 scm_num_overflow (s_scm_truncate_divide
);
2381 scm_t_inum qq
= xx
/ yy
;
2382 scm_t_inum rr
= xx
% yy
;
2383 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2384 *qp
= SCM_I_MAKINUM (qq
);
2386 *qp
= scm_i_inum2big (qq
);
2387 *rp
= SCM_I_MAKINUM (rr
);
2391 else if (SCM_BIGP (y
))
2393 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2394 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2395 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2397 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2398 scm_remember_upto_here_1 (y
);
2399 *qp
= SCM_I_MAKINUM (-1);
2409 else if (SCM_REALP (y
))
2410 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2411 else if (SCM_FRACTIONP (y
))
2412 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2414 return two_valued_wta_dispatch_2
2415 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2416 s_scm_truncate_divide
, qp
, rp
);
2418 else if (SCM_BIGP (x
))
2420 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2422 scm_t_inum yy
= SCM_I_INUM (y
);
2423 if (SCM_UNLIKELY (yy
== 0))
2424 scm_num_overflow (s_scm_truncate_divide
);
2427 SCM q
= scm_i_mkbig ();
2430 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2431 SCM_I_BIG_MPZ (x
), yy
);
2434 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2435 SCM_I_BIG_MPZ (x
), -yy
);
2436 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2438 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2439 scm_remember_upto_here_1 (x
);
2440 *qp
= scm_i_normbig (q
);
2441 *rp
= SCM_I_MAKINUM (rr
);
2445 else if (SCM_BIGP (y
))
2447 SCM q
= scm_i_mkbig ();
2448 SCM r
= scm_i_mkbig ();
2449 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2450 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2451 scm_remember_upto_here_2 (x
, y
);
2452 *qp
= scm_i_normbig (q
);
2453 *rp
= scm_i_normbig (r
);
2455 else if (SCM_REALP (y
))
2456 return scm_i_inexact_truncate_divide
2457 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2458 else if (SCM_FRACTIONP (y
))
2459 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2461 return two_valued_wta_dispatch_2
2462 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2463 s_scm_truncate_divide
, qp
, rp
);
2465 else if (SCM_REALP (x
))
2467 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2468 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2469 return scm_i_inexact_truncate_divide
2470 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2472 return two_valued_wta_dispatch_2
2473 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2474 s_scm_truncate_divide
, qp
, rp
);
2476 else if (SCM_FRACTIONP (x
))
2479 return scm_i_inexact_truncate_divide
2480 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2481 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2482 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2484 return two_valued_wta_dispatch_2
2485 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2486 s_scm_truncate_divide
, qp
, rp
);
2489 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2490 s_scm_truncate_divide
, qp
, rp
);
2494 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2496 if (SCM_UNLIKELY (y
== 0))
2497 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2500 double q
= trunc (x
/ y
);
2501 double r
= x
- q
* y
;
2502 *qp
= scm_from_double (q
);
2503 *rp
= scm_from_double (r
);
2508 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2511 SCM xd
= scm_denominator (x
);
2512 SCM yd
= scm_denominator (y
);
2514 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2515 scm_product (scm_numerator (y
), xd
),
2517 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2520 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2521 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2522 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2524 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2526 "Return the integer @var{q} such that\n"
2527 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2528 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2530 "(centered-quotient 123 10) @result{} 12\n"
2531 "(centered-quotient 123 -10) @result{} -12\n"
2532 "(centered-quotient -123 10) @result{} -12\n"
2533 "(centered-quotient -123 -10) @result{} 12\n"
2534 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2535 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2537 #define FUNC_NAME s_scm_centered_quotient
2539 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2541 scm_t_inum xx
= SCM_I_INUM (x
);
2542 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2544 scm_t_inum yy
= SCM_I_INUM (y
);
2545 if (SCM_UNLIKELY (yy
== 0))
2546 scm_num_overflow (s_scm_centered_quotient
);
2549 scm_t_inum qq
= xx
/ yy
;
2550 scm_t_inum rr
= xx
% yy
;
2551 if (SCM_LIKELY (xx
> 0))
2553 if (SCM_LIKELY (yy
> 0))
2555 if (rr
>= (yy
+ 1) / 2)
2560 if (rr
>= (1 - yy
) / 2)
2566 if (SCM_LIKELY (yy
> 0))
2577 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2578 return SCM_I_MAKINUM (qq
);
2580 return scm_i_inum2big (qq
);
2583 else if (SCM_BIGP (y
))
2585 /* Pass a denormalized bignum version of x (even though it
2586 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2587 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2589 else if (SCM_REALP (y
))
2590 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2591 else if (SCM_FRACTIONP (y
))
2592 return scm_i_exact_rational_centered_quotient (x
, y
);
2594 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2595 s_scm_centered_quotient
);
2597 else if (SCM_BIGP (x
))
2599 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2601 scm_t_inum yy
= SCM_I_INUM (y
);
2602 if (SCM_UNLIKELY (yy
== 0))
2603 scm_num_overflow (s_scm_centered_quotient
);
2604 else if (SCM_UNLIKELY (yy
== 1))
2608 SCM q
= scm_i_mkbig ();
2610 /* Arrange for rr to initially be non-positive,
2611 because that simplifies the test to see
2612 if it is within the needed bounds. */
2615 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2616 SCM_I_BIG_MPZ (x
), yy
);
2617 scm_remember_upto_here_1 (x
);
2619 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2620 SCM_I_BIG_MPZ (q
), 1);
2624 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2625 SCM_I_BIG_MPZ (x
), -yy
);
2626 scm_remember_upto_here_1 (x
);
2627 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2629 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2630 SCM_I_BIG_MPZ (q
), 1);
2632 return scm_i_normbig (q
);
2635 else if (SCM_BIGP (y
))
2636 return scm_i_bigint_centered_quotient (x
, y
);
2637 else if (SCM_REALP (y
))
2638 return scm_i_inexact_centered_quotient
2639 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2640 else if (SCM_FRACTIONP (y
))
2641 return scm_i_exact_rational_centered_quotient (x
, y
);
2643 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2644 s_scm_centered_quotient
);
2646 else if (SCM_REALP (x
))
2648 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2649 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2650 return scm_i_inexact_centered_quotient
2651 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2653 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2654 s_scm_centered_quotient
);
2656 else if (SCM_FRACTIONP (x
))
2659 return scm_i_inexact_centered_quotient
2660 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2661 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2662 return scm_i_exact_rational_centered_quotient (x
, y
);
2664 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2665 s_scm_centered_quotient
);
2668 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2669 s_scm_centered_quotient
);
2674 scm_i_inexact_centered_quotient (double x
, double y
)
2676 if (SCM_LIKELY (y
> 0))
2677 return scm_from_double (floor (x
/y
+ 0.5));
2678 else if (SCM_LIKELY (y
< 0))
2679 return scm_from_double (ceil (x
/y
- 0.5));
2681 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2686 /* Assumes that both x and y are bigints, though
2687 x might be able to fit into a fixnum. */
2689 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2693 /* Note that x might be small enough to fit into a
2694 fixnum, so we must not let it escape into the wild */
2698 /* min_r will eventually become -abs(y)/2 */
2699 min_r
= scm_i_mkbig ();
2700 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2701 SCM_I_BIG_MPZ (y
), 1);
2703 /* Arrange for rr to initially be non-positive,
2704 because that simplifies the test to see
2705 if it is within the needed bounds. */
2706 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2708 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2709 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2710 scm_remember_upto_here_2 (x
, y
);
2711 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2712 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2713 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2714 SCM_I_BIG_MPZ (q
), 1);
2718 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2719 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2720 scm_remember_upto_here_2 (x
, y
);
2721 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2722 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2723 SCM_I_BIG_MPZ (q
), 1);
2725 scm_remember_upto_here_2 (r
, min_r
);
2726 return scm_i_normbig (q
);
2730 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2732 return scm_centered_quotient
2733 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2734 scm_product (scm_numerator (y
), scm_denominator (x
)));
2737 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2738 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2739 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2741 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2743 "Return the real number @var{r} such that\n"
2744 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2745 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2746 "for some integer @var{q}.\n"
2748 "(centered-remainder 123 10) @result{} 3\n"
2749 "(centered-remainder 123 -10) @result{} 3\n"
2750 "(centered-remainder -123 10) @result{} -3\n"
2751 "(centered-remainder -123 -10) @result{} -3\n"
2752 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2753 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2755 #define FUNC_NAME s_scm_centered_remainder
2757 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2759 scm_t_inum xx
= SCM_I_INUM (x
);
2760 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2762 scm_t_inum yy
= SCM_I_INUM (y
);
2763 if (SCM_UNLIKELY (yy
== 0))
2764 scm_num_overflow (s_scm_centered_remainder
);
2767 scm_t_inum rr
= xx
% yy
;
2768 if (SCM_LIKELY (xx
> 0))
2770 if (SCM_LIKELY (yy
> 0))
2772 if (rr
>= (yy
+ 1) / 2)
2777 if (rr
>= (1 - yy
) / 2)
2783 if (SCM_LIKELY (yy
> 0))
2794 return SCM_I_MAKINUM (rr
);
2797 else if (SCM_BIGP (y
))
2799 /* Pass a denormalized bignum version of x (even though it
2800 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2801 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2803 else if (SCM_REALP (y
))
2804 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2805 else if (SCM_FRACTIONP (y
))
2806 return scm_i_exact_rational_centered_remainder (x
, y
);
2808 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2809 s_scm_centered_remainder
);
2811 else if (SCM_BIGP (x
))
2813 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2815 scm_t_inum yy
= SCM_I_INUM (y
);
2816 if (SCM_UNLIKELY (yy
== 0))
2817 scm_num_overflow (s_scm_centered_remainder
);
2821 /* Arrange for rr to initially be non-positive,
2822 because that simplifies the test to see
2823 if it is within the needed bounds. */
2826 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2827 scm_remember_upto_here_1 (x
);
2833 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2834 scm_remember_upto_here_1 (x
);
2838 return SCM_I_MAKINUM (rr
);
2841 else if (SCM_BIGP (y
))
2842 return scm_i_bigint_centered_remainder (x
, y
);
2843 else if (SCM_REALP (y
))
2844 return scm_i_inexact_centered_remainder
2845 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2846 else if (SCM_FRACTIONP (y
))
2847 return scm_i_exact_rational_centered_remainder (x
, y
);
2849 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2850 s_scm_centered_remainder
);
2852 else if (SCM_REALP (x
))
2854 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2855 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2856 return scm_i_inexact_centered_remainder
2857 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2859 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2860 s_scm_centered_remainder
);
2862 else if (SCM_FRACTIONP (x
))
2865 return scm_i_inexact_centered_remainder
2866 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2867 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2868 return scm_i_exact_rational_centered_remainder (x
, y
);
2870 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2871 s_scm_centered_remainder
);
2874 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2875 s_scm_centered_remainder
);
2880 scm_i_inexact_centered_remainder (double x
, double y
)
2884 /* Although it would be more efficient to use fmod here, we can't
2885 because it would in some cases produce results inconsistent with
2886 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2887 close). In particular, when x-y/2 is very close to a multiple of
2888 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2889 two cases must correspond to different choices of q. If quotient
2890 chooses one and remainder chooses the other, it would be bad. */
2891 if (SCM_LIKELY (y
> 0))
2892 q
= floor (x
/y
+ 0.5);
2893 else if (SCM_LIKELY (y
< 0))
2894 q
= ceil (x
/y
- 0.5);
2896 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2899 return scm_from_double (x
- q
* y
);
2902 /* Assumes that both x and y are bigints, though
2903 x might be able to fit into a fixnum. */
2905 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2909 /* Note that x might be small enough to fit into a
2910 fixnum, so we must not let it escape into the wild */
2913 /* min_r will eventually become -abs(y)/2 */
2914 min_r
= scm_i_mkbig ();
2915 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2916 SCM_I_BIG_MPZ (y
), 1);
2918 /* Arrange for rr to initially be non-positive,
2919 because that simplifies the test to see
2920 if it is within the needed bounds. */
2921 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2923 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2924 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2925 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2926 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2927 mpz_add (SCM_I_BIG_MPZ (r
),
2933 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2934 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2935 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2936 mpz_sub (SCM_I_BIG_MPZ (r
),
2940 scm_remember_upto_here_2 (x
, y
);
2941 return scm_i_normbig (r
);
2945 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2947 SCM xd
= scm_denominator (x
);
2948 SCM yd
= scm_denominator (y
);
2949 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2950 scm_product (scm_numerator (y
), xd
));
2951 return scm_divide (r1
, scm_product (xd
, yd
));
2955 static void scm_i_inexact_centered_divide (double x
, double y
,
2957 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2958 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2961 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2963 "Return the integer @var{q} and the real number @var{r}\n"
2964 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2965 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2967 "(centered/ 123 10) @result{} 12 and 3\n"
2968 "(centered/ 123 -10) @result{} -12 and 3\n"
2969 "(centered/ -123 10) @result{} -12 and -3\n"
2970 "(centered/ -123 -10) @result{} 12 and -3\n"
2971 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2972 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2974 #define FUNC_NAME s_scm_i_centered_divide
2978 scm_centered_divide(x
, y
, &q
, &r
);
2979 return scm_values (scm_list_2 (q
, r
));
2983 #define s_scm_centered_divide s_scm_i_centered_divide
2984 #define g_scm_centered_divide g_scm_i_centered_divide
2987 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2989 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2991 scm_t_inum xx
= SCM_I_INUM (x
);
2992 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2994 scm_t_inum yy
= SCM_I_INUM (y
);
2995 if (SCM_UNLIKELY (yy
== 0))
2996 scm_num_overflow (s_scm_centered_divide
);
2999 scm_t_inum qq
= xx
/ yy
;
3000 scm_t_inum rr
= xx
% yy
;
3001 if (SCM_LIKELY (xx
> 0))
3003 if (SCM_LIKELY (yy
> 0))
3005 if (rr
>= (yy
+ 1) / 2)
3010 if (rr
>= (1 - yy
) / 2)
3016 if (SCM_LIKELY (yy
> 0))
3027 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3028 *qp
= SCM_I_MAKINUM (qq
);
3030 *qp
= scm_i_inum2big (qq
);
3031 *rp
= SCM_I_MAKINUM (rr
);
3035 else if (SCM_BIGP (y
))
3037 /* Pass a denormalized bignum version of x (even though it
3038 can fit in a fixnum) to scm_i_bigint_centered_divide */
3039 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3041 else if (SCM_REALP (y
))
3042 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3043 else if (SCM_FRACTIONP (y
))
3044 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3046 return two_valued_wta_dispatch_2
3047 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3048 s_scm_centered_divide
, qp
, rp
);
3050 else if (SCM_BIGP (x
))
3052 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3054 scm_t_inum yy
= SCM_I_INUM (y
);
3055 if (SCM_UNLIKELY (yy
== 0))
3056 scm_num_overflow (s_scm_centered_divide
);
3059 SCM q
= scm_i_mkbig ();
3061 /* Arrange for rr to initially be non-positive,
3062 because that simplifies the test to see
3063 if it is within the needed bounds. */
3066 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3067 SCM_I_BIG_MPZ (x
), yy
);
3068 scm_remember_upto_here_1 (x
);
3071 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3072 SCM_I_BIG_MPZ (q
), 1);
3078 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3079 SCM_I_BIG_MPZ (x
), -yy
);
3080 scm_remember_upto_here_1 (x
);
3081 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3084 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3085 SCM_I_BIG_MPZ (q
), 1);
3089 *qp
= scm_i_normbig (q
);
3090 *rp
= SCM_I_MAKINUM (rr
);
3094 else if (SCM_BIGP (y
))
3095 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3096 else if (SCM_REALP (y
))
3097 return scm_i_inexact_centered_divide
3098 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3099 else if (SCM_FRACTIONP (y
))
3100 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3102 return two_valued_wta_dispatch_2
3103 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3104 s_scm_centered_divide
, qp
, rp
);
3106 else if (SCM_REALP (x
))
3108 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3109 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3110 return scm_i_inexact_centered_divide
3111 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3113 return two_valued_wta_dispatch_2
3114 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3115 s_scm_centered_divide
, qp
, rp
);
3117 else if (SCM_FRACTIONP (x
))
3120 return scm_i_inexact_centered_divide
3121 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3122 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3123 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3125 return two_valued_wta_dispatch_2
3126 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3127 s_scm_centered_divide
, qp
, rp
);
3130 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3131 s_scm_centered_divide
, qp
, rp
);
3135 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3139 if (SCM_LIKELY (y
> 0))
3140 q
= floor (x
/y
+ 0.5);
3141 else if (SCM_LIKELY (y
< 0))
3142 q
= ceil (x
/y
- 0.5);
3144 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3148 *qp
= scm_from_double (q
);
3149 *rp
= scm_from_double (r
);
3152 /* Assumes that both x and y are bigints, though
3153 x might be able to fit into a fixnum. */
3155 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3159 /* Note that x might be small enough to fit into a
3160 fixnum, so we must not let it escape into the wild */
3164 /* min_r will eventually become -abs(y/2) */
3165 min_r
= scm_i_mkbig ();
3166 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3167 SCM_I_BIG_MPZ (y
), 1);
3169 /* Arrange for rr to initially be non-positive,
3170 because that simplifies the test to see
3171 if it is within the needed bounds. */
3172 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3174 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3175 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3176 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3177 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3179 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3180 SCM_I_BIG_MPZ (q
), 1);
3181 mpz_add (SCM_I_BIG_MPZ (r
),
3188 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3189 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3190 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3192 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3193 SCM_I_BIG_MPZ (q
), 1);
3194 mpz_sub (SCM_I_BIG_MPZ (r
),
3199 scm_remember_upto_here_2 (x
, y
);
3200 *qp
= scm_i_normbig (q
);
3201 *rp
= scm_i_normbig (r
);
3205 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3208 SCM xd
= scm_denominator (x
);
3209 SCM yd
= scm_denominator (y
);
3211 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3212 scm_product (scm_numerator (y
), xd
),
3214 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3217 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3218 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3219 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3221 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3223 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3224 "with ties going to the nearest even integer.\n"
3226 "(round-quotient 123 10) @result{} 12\n"
3227 "(round-quotient 123 -10) @result{} -12\n"
3228 "(round-quotient -123 10) @result{} -12\n"
3229 "(round-quotient -123 -10) @result{} 12\n"
3230 "(round-quotient 125 10) @result{} 12\n"
3231 "(round-quotient 127 10) @result{} 13\n"
3232 "(round-quotient 135 10) @result{} 14\n"
3233 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3234 "(round-quotient 16/3 -10/7) @result{} -4\n"
3236 #define FUNC_NAME s_scm_round_quotient
3238 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3240 scm_t_inum xx
= SCM_I_INUM (x
);
3241 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3243 scm_t_inum yy
= SCM_I_INUM (y
);
3244 if (SCM_UNLIKELY (yy
== 0))
3245 scm_num_overflow (s_scm_round_quotient
);
3248 scm_t_inum qq
= xx
/ yy
;
3249 scm_t_inum rr
= xx
% yy
;
3251 scm_t_inum r2
= 2 * rr
;
3253 if (SCM_LIKELY (yy
< 0))
3273 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3274 return SCM_I_MAKINUM (qq
);
3276 return scm_i_inum2big (qq
);
3279 else if (SCM_BIGP (y
))
3281 /* Pass a denormalized bignum version of x (even though it
3282 can fit in a fixnum) to scm_i_bigint_round_quotient */
3283 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3285 else if (SCM_REALP (y
))
3286 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3287 else if (SCM_FRACTIONP (y
))
3288 return scm_i_exact_rational_round_quotient (x
, y
);
3290 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3291 s_scm_round_quotient
);
3293 else if (SCM_BIGP (x
))
3295 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3297 scm_t_inum yy
= SCM_I_INUM (y
);
3298 if (SCM_UNLIKELY (yy
== 0))
3299 scm_num_overflow (s_scm_round_quotient
);
3300 else if (SCM_UNLIKELY (yy
== 1))
3304 SCM q
= scm_i_mkbig ();
3306 int needs_adjustment
;
3310 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3311 SCM_I_BIG_MPZ (x
), yy
);
3312 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3313 needs_adjustment
= (2*rr
>= yy
);
3315 needs_adjustment
= (2*rr
> yy
);
3319 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3320 SCM_I_BIG_MPZ (x
), -yy
);
3321 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3322 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3323 needs_adjustment
= (2*rr
<= yy
);
3325 needs_adjustment
= (2*rr
< yy
);
3327 scm_remember_upto_here_1 (x
);
3328 if (needs_adjustment
)
3329 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3330 return scm_i_normbig (q
);
3333 else if (SCM_BIGP (y
))
3334 return scm_i_bigint_round_quotient (x
, y
);
3335 else if (SCM_REALP (y
))
3336 return scm_i_inexact_round_quotient
3337 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3338 else if (SCM_FRACTIONP (y
))
3339 return scm_i_exact_rational_round_quotient (x
, y
);
3341 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3342 s_scm_round_quotient
);
3344 else if (SCM_REALP (x
))
3346 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3347 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3348 return scm_i_inexact_round_quotient
3349 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3351 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3352 s_scm_round_quotient
);
3354 else if (SCM_FRACTIONP (x
))
3357 return scm_i_inexact_round_quotient
3358 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3359 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3360 return scm_i_exact_rational_round_quotient (x
, y
);
3362 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3363 s_scm_round_quotient
);
3366 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3367 s_scm_round_quotient
);
3372 scm_i_inexact_round_quotient (double x
, double y
)
3374 if (SCM_UNLIKELY (y
== 0))
3375 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3377 return scm_from_double (scm_c_round (x
/ y
));
3380 /* Assumes that both x and y are bigints, though
3381 x might be able to fit into a fixnum. */
3383 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3386 int cmp
, needs_adjustment
;
3388 /* Note that x might be small enough to fit into a
3389 fixnum, so we must not let it escape into the wild */
3392 r2
= scm_i_mkbig ();
3394 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3395 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3396 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3397 scm_remember_upto_here_2 (x
, r
);
3399 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3400 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3401 needs_adjustment
= (cmp
>= 0);
3403 needs_adjustment
= (cmp
> 0);
3404 scm_remember_upto_here_2 (r2
, y
);
3406 if (needs_adjustment
)
3407 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3409 return scm_i_normbig (q
);
3413 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3415 return scm_round_quotient
3416 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3417 scm_product (scm_numerator (y
), scm_denominator (x
)));
3420 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3421 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3422 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3424 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3426 "Return the real number @var{r} such that\n"
3427 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3428 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3429 "nearest integer, with ties going to the nearest\n"
3432 "(round-remainder 123 10) @result{} 3\n"
3433 "(round-remainder 123 -10) @result{} 3\n"
3434 "(round-remainder -123 10) @result{} -3\n"
3435 "(round-remainder -123 -10) @result{} -3\n"
3436 "(round-remainder 125 10) @result{} 5\n"
3437 "(round-remainder 127 10) @result{} -3\n"
3438 "(round-remainder 135 10) @result{} -5\n"
3439 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3440 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3442 #define FUNC_NAME s_scm_round_remainder
3444 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3446 scm_t_inum xx
= SCM_I_INUM (x
);
3447 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3449 scm_t_inum yy
= SCM_I_INUM (y
);
3450 if (SCM_UNLIKELY (yy
== 0))
3451 scm_num_overflow (s_scm_round_remainder
);
3454 scm_t_inum qq
= xx
/ yy
;
3455 scm_t_inum rr
= xx
% yy
;
3457 scm_t_inum r2
= 2 * rr
;
3459 if (SCM_LIKELY (yy
< 0))
3479 return SCM_I_MAKINUM (rr
);
3482 else if (SCM_BIGP (y
))
3484 /* Pass a denormalized bignum version of x (even though it
3485 can fit in a fixnum) to scm_i_bigint_round_remainder */
3486 return scm_i_bigint_round_remainder
3487 (scm_i_long2big (xx
), y
);
3489 else if (SCM_REALP (y
))
3490 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3491 else if (SCM_FRACTIONP (y
))
3492 return scm_i_exact_rational_round_remainder (x
, y
);
3494 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3495 s_scm_round_remainder
);
3497 else if (SCM_BIGP (x
))
3499 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3501 scm_t_inum yy
= SCM_I_INUM (y
);
3502 if (SCM_UNLIKELY (yy
== 0))
3503 scm_num_overflow (s_scm_round_remainder
);
3506 SCM q
= scm_i_mkbig ();
3508 int needs_adjustment
;
3512 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3513 SCM_I_BIG_MPZ (x
), yy
);
3514 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3515 needs_adjustment
= (2*rr
>= yy
);
3517 needs_adjustment
= (2*rr
> yy
);
3521 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3522 SCM_I_BIG_MPZ (x
), -yy
);
3523 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3524 needs_adjustment
= (2*rr
<= yy
);
3526 needs_adjustment
= (2*rr
< yy
);
3528 scm_remember_upto_here_2 (x
, q
);
3529 if (needs_adjustment
)
3531 return SCM_I_MAKINUM (rr
);
3534 else if (SCM_BIGP (y
))
3535 return scm_i_bigint_round_remainder (x
, y
);
3536 else if (SCM_REALP (y
))
3537 return scm_i_inexact_round_remainder
3538 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3539 else if (SCM_FRACTIONP (y
))
3540 return scm_i_exact_rational_round_remainder (x
, y
);
3542 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3543 s_scm_round_remainder
);
3545 else if (SCM_REALP (x
))
3547 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3548 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3549 return scm_i_inexact_round_remainder
3550 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3552 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3553 s_scm_round_remainder
);
3555 else if (SCM_FRACTIONP (x
))
3558 return scm_i_inexact_round_remainder
3559 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3560 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3561 return scm_i_exact_rational_round_remainder (x
, y
);
3563 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3564 s_scm_round_remainder
);
3567 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3568 s_scm_round_remainder
);
3573 scm_i_inexact_round_remainder (double x
, double y
)
3575 /* Although it would be more efficient to use fmod here, we can't
3576 because it would in some cases produce results inconsistent with
3577 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3578 close). In particular, when x-y/2 is very close to a multiple of
3579 y, then r might be either -abs(y/2) or abs(y/2), but those two
3580 cases must correspond to different choices of q. If quotient
3581 chooses one and remainder chooses the other, it would be bad. */
3583 if (SCM_UNLIKELY (y
== 0))
3584 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3587 double q
= scm_c_round (x
/ y
);
3588 return scm_from_double (x
- q
* y
);
3592 /* Assumes that both x and y are bigints, though
3593 x might be able to fit into a fixnum. */
3595 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3598 int cmp
, needs_adjustment
;
3600 /* Note that x might be small enough to fit into a
3601 fixnum, so we must not let it escape into the wild */
3604 r2
= scm_i_mkbig ();
3606 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3607 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3608 scm_remember_upto_here_1 (x
);
3609 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3611 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3612 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3613 needs_adjustment
= (cmp
>= 0);
3615 needs_adjustment
= (cmp
> 0);
3616 scm_remember_upto_here_2 (q
, r2
);
3618 if (needs_adjustment
)
3619 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3621 scm_remember_upto_here_1 (y
);
3622 return scm_i_normbig (r
);
3626 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3628 SCM xd
= scm_denominator (x
);
3629 SCM yd
= scm_denominator (y
);
3630 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3631 scm_product (scm_numerator (y
), xd
));
3632 return scm_divide (r1
, scm_product (xd
, yd
));
3636 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3637 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3638 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3640 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3642 "Return the integer @var{q} and the real number @var{r}\n"
3643 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3644 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3645 "nearest integer, with ties going to the nearest even integer.\n"
3647 "(round/ 123 10) @result{} 12 and 3\n"
3648 "(round/ 123 -10) @result{} -12 and 3\n"
3649 "(round/ -123 10) @result{} -12 and -3\n"
3650 "(round/ -123 -10) @result{} 12 and -3\n"
3651 "(round/ 125 10) @result{} 12 and 5\n"
3652 "(round/ 127 10) @result{} 13 and -3\n"
3653 "(round/ 135 10) @result{} 14 and -5\n"
3654 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3655 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3657 #define FUNC_NAME s_scm_i_round_divide
3661 scm_round_divide(x
, y
, &q
, &r
);
3662 return scm_values (scm_list_2 (q
, r
));
3666 #define s_scm_round_divide s_scm_i_round_divide
3667 #define g_scm_round_divide g_scm_i_round_divide
3670 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3672 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3674 scm_t_inum xx
= SCM_I_INUM (x
);
3675 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3677 scm_t_inum yy
= SCM_I_INUM (y
);
3678 if (SCM_UNLIKELY (yy
== 0))
3679 scm_num_overflow (s_scm_round_divide
);
3682 scm_t_inum qq
= xx
/ yy
;
3683 scm_t_inum rr
= xx
% yy
;
3685 scm_t_inum r2
= 2 * rr
;
3687 if (SCM_LIKELY (yy
< 0))
3707 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3708 *qp
= SCM_I_MAKINUM (qq
);
3710 *qp
= scm_i_inum2big (qq
);
3711 *rp
= SCM_I_MAKINUM (rr
);
3715 else if (SCM_BIGP (y
))
3717 /* Pass a denormalized bignum version of x (even though it
3718 can fit in a fixnum) to scm_i_bigint_round_divide */
3719 return scm_i_bigint_round_divide
3720 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3722 else if (SCM_REALP (y
))
3723 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3724 else if (SCM_FRACTIONP (y
))
3725 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3727 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3728 s_scm_round_divide
, qp
, rp
);
3730 else if (SCM_BIGP (x
))
3732 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3734 scm_t_inum yy
= SCM_I_INUM (y
);
3735 if (SCM_UNLIKELY (yy
== 0))
3736 scm_num_overflow (s_scm_round_divide
);
3739 SCM q
= scm_i_mkbig ();
3741 int needs_adjustment
;
3745 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3746 SCM_I_BIG_MPZ (x
), yy
);
3747 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3748 needs_adjustment
= (2*rr
>= yy
);
3750 needs_adjustment
= (2*rr
> yy
);
3754 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3755 SCM_I_BIG_MPZ (x
), -yy
);
3756 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3757 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3758 needs_adjustment
= (2*rr
<= yy
);
3760 needs_adjustment
= (2*rr
< yy
);
3762 scm_remember_upto_here_1 (x
);
3763 if (needs_adjustment
)
3765 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3768 *qp
= scm_i_normbig (q
);
3769 *rp
= SCM_I_MAKINUM (rr
);
3773 else if (SCM_BIGP (y
))
3774 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3775 else if (SCM_REALP (y
))
3776 return scm_i_inexact_round_divide
3777 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3778 else if (SCM_FRACTIONP (y
))
3779 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3781 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3782 s_scm_round_divide
, qp
, rp
);
3784 else if (SCM_REALP (x
))
3786 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3787 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3788 return scm_i_inexact_round_divide
3789 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3791 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3792 s_scm_round_divide
, qp
, rp
);
3794 else if (SCM_FRACTIONP (x
))
3797 return scm_i_inexact_round_divide
3798 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3799 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3800 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3802 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3803 s_scm_round_divide
, qp
, rp
);
3806 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3807 s_scm_round_divide
, qp
, rp
);
3811 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3813 if (SCM_UNLIKELY (y
== 0))
3814 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3817 double q
= scm_c_round (x
/ y
);
3818 double r
= x
- q
* y
;
3819 *qp
= scm_from_double (q
);
3820 *rp
= scm_from_double (r
);
3824 /* Assumes that both x and y are bigints, though
3825 x might be able to fit into a fixnum. */
3827 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3830 int cmp
, needs_adjustment
;
3832 /* Note that x might be small enough to fit into a
3833 fixnum, so we must not let it escape into the wild */
3836 r2
= scm_i_mkbig ();
3838 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3839 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3840 scm_remember_upto_here_1 (x
);
3841 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3843 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3844 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3845 needs_adjustment
= (cmp
>= 0);
3847 needs_adjustment
= (cmp
> 0);
3849 if (needs_adjustment
)
3851 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3852 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3855 scm_remember_upto_here_2 (r2
, y
);
3856 *qp
= scm_i_normbig (q
);
3857 *rp
= scm_i_normbig (r
);
3861 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3864 SCM xd
= scm_denominator (x
);
3865 SCM yd
= scm_denominator (y
);
3867 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3868 scm_product (scm_numerator (y
), xd
),
3870 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3874 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3875 (SCM x
, SCM y
, SCM rest
),
3876 "Return the greatest common divisor of all parameter values.\n"
3877 "If called without arguments, 0 is returned.")
3878 #define FUNC_NAME s_scm_i_gcd
3880 while (!scm_is_null (rest
))
3881 { x
= scm_gcd (x
, y
);
3883 rest
= scm_cdr (rest
);
3885 return scm_gcd (x
, y
);
3889 #define s_gcd s_scm_i_gcd
3890 #define g_gcd g_scm_i_gcd
3893 scm_gcd (SCM x
, SCM y
)
3895 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
3896 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3898 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3900 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3902 scm_t_inum xx
= SCM_I_INUM (x
);
3903 scm_t_inum yy
= SCM_I_INUM (y
);
3904 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3905 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3907 if (SCM_UNLIKELY (xx
== 0))
3909 else if (SCM_UNLIKELY (yy
== 0))
3914 /* Determine a common factor 2^k */
3915 while (((u
| v
) & 1) == 0)
3921 /* Now, any factor 2^n can be eliminated */
3923 while ((u
& 1) == 0)
3926 while ((v
& 1) == 0)
3928 /* Both u and v are now odd. Subtract the smaller one
3929 from the larger one to produce an even number, remove
3930 more factors of two, and repeat. */
3936 while ((u
& 1) == 0)
3942 while ((v
& 1) == 0)
3948 return (SCM_POSFIXABLE (result
)
3949 ? SCM_I_MAKINUM (result
)
3950 : scm_i_inum2big (result
));
3952 else if (SCM_BIGP (y
))
3958 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3960 else if (SCM_BIGP (x
))
3962 if (SCM_I_INUMP (y
))
3967 yy
= SCM_I_INUM (y
);
3972 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3973 scm_remember_upto_here_1 (x
);
3974 return (SCM_POSFIXABLE (result
)
3975 ? SCM_I_MAKINUM (result
)
3976 : scm_from_unsigned_integer (result
));
3978 else if (SCM_BIGP (y
))
3980 SCM result
= scm_i_mkbig ();
3981 mpz_gcd (SCM_I_BIG_MPZ (result
),
3984 scm_remember_upto_here_2 (x
, y
);
3985 return scm_i_normbig (result
);
3988 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3991 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3994 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3995 (SCM x
, SCM y
, SCM rest
),
3996 "Return the least common multiple of the arguments.\n"
3997 "If called without arguments, 1 is returned.")
3998 #define FUNC_NAME s_scm_i_lcm
4000 while (!scm_is_null (rest
))
4001 { x
= scm_lcm (x
, y
);
4003 rest
= scm_cdr (rest
);
4005 return scm_lcm (x
, y
);
4009 #define s_lcm s_scm_i_lcm
4010 #define g_lcm g_scm_i_lcm
4013 scm_lcm (SCM n1
, SCM n2
)
4015 if (SCM_UNBNDP (n2
))
4017 if (SCM_UNBNDP (n1
))
4018 return SCM_I_MAKINUM (1L);
4019 n2
= SCM_I_MAKINUM (1L);
4022 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
4023 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4024 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
4025 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
4027 if (SCM_I_INUMP (n1
))
4029 if (SCM_I_INUMP (n2
))
4031 SCM d
= scm_gcd (n1
, n2
);
4032 if (scm_is_eq (d
, SCM_INUM0
))
4035 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4039 /* inum n1, big n2 */
4042 SCM result
= scm_i_mkbig ();
4043 scm_t_inum nn1
= SCM_I_INUM (n1
);
4044 if (nn1
== 0) return SCM_INUM0
;
4045 if (nn1
< 0) nn1
= - nn1
;
4046 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4047 scm_remember_upto_here_1 (n2
);
4055 if (SCM_I_INUMP (n2
))
4062 SCM result
= scm_i_mkbig ();
4063 mpz_lcm(SCM_I_BIG_MPZ (result
),
4065 SCM_I_BIG_MPZ (n2
));
4066 scm_remember_upto_here_2(n1
, n2
);
4067 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4073 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4078 + + + x (map digit:logand X Y)
4079 + - + x (map digit:logand X (lognot (+ -1 Y)))
4080 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4081 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4086 + + + (map digit:logior X Y)
4087 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4088 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4089 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4094 + + + (map digit:logxor X Y)
4095 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4096 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4097 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4102 + + (any digit:logand X Y)
4103 + - (any digit:logand X (lognot (+ -1 Y)))
4104 - + (any digit:logand (lognot (+ -1 X)) Y)
4109 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4110 (SCM x
, SCM y
, SCM rest
),
4111 "Return the bitwise AND of the integer arguments.\n\n"
4113 "(logand) @result{} -1\n"
4114 "(logand 7) @result{} 7\n"
4115 "(logand #b111 #b011 #b001) @result{} 1\n"
4117 #define FUNC_NAME s_scm_i_logand
4119 while (!scm_is_null (rest
))
4120 { x
= scm_logand (x
, y
);
4122 rest
= scm_cdr (rest
);
4124 return scm_logand (x
, y
);
4128 #define s_scm_logand s_scm_i_logand
4130 SCM
scm_logand (SCM n1
, SCM n2
)
4131 #define FUNC_NAME s_scm_logand
4135 if (SCM_UNBNDP (n2
))
4137 if (SCM_UNBNDP (n1
))
4138 return SCM_I_MAKINUM (-1);
4139 else if (!SCM_NUMBERP (n1
))
4140 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4141 else if (SCM_NUMBERP (n1
))
4144 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4147 if (SCM_I_INUMP (n1
))
4149 nn1
= SCM_I_INUM (n1
);
4150 if (SCM_I_INUMP (n2
))
4152 scm_t_inum nn2
= SCM_I_INUM (n2
);
4153 return SCM_I_MAKINUM (nn1
& nn2
);
4155 else if SCM_BIGP (n2
)
4161 SCM result_z
= scm_i_mkbig ();
4163 mpz_init_set_si (nn1_z
, nn1
);
4164 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4165 scm_remember_upto_here_1 (n2
);
4167 return scm_i_normbig (result_z
);
4171 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4173 else if (SCM_BIGP (n1
))
4175 if (SCM_I_INUMP (n2
))
4178 nn1
= SCM_I_INUM (n1
);
4181 else if (SCM_BIGP (n2
))
4183 SCM result_z
= scm_i_mkbig ();
4184 mpz_and (SCM_I_BIG_MPZ (result_z
),
4186 SCM_I_BIG_MPZ (n2
));
4187 scm_remember_upto_here_2 (n1
, n2
);
4188 return scm_i_normbig (result_z
);
4191 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4194 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4199 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4200 (SCM x
, SCM y
, SCM rest
),
4201 "Return the bitwise OR of the integer arguments.\n\n"
4203 "(logior) @result{} 0\n"
4204 "(logior 7) @result{} 7\n"
4205 "(logior #b000 #b001 #b011) @result{} 3\n"
4207 #define FUNC_NAME s_scm_i_logior
4209 while (!scm_is_null (rest
))
4210 { x
= scm_logior (x
, y
);
4212 rest
= scm_cdr (rest
);
4214 return scm_logior (x
, y
);
4218 #define s_scm_logior s_scm_i_logior
4220 SCM
scm_logior (SCM n1
, SCM n2
)
4221 #define FUNC_NAME s_scm_logior
4225 if (SCM_UNBNDP (n2
))
4227 if (SCM_UNBNDP (n1
))
4229 else if (SCM_NUMBERP (n1
))
4232 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4235 if (SCM_I_INUMP (n1
))
4237 nn1
= SCM_I_INUM (n1
);
4238 if (SCM_I_INUMP (n2
))
4240 long nn2
= SCM_I_INUM (n2
);
4241 return SCM_I_MAKINUM (nn1
| nn2
);
4243 else if (SCM_BIGP (n2
))
4249 SCM result_z
= scm_i_mkbig ();
4251 mpz_init_set_si (nn1_z
, nn1
);
4252 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4253 scm_remember_upto_here_1 (n2
);
4255 return scm_i_normbig (result_z
);
4259 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4261 else if (SCM_BIGP (n1
))
4263 if (SCM_I_INUMP (n2
))
4266 nn1
= SCM_I_INUM (n1
);
4269 else if (SCM_BIGP (n2
))
4271 SCM result_z
= scm_i_mkbig ();
4272 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4274 SCM_I_BIG_MPZ (n2
));
4275 scm_remember_upto_here_2 (n1
, n2
);
4276 return scm_i_normbig (result_z
);
4279 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4282 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4287 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4288 (SCM x
, SCM y
, SCM rest
),
4289 "Return the bitwise XOR of the integer arguments. A bit is\n"
4290 "set in the result if it is set in an odd number of arguments.\n"
4292 "(logxor) @result{} 0\n"
4293 "(logxor 7) @result{} 7\n"
4294 "(logxor #b000 #b001 #b011) @result{} 2\n"
4295 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4297 #define FUNC_NAME s_scm_i_logxor
4299 while (!scm_is_null (rest
))
4300 { x
= scm_logxor (x
, y
);
4302 rest
= scm_cdr (rest
);
4304 return scm_logxor (x
, y
);
4308 #define s_scm_logxor s_scm_i_logxor
4310 SCM
scm_logxor (SCM n1
, SCM n2
)
4311 #define FUNC_NAME s_scm_logxor
4315 if (SCM_UNBNDP (n2
))
4317 if (SCM_UNBNDP (n1
))
4319 else if (SCM_NUMBERP (n1
))
4322 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4325 if (SCM_I_INUMP (n1
))
4327 nn1
= SCM_I_INUM (n1
);
4328 if (SCM_I_INUMP (n2
))
4330 scm_t_inum nn2
= SCM_I_INUM (n2
);
4331 return SCM_I_MAKINUM (nn1
^ nn2
);
4333 else if (SCM_BIGP (n2
))
4337 SCM result_z
= scm_i_mkbig ();
4339 mpz_init_set_si (nn1_z
, nn1
);
4340 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4341 scm_remember_upto_here_1 (n2
);
4343 return scm_i_normbig (result_z
);
4347 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4349 else if (SCM_BIGP (n1
))
4351 if (SCM_I_INUMP (n2
))
4354 nn1
= SCM_I_INUM (n1
);
4357 else if (SCM_BIGP (n2
))
4359 SCM result_z
= scm_i_mkbig ();
4360 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4362 SCM_I_BIG_MPZ (n2
));
4363 scm_remember_upto_here_2 (n1
, n2
);
4364 return scm_i_normbig (result_z
);
4367 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4370 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4375 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4377 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4378 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4379 "without actually calculating the @code{logand}, just testing\n"
4383 "(logtest #b0100 #b1011) @result{} #f\n"
4384 "(logtest #b0100 #b0111) @result{} #t\n"
4386 #define FUNC_NAME s_scm_logtest
4390 if (SCM_I_INUMP (j
))
4392 nj
= SCM_I_INUM (j
);
4393 if (SCM_I_INUMP (k
))
4395 scm_t_inum nk
= SCM_I_INUM (k
);
4396 return scm_from_bool (nj
& nk
);
4398 else if (SCM_BIGP (k
))
4406 mpz_init_set_si (nj_z
, nj
);
4407 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4408 scm_remember_upto_here_1 (k
);
4409 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4415 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4417 else if (SCM_BIGP (j
))
4419 if (SCM_I_INUMP (k
))
4422 nj
= SCM_I_INUM (j
);
4425 else if (SCM_BIGP (k
))
4429 mpz_init (result_z
);
4433 scm_remember_upto_here_2 (j
, k
);
4434 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4435 mpz_clear (result_z
);
4439 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4442 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4447 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4449 "Test whether bit number @var{index} in @var{j} is set.\n"
4450 "@var{index} starts from 0 for the least significant bit.\n"
4453 "(logbit? 0 #b1101) @result{} #t\n"
4454 "(logbit? 1 #b1101) @result{} #f\n"
4455 "(logbit? 2 #b1101) @result{} #t\n"
4456 "(logbit? 3 #b1101) @result{} #t\n"
4457 "(logbit? 4 #b1101) @result{} #f\n"
4459 #define FUNC_NAME s_scm_logbit_p
4461 unsigned long int iindex
;
4462 iindex
= scm_to_ulong (index
);
4464 if (SCM_I_INUMP (j
))
4466 /* bits above what's in an inum follow the sign bit */
4467 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4468 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4470 else if (SCM_BIGP (j
))
4472 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4473 scm_remember_upto_here_1 (j
);
4474 return scm_from_bool (val
);
4477 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4482 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4484 "Return the integer which is the ones-complement of the integer\n"
4488 "(number->string (lognot #b10000000) 2)\n"
4489 " @result{} \"-10000001\"\n"
4490 "(number->string (lognot #b0) 2)\n"
4491 " @result{} \"-1\"\n"
4493 #define FUNC_NAME s_scm_lognot
4495 if (SCM_I_INUMP (n
)) {
4496 /* No overflow here, just need to toggle all the bits making up the inum.
4497 Enhancement: No need to strip the tag and add it back, could just xor
4498 a block of 1 bits, if that worked with the various debug versions of
4500 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4502 } else if (SCM_BIGP (n
)) {
4503 SCM result
= scm_i_mkbig ();
4504 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4505 scm_remember_upto_here_1 (n
);
4509 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4514 /* returns 0 if IN is not an integer. OUT must already be
4517 coerce_to_big (SCM in
, mpz_t out
)
4520 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4521 else if (SCM_I_INUMP (in
))
4522 mpz_set_si (out
, SCM_I_INUM (in
));
4529 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4530 (SCM n
, SCM k
, SCM m
),
4531 "Return @var{n} raised to the integer exponent\n"
4532 "@var{k}, modulo @var{m}.\n"
4535 "(modulo-expt 2 3 5)\n"
4538 #define FUNC_NAME s_scm_modulo_expt
4544 /* There are two classes of error we might encounter --
4545 1) Math errors, which we'll report by calling scm_num_overflow,
4547 2) wrong-type errors, which of course we'll report by calling
4549 We don't report those errors immediately, however; instead we do
4550 some cleanup first. These variables tell us which error (if
4551 any) we should report after cleaning up.
4553 int report_overflow
= 0;
4555 int position_of_wrong_type
= 0;
4556 SCM value_of_wrong_type
= SCM_INUM0
;
4558 SCM result
= SCM_UNDEFINED
;
4564 if (scm_is_eq (m
, SCM_INUM0
))
4566 report_overflow
= 1;
4570 if (!coerce_to_big (n
, n_tmp
))
4572 value_of_wrong_type
= n
;
4573 position_of_wrong_type
= 1;
4577 if (!coerce_to_big (k
, k_tmp
))
4579 value_of_wrong_type
= k
;
4580 position_of_wrong_type
= 2;
4584 if (!coerce_to_big (m
, m_tmp
))
4586 value_of_wrong_type
= m
;
4587 position_of_wrong_type
= 3;
4591 /* if the exponent K is negative, and we simply call mpz_powm, we
4592 will get a divide-by-zero exception when an inverse 1/n mod m
4593 doesn't exist (or is not unique). Since exceptions are hard to
4594 handle, we'll attempt the inversion "by hand" -- that way, we get
4595 a simple failure code, which is easy to handle. */
4597 if (-1 == mpz_sgn (k_tmp
))
4599 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4601 report_overflow
= 1;
4604 mpz_neg (k_tmp
, k_tmp
);
4607 result
= scm_i_mkbig ();
4608 mpz_powm (SCM_I_BIG_MPZ (result
),
4613 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4614 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4621 if (report_overflow
)
4622 scm_num_overflow (FUNC_NAME
);
4624 if (position_of_wrong_type
)
4625 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4626 value_of_wrong_type
);
4628 return scm_i_normbig (result
);
4632 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4634 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4635 "exact integer, @var{n} can be any number.\n"
4637 "Negative @var{k} is supported, and results in\n"
4638 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4639 "@math{@var{n}^0} is 1, as usual, and that\n"
4640 "includes @math{0^0} is 1.\n"
4643 "(integer-expt 2 5) @result{} 32\n"
4644 "(integer-expt -3 3) @result{} -27\n"
4645 "(integer-expt 5 -3) @result{} 1/125\n"
4646 "(integer-expt 0 0) @result{} 1\n"
4648 #define FUNC_NAME s_scm_integer_expt
4651 SCM z_i2
= SCM_BOOL_F
;
4653 SCM acc
= SCM_I_MAKINUM (1L);
4655 /* Specifically refrain from checking the type of the first argument.
4656 This allows us to exponentiate any object that can be multiplied.
4657 If we must raise to a negative power, we must also be able to
4658 take its reciprocal. */
4659 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4660 SCM_WRONG_TYPE_ARG (2, k
);
4662 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4663 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4664 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4665 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4666 /* The next check is necessary only because R6RS specifies different
4667 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4668 we simply skip this case and move on. */
4669 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4671 /* k cannot be 0 at this point, because we
4672 have already checked for that case above */
4673 if (scm_is_true (scm_positive_p (k
)))
4675 else /* return NaN for (0 ^ k) for negative k per R6RS */
4679 if (SCM_I_INUMP (k
))
4680 i2
= SCM_I_INUM (k
);
4681 else if (SCM_BIGP (k
))
4683 z_i2
= scm_i_clonebig (k
, 1);
4684 scm_remember_upto_here_1 (k
);
4688 SCM_WRONG_TYPE_ARG (2, k
);
4692 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4694 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4695 n
= scm_divide (n
, SCM_UNDEFINED
);
4699 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4703 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4705 return scm_product (acc
, n
);
4707 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4708 acc
= scm_product (acc
, n
);
4709 n
= scm_product (n
, n
);
4710 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4718 n
= scm_divide (n
, SCM_UNDEFINED
);
4725 return scm_product (acc
, n
);
4727 acc
= scm_product (acc
, n
);
4728 n
= scm_product (n
, n
);
4735 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4737 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4738 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4740 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4741 "@var{cnt} is negative it's a division, rounded towards negative\n"
4742 "infinity. (Note that this is not the same rounding as\n"
4743 "@code{quotient} does.)\n"
4745 "With @var{n} viewed as an infinite precision twos complement,\n"
4746 "@code{ash} means a left shift introducing zero bits, or a right\n"
4747 "shift dropping bits.\n"
4750 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4751 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4753 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4754 "(ash -23 -2) @result{} -6\n"
4756 #define FUNC_NAME s_scm_ash
4759 bits_to_shift
= scm_to_long (cnt
);
4761 if (SCM_I_INUMP (n
))
4763 scm_t_inum nn
= SCM_I_INUM (n
);
4765 if (bits_to_shift
> 0)
4767 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4768 overflow a non-zero fixnum. For smaller shifts we check the
4769 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4770 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4771 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4777 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4779 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4782 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4786 SCM result
= scm_i_inum2big (nn
);
4787 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4794 bits_to_shift
= -bits_to_shift
;
4795 if (bits_to_shift
>= SCM_LONG_BIT
)
4796 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4798 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4802 else if (SCM_BIGP (n
))
4806 if (bits_to_shift
== 0)
4809 result
= scm_i_mkbig ();
4810 if (bits_to_shift
>= 0)
4812 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4818 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4819 we have to allocate a bignum even if the result is going to be a
4821 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4823 return scm_i_normbig (result
);
4829 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4835 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4836 (SCM n
, SCM start
, SCM end
),
4837 "Return the integer composed of the @var{start} (inclusive)\n"
4838 "through @var{end} (exclusive) bits of @var{n}. The\n"
4839 "@var{start}th bit becomes the 0-th bit in the result.\n"
4842 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4843 " @result{} \"1010\"\n"
4844 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4845 " @result{} \"10110\"\n"
4847 #define FUNC_NAME s_scm_bit_extract
4849 unsigned long int istart
, iend
, bits
;
4850 istart
= scm_to_ulong (start
);
4851 iend
= scm_to_ulong (end
);
4852 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4854 /* how many bits to keep */
4855 bits
= iend
- istart
;
4857 if (SCM_I_INUMP (n
))
4859 scm_t_inum in
= SCM_I_INUM (n
);
4861 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4862 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4863 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4865 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4867 /* Since we emulate two's complement encoded numbers, this
4868 * special case requires us to produce a result that has
4869 * more bits than can be stored in a fixnum.
4871 SCM result
= scm_i_inum2big (in
);
4872 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4877 /* mask down to requisite bits */
4878 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4879 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4881 else if (SCM_BIGP (n
))
4886 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4890 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4891 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4892 such bits into a ulong. */
4893 result
= scm_i_mkbig ();
4894 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4895 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4896 result
= scm_i_normbig (result
);
4898 scm_remember_upto_here_1 (n
);
4902 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4907 static const char scm_logtab
[] = {
4908 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4911 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4913 "Return the number of bits in integer @var{n}. If integer is\n"
4914 "positive, the 1-bits in its binary representation are counted.\n"
4915 "If negative, the 0-bits in its two's-complement binary\n"
4916 "representation are counted. If 0, 0 is returned.\n"
4919 "(logcount #b10101010)\n"
4926 #define FUNC_NAME s_scm_logcount
4928 if (SCM_I_INUMP (n
))
4930 unsigned long c
= 0;
4931 scm_t_inum nn
= SCM_I_INUM (n
);
4936 c
+= scm_logtab
[15 & nn
];
4939 return SCM_I_MAKINUM (c
);
4941 else if (SCM_BIGP (n
))
4943 unsigned long count
;
4944 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4945 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4947 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4948 scm_remember_upto_here_1 (n
);
4949 return SCM_I_MAKINUM (count
);
4952 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4957 static const char scm_ilentab
[] = {
4958 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4962 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4964 "Return the number of bits necessary to represent @var{n}.\n"
4967 "(integer-length #b10101010)\n"
4969 "(integer-length 0)\n"
4971 "(integer-length #b1111)\n"
4974 #define FUNC_NAME s_scm_integer_length
4976 if (SCM_I_INUMP (n
))
4978 unsigned long c
= 0;
4980 scm_t_inum nn
= SCM_I_INUM (n
);
4986 l
= scm_ilentab
[15 & nn
];
4989 return SCM_I_MAKINUM (c
- 4 + l
);
4991 else if (SCM_BIGP (n
))
4993 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4994 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4995 1 too big, so check for that and adjust. */
4996 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4997 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4998 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4999 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
5001 scm_remember_upto_here_1 (n
);
5002 return SCM_I_MAKINUM (size
);
5005 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5009 /*** NUMBERS -> STRINGS ***/
5010 #define SCM_MAX_DBL_PREC 60
5011 #define SCM_MAX_DBL_RADIX 36
5013 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
5014 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
5015 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
5018 void init_dblprec(int *prec
, int radix
) {
5019 /* determine floating point precision by adding successively
5020 smaller increments to 1.0 until it is considered == 1.0 */
5021 double f
= ((double)1.0)/radix
;
5022 double fsum
= 1.0 + f
;
5027 if (++(*prec
) > SCM_MAX_DBL_PREC
)
5039 void init_fx_radix(double *fx_list
, int radix
)
5041 /* initialize a per-radix list of tolerances. When added
5042 to a number < 1.0, we can determine if we should raund
5043 up and quit converting a number to a string. */
5047 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5048 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5051 /* use this array as a way to generate a single digit */
5052 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5055 idbl2str (double f
, char *a
, int radix
)
5057 int efmt
, dpt
, d
, i
, wp
;
5059 #ifdef DBL_MIN_10_EXP
5062 #endif /* DBL_MIN_10_EXP */
5067 radix
> SCM_MAX_DBL_RADIX
)
5069 /* revert to existing behavior */
5073 wp
= scm_dblprec
[radix
-2];
5074 fx
= fx_per_radix
[radix
-2];
5078 #ifdef HAVE_COPYSIGN
5079 double sgn
= copysign (1.0, f
);
5084 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5090 strcpy (a
, "-inf.0");
5092 strcpy (a
, "+inf.0");
5097 strcpy (a
, "+nan.0");
5107 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5108 make-uniform-vector, from causing infinite loops. */
5109 /* just do the checking...if it passes, we do the conversion for our
5110 radix again below */
5117 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5125 while (f_cpy
> 10.0)
5128 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5149 if (f
+ fx
[wp
] >= radix
)
5156 /* adding 9999 makes this equivalent to abs(x) % 3 */
5157 dpt
= (exp
+ 9999) % 3;
5161 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5183 a
[ch
++] = number_chars
[d
];
5186 if (f
+ fx
[wp
] >= 1.0)
5188 a
[ch
- 1] = number_chars
[d
+1];
5200 if ((dpt
> 4) && (exp
> 6))
5202 d
= (a
[0] == '-' ? 2 : 1);
5203 for (i
= ch
++; i
> d
; i
--)
5216 if (a
[ch
- 1] == '.')
5217 a
[ch
++] = '0'; /* trailing zero */
5226 for (i
= radix
; i
<= exp
; i
*= radix
);
5227 for (i
/= radix
; i
; i
/= radix
)
5229 a
[ch
++] = number_chars
[exp
/ i
];
5238 icmplx2str (double real
, double imag
, char *str
, int radix
)
5243 i
= idbl2str (real
, str
, radix
);
5244 #ifdef HAVE_COPYSIGN
5245 sgn
= copysign (1.0, imag
);
5249 /* Don't output a '+' for negative numbers or for Inf and
5250 NaN. They will provide their own sign. */
5251 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5253 i
+= idbl2str (imag
, &str
[i
], radix
);
5259 iflo2str (SCM flt
, char *str
, int radix
)
5262 if (SCM_REALP (flt
))
5263 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5265 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5270 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5271 characters in the result.
5273 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5275 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5280 return scm_iuint2str (-num
, rad
, p
) + 1;
5283 return scm_iuint2str (num
, rad
, p
);
5286 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5287 characters in the result.
5289 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5291 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5295 scm_t_uintmax n
= num
;
5297 if (rad
< 2 || rad
> 36)
5298 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5300 for (n
/= rad
; n
> 0; n
/= rad
)
5310 p
[i
] = number_chars
[d
];
5315 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5317 "Return a string holding the external representation of the\n"
5318 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5319 "inexact, a radix of 10 will be used.")
5320 #define FUNC_NAME s_scm_number_to_string
5324 if (SCM_UNBNDP (radix
))
5327 base
= scm_to_signed_integer (radix
, 2, 36);
5329 if (SCM_I_INUMP (n
))
5331 char num_buf
[SCM_INTBUFLEN
];
5332 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5333 return scm_from_locale_stringn (num_buf
, length
);
5335 else if (SCM_BIGP (n
))
5337 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5338 size_t len
= strlen (str
);
5339 void (*freefunc
) (void *, size_t);
5341 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5342 scm_remember_upto_here_1 (n
);
5343 ret
= scm_from_latin1_stringn (str
, len
);
5344 freefunc (str
, len
+ 1);
5347 else if (SCM_FRACTIONP (n
))
5349 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5350 scm_from_locale_string ("/"),
5351 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5353 else if (SCM_INEXACTP (n
))
5355 char num_buf
[FLOBUFLEN
];
5356 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5359 SCM_WRONG_TYPE_ARG (1, n
);
5364 /* These print routines used to be stubbed here so that scm_repl.c
5365 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5368 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5370 char num_buf
[FLOBUFLEN
];
5371 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5376 scm_i_print_double (double val
, SCM port
)
5378 char num_buf
[FLOBUFLEN
];
5379 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5383 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5386 char num_buf
[FLOBUFLEN
];
5387 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5392 scm_i_print_complex (double real
, double imag
, SCM port
)
5394 char num_buf
[FLOBUFLEN
];
5395 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5399 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5402 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5403 scm_display (str
, port
);
5404 scm_remember_upto_here_1 (str
);
5409 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5411 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5412 size_t len
= strlen (str
);
5413 void (*freefunc
) (void *, size_t);
5414 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5415 scm_remember_upto_here_1 (exp
);
5416 scm_lfwrite (str
, len
, port
);
5417 freefunc (str
, len
+ 1);
5420 /*** END nums->strs ***/
5423 /*** STRINGS -> NUMBERS ***/
5425 /* The following functions implement the conversion from strings to numbers.
5426 * The implementation somehow follows the grammar for numbers as it is given
5427 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5428 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5429 * points should be noted about the implementation:
5431 * * Each function keeps a local index variable 'idx' that points at the
5432 * current position within the parsed string. The global index is only
5433 * updated if the function could parse the corresponding syntactic unit
5436 * * Similarly, the functions keep track of indicators of inexactness ('#',
5437 * '.' or exponents) using local variables ('hash_seen', 'x').
5439 * * Sequences of digits are parsed into temporary variables holding fixnums.
5440 * Only if these fixnums would overflow, the result variables are updated
5441 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5442 * the temporary variables holding the fixnums are cleared, and the process
5443 * starts over again. If for example fixnums were able to store five decimal
5444 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5445 * and the result was computed as 12345 * 100000 + 67890. In other words,
5446 * only every five digits two bignum operations were performed.
5448 * Notes on the handling of exactness specifiers:
5450 * When parsing non-real complex numbers, we apply exactness specifiers on
5451 * per-component basis, as is done in PLT Scheme. For complex numbers
5452 * written in rectangular form, exactness specifiers are applied to the
5453 * real and imaginary parts before calling scm_make_rectangular. For
5454 * complex numbers written in polar form, exactness specifiers are applied
5455 * to the magnitude and angle before calling scm_make_polar.
5457 * There are two kinds of exactness specifiers: forced and implicit. A
5458 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5459 * the entire number, and applies to both components of a complex number.
5460 * "#e" causes each component to be made exact, and "#i" causes each
5461 * component to be made inexact. If no forced exactness specifier is
5462 * present, then the exactness of each component is determined
5463 * independently by the presence or absence of a decimal point or hash mark
5464 * within that component. If a decimal point or hash mark is present, the
5465 * component is made inexact, otherwise it is made exact.
5467 * After the exactness specifiers have been applied to each component, they
5468 * are passed to either scm_make_rectangular or scm_make_polar to produce
5469 * the final result. Note that this will result in a real number if the
5470 * imaginary part, magnitude, or angle is an exact 0.
5472 * For example, (string->number "#i5.0+0i") does the equivalent of:
5474 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5477 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5479 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5481 /* Caller is responsible for checking that the return value is in range
5482 for the given radix, which should be <= 36. */
5484 char_decimal_value (scm_t_uint32 c
)
5486 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5487 that's certainly above any valid decimal, so we take advantage of
5488 that to elide some tests. */
5489 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5491 /* If that failed, try extended hexadecimals, then. Only accept ascii
5496 if (c
>= (scm_t_uint32
) 'a')
5497 d
= c
- (scm_t_uint32
)'a' + 10U;
5502 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5503 in base RADIX. Upon success, return the unsigned integer and update
5504 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5506 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5507 unsigned int radix
, enum t_exactness
*p_exactness
)
5509 unsigned int idx
= *p_idx
;
5510 unsigned int hash_seen
= 0;
5511 scm_t_bits shift
= 1;
5513 unsigned int digit_value
;
5516 size_t len
= scm_i_string_length (mem
);
5521 c
= scm_i_string_ref (mem
, idx
);
5522 digit_value
= char_decimal_value (c
);
5523 if (digit_value
>= radix
)
5527 result
= SCM_I_MAKINUM (digit_value
);
5530 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5540 digit_value
= char_decimal_value (c
);
5541 /* This check catches non-decimals in addition to out-of-range
5543 if (digit_value
>= radix
)
5548 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5550 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5552 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5559 shift
= shift
* radix
;
5560 add
= add
* radix
+ digit_value
;
5565 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5567 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5571 *p_exactness
= INEXACT
;
5577 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5578 * covers the parts of the rules that start at a potential point. The value
5579 * of the digits up to the point have been parsed by the caller and are given
5580 * in variable result. The content of *p_exactness indicates, whether a hash
5581 * has already been seen in the digits before the point.
5584 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5587 mem2decimal_from_point (SCM result
, SCM mem
,
5588 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5590 unsigned int idx
= *p_idx
;
5591 enum t_exactness x
= *p_exactness
;
5592 size_t len
= scm_i_string_length (mem
);
5597 if (scm_i_string_ref (mem
, idx
) == '.')
5599 scm_t_bits shift
= 1;
5601 unsigned int digit_value
;
5602 SCM big_shift
= SCM_INUM1
;
5607 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5608 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5613 digit_value
= DIGIT2UINT (c
);
5624 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5626 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5627 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5629 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5637 add
= add
* 10 + digit_value
;
5643 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5644 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5645 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5648 result
= scm_divide (result
, big_shift
);
5650 /* We've seen a decimal point, thus the value is implicitly inexact. */
5662 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5664 switch (scm_i_string_ref (mem
, idx
))
5676 c
= scm_i_string_ref (mem
, idx
);
5684 c
= scm_i_string_ref (mem
, idx
);
5693 c
= scm_i_string_ref (mem
, idx
);
5698 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5702 exponent
= DIGIT2UINT (c
);
5705 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5706 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5709 if (exponent
<= SCM_MAXEXP
)
5710 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5716 if (exponent
> SCM_MAXEXP
)
5718 size_t exp_len
= idx
- start
;
5719 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5720 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5721 scm_out_of_range ("string->number", exp_num
);
5724 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5726 result
= scm_product (result
, e
);
5728 result
= scm_divide (result
, e
);
5730 /* We've seen an exponent, thus the value is implicitly inexact. */
5748 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5751 mem2ureal (SCM mem
, unsigned int *p_idx
,
5752 unsigned int radix
, enum t_exactness forced_x
)
5754 unsigned int idx
= *p_idx
;
5756 size_t len
= scm_i_string_length (mem
);
5758 /* Start off believing that the number will be exact. This changes
5759 to INEXACT if we see a decimal point or a hash. */
5760 enum t_exactness implicit_x
= EXACT
;
5765 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5771 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5773 /* Cobble up the fractional part. We might want to set the
5774 NaN's mantissa from it. */
5776 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
), SCM_INUM0
))
5778 #if SCM_ENABLE_DEPRECATED == 1
5779 scm_c_issue_deprecation_warning
5780 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5790 if (scm_i_string_ref (mem
, idx
) == '.')
5794 else if (idx
+ 1 == len
)
5796 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5799 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5800 p_idx
, &implicit_x
);
5806 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5807 if (scm_is_false (uinteger
))
5812 else if (scm_i_string_ref (mem
, idx
) == '/')
5820 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5821 if (scm_is_false (divisor
))
5824 /* both are int/big here, I assume */
5825 result
= scm_i_make_ratio (uinteger
, divisor
);
5827 else if (radix
== 10)
5829 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5830 if (scm_is_false (result
))
5842 if (SCM_INEXACTP (result
))
5843 return scm_inexact_to_exact (result
);
5847 if (SCM_INEXACTP (result
))
5850 return scm_exact_to_inexact (result
);
5852 if (implicit_x
== INEXACT
)
5854 if (SCM_INEXACTP (result
))
5857 return scm_exact_to_inexact (result
);
5863 /* We should never get here */
5864 scm_syserror ("mem2ureal");
5868 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5871 mem2complex (SCM mem
, unsigned int idx
,
5872 unsigned int radix
, enum t_exactness forced_x
)
5877 size_t len
= scm_i_string_length (mem
);
5882 c
= scm_i_string_ref (mem
, idx
);
5897 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5898 if (scm_is_false (ureal
))
5900 /* input must be either +i or -i */
5905 if (scm_i_string_ref (mem
, idx
) == 'i'
5906 || scm_i_string_ref (mem
, idx
) == 'I')
5912 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5919 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5920 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5925 c
= scm_i_string_ref (mem
, idx
);
5929 /* either +<ureal>i or -<ureal>i */
5936 return scm_make_rectangular (SCM_INUM0
, ureal
);
5939 /* polar input: <real>@<real>. */
5950 c
= scm_i_string_ref (mem
, idx
);
5968 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5969 if (scm_is_false (angle
))
5974 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5975 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5977 result
= scm_make_polar (ureal
, angle
);
5982 /* expecting input matching <real>[+-]<ureal>?i */
5989 int sign
= (c
== '+') ? 1 : -1;
5990 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5992 if (scm_is_false (imag
))
5993 imag
= SCM_I_MAKINUM (sign
);
5994 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5995 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5999 if (scm_i_string_ref (mem
, idx
) != 'i'
6000 && scm_i_string_ref (mem
, idx
) != 'I')
6007 return scm_make_rectangular (ureal
, imag
);
6016 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6018 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6021 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6023 unsigned int idx
= 0;
6024 unsigned int radix
= NO_RADIX
;
6025 enum t_exactness forced_x
= NO_EXACTNESS
;
6026 size_t len
= scm_i_string_length (mem
);
6028 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6029 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6031 switch (scm_i_string_ref (mem
, idx
+ 1))
6034 if (radix
!= NO_RADIX
)
6039 if (radix
!= NO_RADIX
)
6044 if (forced_x
!= NO_EXACTNESS
)
6049 if (forced_x
!= NO_EXACTNESS
)
6054 if (radix
!= NO_RADIX
)
6059 if (radix
!= NO_RADIX
)
6069 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6070 if (radix
== NO_RADIX
)
6071 radix
= default_radix
;
6073 return mem2complex (mem
, idx
, radix
, forced_x
);
6077 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6078 unsigned int default_radix
)
6080 SCM str
= scm_from_locale_stringn (mem
, len
);
6082 return scm_i_string_to_number (str
, default_radix
);
6086 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6087 (SCM string
, SCM radix
),
6088 "Return a number of the maximally precise representation\n"
6089 "expressed by the given @var{string}. @var{radix} must be an\n"
6090 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6091 "is a default radix that may be overridden by an explicit radix\n"
6092 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6093 "supplied, then the default radix is 10. If string is not a\n"
6094 "syntactically valid notation for a number, then\n"
6095 "@code{string->number} returns @code{#f}.")
6096 #define FUNC_NAME s_scm_string_to_number
6100 SCM_VALIDATE_STRING (1, string
);
6102 if (SCM_UNBNDP (radix
))
6105 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6107 answer
= scm_i_string_to_number (string
, base
);
6108 scm_remember_upto_here_1 (string
);
6114 /*** END strs->nums ***/
6117 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6119 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6121 #define FUNC_NAME s_scm_number_p
6123 return scm_from_bool (SCM_NUMBERP (x
));
6127 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6129 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6130 "otherwise. Note that the sets of real, rational and integer\n"
6131 "values form subsets of the set of complex numbers, i. e. the\n"
6132 "predicate will also be fulfilled if @var{x} is a real,\n"
6133 "rational or integer number.")
6134 #define FUNC_NAME s_scm_complex_p
6136 /* all numbers are complex. */
6137 return scm_number_p (x
);
6141 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6143 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6144 "otherwise. Note that the set of integer values forms a subset of\n"
6145 "the set of real numbers, i. e. the predicate will also be\n"
6146 "fulfilled if @var{x} is an integer number.")
6147 #define FUNC_NAME s_scm_real_p
6149 return scm_from_bool
6150 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6154 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6156 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6157 "otherwise. Note that the set of integer values forms a subset of\n"
6158 "the set of rational numbers, i. e. the predicate will also be\n"
6159 "fulfilled if @var{x} is an integer number.")
6160 #define FUNC_NAME s_scm_rational_p
6162 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6164 else if (SCM_REALP (x
))
6165 /* due to their limited precision, finite floating point numbers are
6166 rational as well. (finite means neither infinity nor a NaN) */
6167 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6173 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6175 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6177 #define FUNC_NAME s_scm_integer_p
6179 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6181 else if (SCM_REALP (x
))
6183 double val
= SCM_REAL_VALUE (x
);
6184 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6192 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6193 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6194 (SCM x
, SCM y
, SCM rest
),
6195 "Return @code{#t} if all parameters are numerically equal.")
6196 #define FUNC_NAME s_scm_i_num_eq_p
6198 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6200 while (!scm_is_null (rest
))
6202 if (scm_is_false (scm_num_eq_p (x
, y
)))
6206 rest
= scm_cdr (rest
);
6208 return scm_num_eq_p (x
, y
);
6212 scm_num_eq_p (SCM x
, SCM y
)
6215 if (SCM_I_INUMP (x
))
6217 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6218 if (SCM_I_INUMP (y
))
6220 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6221 return scm_from_bool (xx
== yy
);
6223 else if (SCM_BIGP (y
))
6225 else if (SCM_REALP (y
))
6227 /* On a 32-bit system an inum fits a double, we can cast the inum
6228 to a double and compare.
6230 But on a 64-bit system an inum is bigger than a double and
6231 casting it to a double (call that dxx) will round. dxx is at
6232 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6233 an integer and fits a long. So we cast yy to a long and
6234 compare with plain xx.
6236 An alternative (for any size system actually) would be to check
6237 yy is an integer (with floor) and is in range of an inum
6238 (compare against appropriate powers of 2) then test
6239 xx==(scm_t_signed_bits)yy. It's just a matter of which
6240 casts/comparisons might be fastest or easiest for the cpu. */
6242 double yy
= SCM_REAL_VALUE (y
);
6243 return scm_from_bool ((double) xx
== yy
6244 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6245 || xx
== (scm_t_signed_bits
) yy
));
6247 else if (SCM_COMPLEXP (y
))
6248 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6249 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6250 else if (SCM_FRACTIONP (y
))
6253 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6255 else if (SCM_BIGP (x
))
6257 if (SCM_I_INUMP (y
))
6259 else if (SCM_BIGP (y
))
6261 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6262 scm_remember_upto_here_2 (x
, y
);
6263 return scm_from_bool (0 == cmp
);
6265 else if (SCM_REALP (y
))
6268 if (isnan (SCM_REAL_VALUE (y
)))
6270 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6271 scm_remember_upto_here_1 (x
);
6272 return scm_from_bool (0 == cmp
);
6274 else if (SCM_COMPLEXP (y
))
6277 if (0.0 != SCM_COMPLEX_IMAG (y
))
6279 if (isnan (SCM_COMPLEX_REAL (y
)))
6281 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6282 scm_remember_upto_here_1 (x
);
6283 return scm_from_bool (0 == cmp
);
6285 else if (SCM_FRACTIONP (y
))
6288 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6290 else if (SCM_REALP (x
))
6292 double xx
= SCM_REAL_VALUE (x
);
6293 if (SCM_I_INUMP (y
))
6295 /* see comments with inum/real above */
6296 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6297 return scm_from_bool (xx
== (double) yy
6298 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6299 || (scm_t_signed_bits
) xx
== yy
));
6301 else if (SCM_BIGP (y
))
6304 if (isnan (SCM_REAL_VALUE (x
)))
6306 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6307 scm_remember_upto_here_1 (y
);
6308 return scm_from_bool (0 == cmp
);
6310 else if (SCM_REALP (y
))
6311 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6312 else if (SCM_COMPLEXP (y
))
6313 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6314 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6315 else if (SCM_FRACTIONP (y
))
6317 double xx
= SCM_REAL_VALUE (x
);
6321 return scm_from_bool (xx
< 0.0);
6322 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6326 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6328 else if (SCM_COMPLEXP (x
))
6330 if (SCM_I_INUMP (y
))
6331 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6332 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6333 else if (SCM_BIGP (y
))
6336 if (0.0 != SCM_COMPLEX_IMAG (x
))
6338 if (isnan (SCM_COMPLEX_REAL (x
)))
6340 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6341 scm_remember_upto_here_1 (y
);
6342 return scm_from_bool (0 == cmp
);
6344 else if (SCM_REALP (y
))
6345 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6346 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6347 else if (SCM_COMPLEXP (y
))
6348 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6349 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6350 else if (SCM_FRACTIONP (y
))
6353 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6355 xx
= SCM_COMPLEX_REAL (x
);
6359 return scm_from_bool (xx
< 0.0);
6360 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6364 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6366 else if (SCM_FRACTIONP (x
))
6368 if (SCM_I_INUMP (y
))
6370 else if (SCM_BIGP (y
))
6372 else if (SCM_REALP (y
))
6374 double yy
= SCM_REAL_VALUE (y
);
6378 return scm_from_bool (0.0 < yy
);
6379 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6382 else if (SCM_COMPLEXP (y
))
6385 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6387 yy
= SCM_COMPLEX_REAL (y
);
6391 return scm_from_bool (0.0 < yy
);
6392 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6395 else if (SCM_FRACTIONP (y
))
6396 return scm_i_fraction_equalp (x
, y
);
6398 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6401 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6405 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6406 done are good for inums, but for bignums an answer can almost always be
6407 had by just examining a few high bits of the operands, as done by GMP in
6408 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6409 of the float exponent to take into account. */
6411 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6412 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6413 (SCM x
, SCM y
, SCM rest
),
6414 "Return @code{#t} if the list of parameters is monotonically\n"
6416 #define FUNC_NAME s_scm_i_num_less_p
6418 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6420 while (!scm_is_null (rest
))
6422 if (scm_is_false (scm_less_p (x
, y
)))
6426 rest
= scm_cdr (rest
);
6428 return scm_less_p (x
, y
);
6432 scm_less_p (SCM x
, SCM y
)
6435 if (SCM_I_INUMP (x
))
6437 scm_t_inum xx
= SCM_I_INUM (x
);
6438 if (SCM_I_INUMP (y
))
6440 scm_t_inum yy
= SCM_I_INUM (y
);
6441 return scm_from_bool (xx
< yy
);
6443 else if (SCM_BIGP (y
))
6445 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6446 scm_remember_upto_here_1 (y
);
6447 return scm_from_bool (sgn
> 0);
6449 else if (SCM_REALP (y
))
6450 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6451 else if (SCM_FRACTIONP (y
))
6453 /* "x < a/b" becomes "x*b < a" */
6455 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6456 y
= SCM_FRACTION_NUMERATOR (y
);
6460 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6462 else if (SCM_BIGP (x
))
6464 if (SCM_I_INUMP (y
))
6466 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6467 scm_remember_upto_here_1 (x
);
6468 return scm_from_bool (sgn
< 0);
6470 else if (SCM_BIGP (y
))
6472 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6473 scm_remember_upto_here_2 (x
, y
);
6474 return scm_from_bool (cmp
< 0);
6476 else if (SCM_REALP (y
))
6479 if (isnan (SCM_REAL_VALUE (y
)))
6481 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6482 scm_remember_upto_here_1 (x
);
6483 return scm_from_bool (cmp
< 0);
6485 else if (SCM_FRACTIONP (y
))
6488 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6490 else if (SCM_REALP (x
))
6492 if (SCM_I_INUMP (y
))
6493 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6494 else if (SCM_BIGP (y
))
6497 if (isnan (SCM_REAL_VALUE (x
)))
6499 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6500 scm_remember_upto_here_1 (y
);
6501 return scm_from_bool (cmp
> 0);
6503 else if (SCM_REALP (y
))
6504 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6505 else if (SCM_FRACTIONP (y
))
6507 double xx
= SCM_REAL_VALUE (x
);
6511 return scm_from_bool (xx
< 0.0);
6512 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6516 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6518 else if (SCM_FRACTIONP (x
))
6520 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6522 /* "a/b < y" becomes "a < y*b" */
6523 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6524 x
= SCM_FRACTION_NUMERATOR (x
);
6527 else if (SCM_REALP (y
))
6529 double yy
= SCM_REAL_VALUE (y
);
6533 return scm_from_bool (0.0 < yy
);
6534 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6537 else if (SCM_FRACTIONP (y
))
6539 /* "a/b < c/d" becomes "a*d < c*b" */
6540 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6541 SCM_FRACTION_DENOMINATOR (y
));
6542 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6543 SCM_FRACTION_DENOMINATOR (x
));
6549 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6552 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6556 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6557 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6558 (SCM x
, SCM y
, SCM rest
),
6559 "Return @code{#t} if the list of parameters is monotonically\n"
6561 #define FUNC_NAME s_scm_i_num_gr_p
6563 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6565 while (!scm_is_null (rest
))
6567 if (scm_is_false (scm_gr_p (x
, y
)))
6571 rest
= scm_cdr (rest
);
6573 return scm_gr_p (x
, y
);
6576 #define FUNC_NAME s_scm_i_num_gr_p
6578 scm_gr_p (SCM x
, SCM y
)
6580 if (!SCM_NUMBERP (x
))
6581 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6582 else if (!SCM_NUMBERP (y
))
6583 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6585 return scm_less_p (y
, x
);
6590 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6591 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6592 (SCM x
, SCM y
, SCM rest
),
6593 "Return @code{#t} if the list of parameters is monotonically\n"
6595 #define FUNC_NAME s_scm_i_num_leq_p
6597 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6599 while (!scm_is_null (rest
))
6601 if (scm_is_false (scm_leq_p (x
, y
)))
6605 rest
= scm_cdr (rest
);
6607 return scm_leq_p (x
, y
);
6610 #define FUNC_NAME s_scm_i_num_leq_p
6612 scm_leq_p (SCM x
, SCM y
)
6614 if (!SCM_NUMBERP (x
))
6615 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6616 else if (!SCM_NUMBERP (y
))
6617 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6618 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6621 return scm_not (scm_less_p (y
, x
));
6626 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6627 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6628 (SCM x
, SCM y
, SCM rest
),
6629 "Return @code{#t} if the list of parameters is monotonically\n"
6631 #define FUNC_NAME s_scm_i_num_geq_p
6633 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6635 while (!scm_is_null (rest
))
6637 if (scm_is_false (scm_geq_p (x
, y
)))
6641 rest
= scm_cdr (rest
);
6643 return scm_geq_p (x
, y
);
6646 #define FUNC_NAME s_scm_i_num_geq_p
6648 scm_geq_p (SCM x
, SCM y
)
6650 if (!SCM_NUMBERP (x
))
6651 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6652 else if (!SCM_NUMBERP (y
))
6653 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6654 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6657 return scm_not (scm_less_p (x
, y
));
6662 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6664 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6666 #define FUNC_NAME s_scm_zero_p
6668 if (SCM_I_INUMP (z
))
6669 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6670 else if (SCM_BIGP (z
))
6672 else if (SCM_REALP (z
))
6673 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6674 else if (SCM_COMPLEXP (z
))
6675 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6676 && SCM_COMPLEX_IMAG (z
) == 0.0);
6677 else if (SCM_FRACTIONP (z
))
6680 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6685 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6687 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6689 #define FUNC_NAME s_scm_positive_p
6691 if (SCM_I_INUMP (x
))
6692 return scm_from_bool (SCM_I_INUM (x
) > 0);
6693 else if (SCM_BIGP (x
))
6695 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6696 scm_remember_upto_here_1 (x
);
6697 return scm_from_bool (sgn
> 0);
6699 else if (SCM_REALP (x
))
6700 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6701 else if (SCM_FRACTIONP (x
))
6702 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6704 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6709 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6711 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6713 #define FUNC_NAME s_scm_negative_p
6715 if (SCM_I_INUMP (x
))
6716 return scm_from_bool (SCM_I_INUM (x
) < 0);
6717 else if (SCM_BIGP (x
))
6719 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6720 scm_remember_upto_here_1 (x
);
6721 return scm_from_bool (sgn
< 0);
6723 else if (SCM_REALP (x
))
6724 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6725 else if (SCM_FRACTIONP (x
))
6726 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6728 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6733 /* scm_min and scm_max return an inexact when either argument is inexact, as
6734 required by r5rs. On that basis, for exact/inexact combinations the
6735 exact is converted to inexact to compare and possibly return. This is
6736 unlike scm_less_p above which takes some trouble to preserve all bits in
6737 its test, such trouble is not required for min and max. */
6739 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6740 (SCM x
, SCM y
, SCM rest
),
6741 "Return the maximum of all parameter values.")
6742 #define FUNC_NAME s_scm_i_max
6744 while (!scm_is_null (rest
))
6745 { x
= scm_max (x
, y
);
6747 rest
= scm_cdr (rest
);
6749 return scm_max (x
, y
);
6753 #define s_max s_scm_i_max
6754 #define g_max g_scm_i_max
6757 scm_max (SCM x
, SCM y
)
6762 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6763 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6766 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6769 if (SCM_I_INUMP (x
))
6771 scm_t_inum xx
= SCM_I_INUM (x
);
6772 if (SCM_I_INUMP (y
))
6774 scm_t_inum yy
= SCM_I_INUM (y
);
6775 return (xx
< yy
) ? y
: x
;
6777 else if (SCM_BIGP (y
))
6779 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6780 scm_remember_upto_here_1 (y
);
6781 return (sgn
< 0) ? x
: y
;
6783 else if (SCM_REALP (y
))
6786 double yyd
= SCM_REAL_VALUE (y
);
6789 return scm_from_double (xxd
);
6790 /* If y is a NaN, then "==" is false and we return the NaN */
6791 else if (SCM_LIKELY (!(xxd
== yyd
)))
6793 /* Handle signed zeroes properly */
6799 else if (SCM_FRACTIONP (y
))
6802 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6805 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6807 else if (SCM_BIGP (x
))
6809 if (SCM_I_INUMP (y
))
6811 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6812 scm_remember_upto_here_1 (x
);
6813 return (sgn
< 0) ? y
: x
;
6815 else if (SCM_BIGP (y
))
6817 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6818 scm_remember_upto_here_2 (x
, y
);
6819 return (cmp
> 0) ? x
: y
;
6821 else if (SCM_REALP (y
))
6823 /* if y==NaN then xx>yy is false, so we return the NaN y */
6826 xx
= scm_i_big2dbl (x
);
6827 yy
= SCM_REAL_VALUE (y
);
6828 return (xx
> yy
? scm_from_double (xx
) : y
);
6830 else if (SCM_FRACTIONP (y
))
6835 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6837 else if (SCM_REALP (x
))
6839 if (SCM_I_INUMP (y
))
6841 scm_t_inum yy
= SCM_I_INUM (y
);
6842 double xxd
= SCM_REAL_VALUE (x
);
6846 return scm_from_double (yyd
);
6847 /* If x is a NaN, then "==" is false and we return the NaN */
6848 else if (SCM_LIKELY (!(xxd
== yyd
)))
6850 /* Handle signed zeroes properly */
6856 else if (SCM_BIGP (y
))
6861 else if (SCM_REALP (y
))
6863 double xx
= SCM_REAL_VALUE (x
);
6864 double yy
= SCM_REAL_VALUE (y
);
6866 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6869 else if (SCM_LIKELY (xx
< yy
))
6871 /* If neither (xx > yy) nor (xx < yy), then
6872 either they're equal or one is a NaN */
6873 else if (SCM_UNLIKELY (isnan (xx
)))
6874 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6875 else if (SCM_UNLIKELY (isnan (yy
)))
6876 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6877 /* xx == yy, but handle signed zeroes properly */
6878 else if (double_is_non_negative_zero (yy
))
6883 else if (SCM_FRACTIONP (y
))
6885 double yy
= scm_i_fraction2double (y
);
6886 double xx
= SCM_REAL_VALUE (x
);
6887 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6890 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6892 else if (SCM_FRACTIONP (x
))
6894 if (SCM_I_INUMP (y
))
6898 else if (SCM_BIGP (y
))
6902 else if (SCM_REALP (y
))
6904 double xx
= scm_i_fraction2double (x
);
6905 /* if y==NaN then ">" is false, so we return the NaN y */
6906 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6908 else if (SCM_FRACTIONP (y
))
6913 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6916 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6920 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6921 (SCM x
, SCM y
, SCM rest
),
6922 "Return the minimum of all parameter values.")
6923 #define FUNC_NAME s_scm_i_min
6925 while (!scm_is_null (rest
))
6926 { x
= scm_min (x
, y
);
6928 rest
= scm_cdr (rest
);
6930 return scm_min (x
, y
);
6934 #define s_min s_scm_i_min
6935 #define g_min g_scm_i_min
6938 scm_min (SCM x
, SCM y
)
6943 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
6944 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6947 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
6950 if (SCM_I_INUMP (x
))
6952 scm_t_inum xx
= SCM_I_INUM (x
);
6953 if (SCM_I_INUMP (y
))
6955 scm_t_inum yy
= SCM_I_INUM (y
);
6956 return (xx
< yy
) ? x
: y
;
6958 else if (SCM_BIGP (y
))
6960 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6961 scm_remember_upto_here_1 (y
);
6962 return (sgn
< 0) ? y
: x
;
6964 else if (SCM_REALP (y
))
6967 /* if y==NaN then "<" is false and we return NaN */
6968 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6970 else if (SCM_FRACTIONP (y
))
6973 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6976 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6978 else if (SCM_BIGP (x
))
6980 if (SCM_I_INUMP (y
))
6982 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6983 scm_remember_upto_here_1 (x
);
6984 return (sgn
< 0) ? x
: y
;
6986 else if (SCM_BIGP (y
))
6988 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6989 scm_remember_upto_here_2 (x
, y
);
6990 return (cmp
> 0) ? y
: x
;
6992 else if (SCM_REALP (y
))
6994 /* if y==NaN then xx<yy is false, so we return the NaN y */
6997 xx
= scm_i_big2dbl (x
);
6998 yy
= SCM_REAL_VALUE (y
);
6999 return (xx
< yy
? scm_from_double (xx
) : y
);
7001 else if (SCM_FRACTIONP (y
))
7006 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7008 else if (SCM_REALP (x
))
7010 if (SCM_I_INUMP (y
))
7012 double z
= SCM_I_INUM (y
);
7013 /* if x==NaN then "<" is false and we return NaN */
7014 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7016 else if (SCM_BIGP (y
))
7021 else if (SCM_REALP (y
))
7023 double xx
= SCM_REAL_VALUE (x
);
7024 double yy
= SCM_REAL_VALUE (y
);
7026 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7029 else if (SCM_LIKELY (xx
> yy
))
7031 /* If neither (xx < yy) nor (xx > yy), then
7032 either they're equal or one is a NaN */
7033 else if (SCM_UNLIKELY (isnan (xx
)))
7034 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7035 else if (SCM_UNLIKELY (isnan (yy
)))
7036 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7037 /* xx == yy, but handle signed zeroes properly */
7038 else if (double_is_non_negative_zero (xx
))
7043 else if (SCM_FRACTIONP (y
))
7045 double yy
= scm_i_fraction2double (y
);
7046 double xx
= SCM_REAL_VALUE (x
);
7047 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7050 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7052 else if (SCM_FRACTIONP (x
))
7054 if (SCM_I_INUMP (y
))
7058 else if (SCM_BIGP (y
))
7062 else if (SCM_REALP (y
))
7064 double xx
= scm_i_fraction2double (x
);
7065 /* if y==NaN then "<" is false, so we return the NaN y */
7066 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7068 else if (SCM_FRACTIONP (y
))
7073 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7076 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7080 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7081 (SCM x
, SCM y
, SCM rest
),
7082 "Return the sum of all parameter values. Return 0 if called without\n"
7084 #define FUNC_NAME s_scm_i_sum
7086 while (!scm_is_null (rest
))
7087 { x
= scm_sum (x
, y
);
7089 rest
= scm_cdr (rest
);
7091 return scm_sum (x
, y
);
7095 #define s_sum s_scm_i_sum
7096 #define g_sum g_scm_i_sum
7099 scm_sum (SCM x
, SCM y
)
7101 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7103 if (SCM_NUMBERP (x
)) return x
;
7104 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7105 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7108 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7110 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7112 scm_t_inum xx
= SCM_I_INUM (x
);
7113 scm_t_inum yy
= SCM_I_INUM (y
);
7114 scm_t_inum z
= xx
+ yy
;
7115 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7117 else if (SCM_BIGP (y
))
7122 else if (SCM_REALP (y
))
7124 scm_t_inum xx
= SCM_I_INUM (x
);
7125 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7127 else if (SCM_COMPLEXP (y
))
7129 scm_t_inum xx
= SCM_I_INUM (x
);
7130 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7131 SCM_COMPLEX_IMAG (y
));
7133 else if (SCM_FRACTIONP (y
))
7134 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7135 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7136 SCM_FRACTION_DENOMINATOR (y
));
7138 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7139 } else if (SCM_BIGP (x
))
7141 if (SCM_I_INUMP (y
))
7146 inum
= SCM_I_INUM (y
);
7149 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7152 SCM result
= scm_i_mkbig ();
7153 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7154 scm_remember_upto_here_1 (x
);
7155 /* we know the result will have to be a bignum */
7158 return scm_i_normbig (result
);
7162 SCM result
= scm_i_mkbig ();
7163 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7164 scm_remember_upto_here_1 (x
);
7165 /* we know the result will have to be a bignum */
7168 return scm_i_normbig (result
);
7171 else if (SCM_BIGP (y
))
7173 SCM result
= scm_i_mkbig ();
7174 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7175 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7176 mpz_add (SCM_I_BIG_MPZ (result
),
7179 scm_remember_upto_here_2 (x
, y
);
7180 /* we know the result will have to be a bignum */
7183 return scm_i_normbig (result
);
7185 else if (SCM_REALP (y
))
7187 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7188 scm_remember_upto_here_1 (x
);
7189 return scm_from_double (result
);
7191 else if (SCM_COMPLEXP (y
))
7193 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7194 + SCM_COMPLEX_REAL (y
));
7195 scm_remember_upto_here_1 (x
);
7196 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7198 else if (SCM_FRACTIONP (y
))
7199 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7200 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7201 SCM_FRACTION_DENOMINATOR (y
));
7203 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7205 else if (SCM_REALP (x
))
7207 if (SCM_I_INUMP (y
))
7208 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7209 else if (SCM_BIGP (y
))
7211 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7212 scm_remember_upto_here_1 (y
);
7213 return scm_from_double (result
);
7215 else if (SCM_REALP (y
))
7216 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7217 else if (SCM_COMPLEXP (y
))
7218 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7219 SCM_COMPLEX_IMAG (y
));
7220 else if (SCM_FRACTIONP (y
))
7221 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7223 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7225 else if (SCM_COMPLEXP (x
))
7227 if (SCM_I_INUMP (y
))
7228 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7229 SCM_COMPLEX_IMAG (x
));
7230 else if (SCM_BIGP (y
))
7232 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7233 + SCM_COMPLEX_REAL (x
));
7234 scm_remember_upto_here_1 (y
);
7235 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7237 else if (SCM_REALP (y
))
7238 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7239 SCM_COMPLEX_IMAG (x
));
7240 else if (SCM_COMPLEXP (y
))
7241 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7242 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7243 else if (SCM_FRACTIONP (y
))
7244 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7245 SCM_COMPLEX_IMAG (x
));
7247 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7249 else if (SCM_FRACTIONP (x
))
7251 if (SCM_I_INUMP (y
))
7252 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7253 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7254 SCM_FRACTION_DENOMINATOR (x
));
7255 else if (SCM_BIGP (y
))
7256 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7257 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7258 SCM_FRACTION_DENOMINATOR (x
));
7259 else if (SCM_REALP (y
))
7260 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7261 else if (SCM_COMPLEXP (y
))
7262 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7263 SCM_COMPLEX_IMAG (y
));
7264 else if (SCM_FRACTIONP (y
))
7265 /* a/b + c/d = (ad + bc) / bd */
7266 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7267 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7268 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7270 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7273 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7277 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7279 "Return @math{@var{x}+1}.")
7280 #define FUNC_NAME s_scm_oneplus
7282 return scm_sum (x
, SCM_INUM1
);
7287 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7288 (SCM x
, SCM y
, SCM rest
),
7289 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7290 "the sum of all but the first argument are subtracted from the first\n"
7292 #define FUNC_NAME s_scm_i_difference
7294 while (!scm_is_null (rest
))
7295 { x
= scm_difference (x
, y
);
7297 rest
= scm_cdr (rest
);
7299 return scm_difference (x
, y
);
7303 #define s_difference s_scm_i_difference
7304 #define g_difference g_scm_i_difference
7307 scm_difference (SCM x
, SCM y
)
7308 #define FUNC_NAME s_difference
7310 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7313 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7315 if (SCM_I_INUMP (x
))
7317 scm_t_inum xx
= -SCM_I_INUM (x
);
7318 if (SCM_FIXABLE (xx
))
7319 return SCM_I_MAKINUM (xx
);
7321 return scm_i_inum2big (xx
);
7323 else if (SCM_BIGP (x
))
7324 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7325 bignum, but negating that gives a fixnum. */
7326 return scm_i_normbig (scm_i_clonebig (x
, 0));
7327 else if (SCM_REALP (x
))
7328 return scm_from_double (-SCM_REAL_VALUE (x
));
7329 else if (SCM_COMPLEXP (x
))
7330 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7331 -SCM_COMPLEX_IMAG (x
));
7332 else if (SCM_FRACTIONP (x
))
7333 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7334 SCM_FRACTION_DENOMINATOR (x
));
7336 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7339 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7341 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7343 scm_t_inum xx
= SCM_I_INUM (x
);
7344 scm_t_inum yy
= SCM_I_INUM (y
);
7345 scm_t_inum z
= xx
- yy
;
7346 if (SCM_FIXABLE (z
))
7347 return SCM_I_MAKINUM (z
);
7349 return scm_i_inum2big (z
);
7351 else if (SCM_BIGP (y
))
7353 /* inum-x - big-y */
7354 scm_t_inum xx
= SCM_I_INUM (x
);
7358 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7359 bignum, but negating that gives a fixnum. */
7360 return scm_i_normbig (scm_i_clonebig (y
, 0));
7364 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7365 SCM result
= scm_i_mkbig ();
7368 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7371 /* x - y == -(y + -x) */
7372 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7373 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7375 scm_remember_upto_here_1 (y
);
7377 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7378 /* we know the result will have to be a bignum */
7381 return scm_i_normbig (result
);
7384 else if (SCM_REALP (y
))
7386 scm_t_inum xx
= SCM_I_INUM (x
);
7389 * We need to handle x == exact 0
7390 * specially because R6RS states that:
7391 * (- 0.0) ==> -0.0 and
7392 * (- 0.0 0.0) ==> 0.0
7393 * and the scheme compiler changes
7394 * (- 0.0) into (- 0 0.0)
7395 * So we need to treat (- 0 0.0) like (- 0.0).
7396 * At the C level, (-x) is different than (0.0 - x).
7397 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7400 return scm_from_double (- SCM_REAL_VALUE (y
));
7402 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7404 else if (SCM_COMPLEXP (y
))
7406 scm_t_inum xx
= SCM_I_INUM (x
);
7408 /* We need to handle x == exact 0 specially.
7409 See the comment above (for SCM_REALP (y)) */
7411 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7412 - SCM_COMPLEX_IMAG (y
));
7414 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7415 - SCM_COMPLEX_IMAG (y
));
7417 else if (SCM_FRACTIONP (y
))
7418 /* a - b/c = (ac - b) / c */
7419 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7420 SCM_FRACTION_NUMERATOR (y
)),
7421 SCM_FRACTION_DENOMINATOR (y
));
7423 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7425 else if (SCM_BIGP (x
))
7427 if (SCM_I_INUMP (y
))
7429 /* big-x - inum-y */
7430 scm_t_inum yy
= SCM_I_INUM (y
);
7431 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7433 scm_remember_upto_here_1 (x
);
7435 return (SCM_FIXABLE (-yy
) ?
7436 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7439 SCM result
= scm_i_mkbig ();
7442 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7444 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7445 scm_remember_upto_here_1 (x
);
7447 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7448 /* we know the result will have to be a bignum */
7451 return scm_i_normbig (result
);
7454 else if (SCM_BIGP (y
))
7456 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7457 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7458 SCM result
= scm_i_mkbig ();
7459 mpz_sub (SCM_I_BIG_MPZ (result
),
7462 scm_remember_upto_here_2 (x
, y
);
7463 /* we know the result will have to be a bignum */
7464 if ((sgn_x
== 1) && (sgn_y
== -1))
7466 if ((sgn_x
== -1) && (sgn_y
== 1))
7468 return scm_i_normbig (result
);
7470 else if (SCM_REALP (y
))
7472 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7473 scm_remember_upto_here_1 (x
);
7474 return scm_from_double (result
);
7476 else if (SCM_COMPLEXP (y
))
7478 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7479 - SCM_COMPLEX_REAL (y
));
7480 scm_remember_upto_here_1 (x
);
7481 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7483 else if (SCM_FRACTIONP (y
))
7484 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7485 SCM_FRACTION_NUMERATOR (y
)),
7486 SCM_FRACTION_DENOMINATOR (y
));
7487 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7489 else if (SCM_REALP (x
))
7491 if (SCM_I_INUMP (y
))
7492 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7493 else if (SCM_BIGP (y
))
7495 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7496 scm_remember_upto_here_1 (x
);
7497 return scm_from_double (result
);
7499 else if (SCM_REALP (y
))
7500 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7501 else if (SCM_COMPLEXP (y
))
7502 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7503 -SCM_COMPLEX_IMAG (y
));
7504 else if (SCM_FRACTIONP (y
))
7505 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7507 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7509 else if (SCM_COMPLEXP (x
))
7511 if (SCM_I_INUMP (y
))
7512 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7513 SCM_COMPLEX_IMAG (x
));
7514 else if (SCM_BIGP (y
))
7516 double real_part
= (SCM_COMPLEX_REAL (x
)
7517 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7518 scm_remember_upto_here_1 (x
);
7519 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7521 else if (SCM_REALP (y
))
7522 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7523 SCM_COMPLEX_IMAG (x
));
7524 else if (SCM_COMPLEXP (y
))
7525 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7526 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7527 else if (SCM_FRACTIONP (y
))
7528 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7529 SCM_COMPLEX_IMAG (x
));
7531 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7533 else if (SCM_FRACTIONP (x
))
7535 if (SCM_I_INUMP (y
))
7536 /* a/b - c = (a - cb) / b */
7537 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7538 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7539 SCM_FRACTION_DENOMINATOR (x
));
7540 else if (SCM_BIGP (y
))
7541 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7542 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7543 SCM_FRACTION_DENOMINATOR (x
));
7544 else if (SCM_REALP (y
))
7545 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7546 else if (SCM_COMPLEXP (y
))
7547 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7548 -SCM_COMPLEX_IMAG (y
));
7549 else if (SCM_FRACTIONP (y
))
7550 /* a/b - c/d = (ad - bc) / bd */
7551 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7552 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7553 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7555 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7558 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7563 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7565 "Return @math{@var{x}-1}.")
7566 #define FUNC_NAME s_scm_oneminus
7568 return scm_difference (x
, SCM_INUM1
);
7573 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7574 (SCM x
, SCM y
, SCM rest
),
7575 "Return the product of all arguments. If called without arguments,\n"
7577 #define FUNC_NAME s_scm_i_product
7579 while (!scm_is_null (rest
))
7580 { x
= scm_product (x
, y
);
7582 rest
= scm_cdr (rest
);
7584 return scm_product (x
, y
);
7588 #define s_product s_scm_i_product
7589 #define g_product g_scm_i_product
7592 scm_product (SCM x
, SCM y
)
7594 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7597 return SCM_I_MAKINUM (1L);
7598 else if (SCM_NUMBERP (x
))
7601 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7604 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7609 xx
= SCM_I_INUM (x
);
7614 /* exact1 is the universal multiplicative identity */
7618 /* exact0 times a fixnum is exact0: optimize this case */
7619 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7621 /* if the other argument is inexact, the result is inexact,
7622 and we must do the multiplication in order to handle
7623 infinities and NaNs properly. */
7624 else if (SCM_REALP (y
))
7625 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7626 else if (SCM_COMPLEXP (y
))
7627 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7628 0.0 * SCM_COMPLEX_IMAG (y
));
7629 /* we've already handled inexact numbers,
7630 so y must be exact, and we return exact0 */
7631 else if (SCM_NUMP (y
))
7634 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7638 * This case is important for more than just optimization.
7639 * It handles the case of negating
7640 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7641 * which is a bignum that must be changed back into a fixnum.
7642 * Failure to do so will cause the following to return #f:
7643 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7645 return scm_difference(y
, SCM_UNDEFINED
);
7649 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7651 scm_t_inum yy
= SCM_I_INUM (y
);
7652 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
7653 scm_t_int64 kk
= xx
* (scm_t_int64
) yy
;
7654 if (SCM_FIXABLE (kk
))
7655 return SCM_I_MAKINUM (kk
);
7657 scm_t_inum axx
= (xx
> 0) ? xx
: -xx
;
7658 scm_t_inum ayy
= (yy
> 0) ? yy
: -yy
;
7659 if (SCM_MOST_POSITIVE_FIXNUM
/ axx
>= ayy
)
7660 return SCM_I_MAKINUM (xx
* yy
);
7664 SCM result
= scm_i_inum2big (xx
);
7665 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7666 return scm_i_normbig (result
);
7669 else if (SCM_BIGP (y
))
7671 SCM result
= scm_i_mkbig ();
7672 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7673 scm_remember_upto_here_1 (y
);
7676 else if (SCM_REALP (y
))
7677 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7678 else if (SCM_COMPLEXP (y
))
7679 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7680 xx
* SCM_COMPLEX_IMAG (y
));
7681 else if (SCM_FRACTIONP (y
))
7682 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7683 SCM_FRACTION_DENOMINATOR (y
));
7685 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7687 else if (SCM_BIGP (x
))
7689 if (SCM_I_INUMP (y
))
7694 else if (SCM_BIGP (y
))
7696 SCM result
= scm_i_mkbig ();
7697 mpz_mul (SCM_I_BIG_MPZ (result
),
7700 scm_remember_upto_here_2 (x
, y
);
7703 else if (SCM_REALP (y
))
7705 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7706 scm_remember_upto_here_1 (x
);
7707 return scm_from_double (result
);
7709 else if (SCM_COMPLEXP (y
))
7711 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7712 scm_remember_upto_here_1 (x
);
7713 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7714 z
* SCM_COMPLEX_IMAG (y
));
7716 else if (SCM_FRACTIONP (y
))
7717 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7718 SCM_FRACTION_DENOMINATOR (y
));
7720 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7722 else if (SCM_REALP (x
))
7724 if (SCM_I_INUMP (y
))
7729 else if (SCM_BIGP (y
))
7731 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7732 scm_remember_upto_here_1 (y
);
7733 return scm_from_double (result
);
7735 else if (SCM_REALP (y
))
7736 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7737 else if (SCM_COMPLEXP (y
))
7738 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7739 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7740 else if (SCM_FRACTIONP (y
))
7741 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7743 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7745 else if (SCM_COMPLEXP (x
))
7747 if (SCM_I_INUMP (y
))
7752 else if (SCM_BIGP (y
))
7754 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7755 scm_remember_upto_here_1 (y
);
7756 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7757 z
* SCM_COMPLEX_IMAG (x
));
7759 else if (SCM_REALP (y
))
7760 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7761 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7762 else if (SCM_COMPLEXP (y
))
7764 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7765 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7766 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7767 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7769 else if (SCM_FRACTIONP (y
))
7771 double yy
= scm_i_fraction2double (y
);
7772 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7773 yy
* SCM_COMPLEX_IMAG (x
));
7776 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7778 else if (SCM_FRACTIONP (x
))
7780 if (SCM_I_INUMP (y
))
7781 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7782 SCM_FRACTION_DENOMINATOR (x
));
7783 else if (SCM_BIGP (y
))
7784 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7785 SCM_FRACTION_DENOMINATOR (x
));
7786 else if (SCM_REALP (y
))
7787 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7788 else if (SCM_COMPLEXP (y
))
7790 double xx
= scm_i_fraction2double (x
);
7791 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7792 xx
* SCM_COMPLEX_IMAG (y
));
7794 else if (SCM_FRACTIONP (y
))
7795 /* a/b * c/d = ac / bd */
7796 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7797 SCM_FRACTION_NUMERATOR (y
)),
7798 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7799 SCM_FRACTION_DENOMINATOR (y
)));
7801 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7804 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7807 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7808 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7809 #define ALLOW_DIVIDE_BY_ZERO
7810 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7813 /* The code below for complex division is adapted from the GNU
7814 libstdc++, which adapted it from f2c's libF77, and is subject to
7817 /****************************************************************
7818 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7820 Permission to use, copy, modify, and distribute this software
7821 and its documentation for any purpose and without fee is hereby
7822 granted, provided that the above copyright notice appear in all
7823 copies and that both that the copyright notice and this
7824 permission notice and warranty disclaimer appear in supporting
7825 documentation, and that the names of AT&T Bell Laboratories or
7826 Bellcore or any of their entities not be used in advertising or
7827 publicity pertaining to distribution of the software without
7828 specific, written prior permission.
7830 AT&T and Bellcore disclaim all warranties with regard to this
7831 software, including all implied warranties of merchantability
7832 and fitness. In no event shall AT&T or Bellcore be liable for
7833 any special, indirect or consequential damages or any damages
7834 whatsoever resulting from loss of use, data or profits, whether
7835 in an action of contract, negligence or other tortious action,
7836 arising out of or in connection with the use or performance of
7838 ****************************************************************/
7840 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7841 (SCM x
, SCM y
, SCM rest
),
7842 "Divide the first argument by the product of the remaining\n"
7843 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7845 #define FUNC_NAME s_scm_i_divide
7847 while (!scm_is_null (rest
))
7848 { x
= scm_divide (x
, y
);
7850 rest
= scm_cdr (rest
);
7852 return scm_divide (x
, y
);
7856 #define s_divide s_scm_i_divide
7857 #define g_divide g_scm_i_divide
7860 do_divide (SCM x
, SCM y
, int inexact
)
7861 #define FUNC_NAME s_divide
7865 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7868 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7869 else if (SCM_I_INUMP (x
))
7871 scm_t_inum xx
= SCM_I_INUM (x
);
7872 if (xx
== 1 || xx
== -1)
7874 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7876 scm_num_overflow (s_divide
);
7881 return scm_from_double (1.0 / (double) xx
);
7882 else return scm_i_make_ratio (SCM_INUM1
, x
);
7885 else if (SCM_BIGP (x
))
7888 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7889 else return scm_i_make_ratio (SCM_INUM1
, x
);
7891 else if (SCM_REALP (x
))
7893 double xx
= SCM_REAL_VALUE (x
);
7894 #ifndef ALLOW_DIVIDE_BY_ZERO
7896 scm_num_overflow (s_divide
);
7899 return scm_from_double (1.0 / xx
);
7901 else if (SCM_COMPLEXP (x
))
7903 double r
= SCM_COMPLEX_REAL (x
);
7904 double i
= SCM_COMPLEX_IMAG (x
);
7905 if (fabs(r
) <= fabs(i
))
7908 double d
= i
* (1.0 + t
* t
);
7909 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7914 double d
= r
* (1.0 + t
* t
);
7915 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7918 else if (SCM_FRACTIONP (x
))
7919 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7920 SCM_FRACTION_NUMERATOR (x
));
7922 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7925 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7927 scm_t_inum xx
= SCM_I_INUM (x
);
7928 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7930 scm_t_inum yy
= SCM_I_INUM (y
);
7933 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7934 scm_num_overflow (s_divide
);
7936 return scm_from_double ((double) xx
/ (double) yy
);
7939 else if (xx
% yy
!= 0)
7942 return scm_from_double ((double) xx
/ (double) yy
);
7943 else return scm_i_make_ratio (x
, y
);
7947 scm_t_inum z
= xx
/ yy
;
7948 if (SCM_FIXABLE (z
))
7949 return SCM_I_MAKINUM (z
);
7951 return scm_i_inum2big (z
);
7954 else if (SCM_BIGP (y
))
7957 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7958 else return scm_i_make_ratio (x
, y
);
7960 else if (SCM_REALP (y
))
7962 double yy
= SCM_REAL_VALUE (y
);
7963 #ifndef ALLOW_DIVIDE_BY_ZERO
7965 scm_num_overflow (s_divide
);
7968 return scm_from_double ((double) xx
/ yy
);
7970 else if (SCM_COMPLEXP (y
))
7973 complex_div
: /* y _must_ be a complex number */
7975 double r
= SCM_COMPLEX_REAL (y
);
7976 double i
= SCM_COMPLEX_IMAG (y
);
7977 if (fabs(r
) <= fabs(i
))
7980 double d
= i
* (1.0 + t
* t
);
7981 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7986 double d
= r
* (1.0 + t
* t
);
7987 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7991 else if (SCM_FRACTIONP (y
))
7992 /* a / b/c = ac / b */
7993 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7994 SCM_FRACTION_NUMERATOR (y
));
7996 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7998 else if (SCM_BIGP (x
))
8000 if (SCM_I_INUMP (y
))
8002 scm_t_inum yy
= SCM_I_INUM (y
);
8005 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8006 scm_num_overflow (s_divide
);
8008 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8009 scm_remember_upto_here_1 (x
);
8010 return (sgn
== 0) ? scm_nan () : scm_inf ();
8017 /* FIXME: HMM, what are the relative performance issues here?
8018 We need to test. Is it faster on average to test
8019 divisible_p, then perform whichever operation, or is it
8020 faster to perform the integer div opportunistically and
8021 switch to real if there's a remainder? For now we take the
8022 middle ground: test, then if divisible, use the faster div
8025 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8026 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8030 SCM result
= scm_i_mkbig ();
8031 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8032 scm_remember_upto_here_1 (x
);
8034 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8035 return scm_i_normbig (result
);
8040 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
8041 else return scm_i_make_ratio (x
, y
);
8045 else if (SCM_BIGP (y
))
8050 /* It's easily possible for the ratio x/y to fit a double
8051 but one or both x and y be too big to fit a double,
8052 hence the use of mpq_get_d rather than converting and
8055 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8056 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8057 return scm_from_double (mpq_get_d (q
));
8061 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8065 SCM result
= scm_i_mkbig ();
8066 mpz_divexact (SCM_I_BIG_MPZ (result
),
8069 scm_remember_upto_here_2 (x
, y
);
8070 return scm_i_normbig (result
);
8073 return scm_i_make_ratio (x
, y
);
8076 else if (SCM_REALP (y
))
8078 double yy
= SCM_REAL_VALUE (y
);
8079 #ifndef ALLOW_DIVIDE_BY_ZERO
8081 scm_num_overflow (s_divide
);
8084 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8086 else if (SCM_COMPLEXP (y
))
8088 a
= scm_i_big2dbl (x
);
8091 else if (SCM_FRACTIONP (y
))
8092 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8093 SCM_FRACTION_NUMERATOR (y
));
8095 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8097 else if (SCM_REALP (x
))
8099 double rx
= SCM_REAL_VALUE (x
);
8100 if (SCM_I_INUMP (y
))
8102 scm_t_inum yy
= SCM_I_INUM (y
);
8103 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8105 scm_num_overflow (s_divide
);
8108 return scm_from_double (rx
/ (double) yy
);
8110 else if (SCM_BIGP (y
))
8112 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8113 scm_remember_upto_here_1 (y
);
8114 return scm_from_double (rx
/ dby
);
8116 else if (SCM_REALP (y
))
8118 double yy
= SCM_REAL_VALUE (y
);
8119 #ifndef ALLOW_DIVIDE_BY_ZERO
8121 scm_num_overflow (s_divide
);
8124 return scm_from_double (rx
/ yy
);
8126 else if (SCM_COMPLEXP (y
))
8131 else if (SCM_FRACTIONP (y
))
8132 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8134 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8136 else if (SCM_COMPLEXP (x
))
8138 double rx
= SCM_COMPLEX_REAL (x
);
8139 double ix
= SCM_COMPLEX_IMAG (x
);
8140 if (SCM_I_INUMP (y
))
8142 scm_t_inum yy
= SCM_I_INUM (y
);
8143 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8145 scm_num_overflow (s_divide
);
8150 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8153 else if (SCM_BIGP (y
))
8155 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8156 scm_remember_upto_here_1 (y
);
8157 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8159 else if (SCM_REALP (y
))
8161 double yy
= SCM_REAL_VALUE (y
);
8162 #ifndef ALLOW_DIVIDE_BY_ZERO
8164 scm_num_overflow (s_divide
);
8167 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8169 else if (SCM_COMPLEXP (y
))
8171 double ry
= SCM_COMPLEX_REAL (y
);
8172 double iy
= SCM_COMPLEX_IMAG (y
);
8173 if (fabs(ry
) <= fabs(iy
))
8176 double d
= iy
* (1.0 + t
* t
);
8177 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8182 double d
= ry
* (1.0 + t
* t
);
8183 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8186 else if (SCM_FRACTIONP (y
))
8188 double yy
= scm_i_fraction2double (y
);
8189 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8192 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8194 else if (SCM_FRACTIONP (x
))
8196 if (SCM_I_INUMP (y
))
8198 scm_t_inum yy
= SCM_I_INUM (y
);
8199 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8201 scm_num_overflow (s_divide
);
8204 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8205 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8207 else if (SCM_BIGP (y
))
8209 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8210 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8212 else if (SCM_REALP (y
))
8214 double yy
= SCM_REAL_VALUE (y
);
8215 #ifndef ALLOW_DIVIDE_BY_ZERO
8217 scm_num_overflow (s_divide
);
8220 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8222 else if (SCM_COMPLEXP (y
))
8224 a
= scm_i_fraction2double (x
);
8227 else if (SCM_FRACTIONP (y
))
8228 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8229 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8231 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8234 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8238 scm_divide (SCM x
, SCM y
)
8240 return do_divide (x
, y
, 0);
8243 static SCM
scm_divide2real (SCM x
, SCM y
)
8245 return do_divide (x
, y
, 1);
8251 scm_c_truncate (double x
)
8256 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8257 half-way case (ie. when x is an integer plus 0.5) going upwards.
8258 Then half-way cases are identified and adjusted down if the
8259 round-upwards didn't give the desired even integer.
8261 "plus_half == result" identifies a half-way case. If plus_half, which is
8262 x + 0.5, is an integer then x must be an integer plus 0.5.
8264 An odd "result" value is identified with result/2 != floor(result/2).
8265 This is done with plus_half, since that value is ready for use sooner in
8266 a pipelined cpu, and we're already requiring plus_half == result.
8268 Note however that we need to be careful when x is big and already an
8269 integer. In that case "x+0.5" may round to an adjacent integer, causing
8270 us to return such a value, incorrectly. For instance if the hardware is
8271 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8272 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8273 returned. Or if the hardware is in round-upwards mode, then other bigger
8274 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8275 representable value, 2^128+2^76 (or whatever), again incorrect.
8277 These bad roundings of x+0.5 are avoided by testing at the start whether
8278 x is already an integer. If it is then clearly that's the desired result
8279 already. And if it's not then the exponent must be small enough to allow
8280 an 0.5 to be represented, and hence added without a bad rounding. */
8283 scm_c_round (double x
)
8285 double plus_half
, result
;
8290 plus_half
= x
+ 0.5;
8291 result
= floor (plus_half
);
8292 /* Adjust so that the rounding is towards even. */
8293 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8298 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8300 "Round the number @var{x} towards zero.")
8301 #define FUNC_NAME s_scm_truncate_number
8303 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8305 else if (SCM_REALP (x
))
8306 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8307 else if (SCM_FRACTIONP (x
))
8308 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8309 SCM_FRACTION_DENOMINATOR (x
));
8311 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8312 s_scm_truncate_number
);
8316 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8318 "Round the number @var{x} towards the nearest integer. "
8319 "When it is exactly halfway between two integers, "
8320 "round towards the even one.")
8321 #define FUNC_NAME s_scm_round_number
8323 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8325 else if (SCM_REALP (x
))
8326 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8327 else if (SCM_FRACTIONP (x
))
8328 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8329 SCM_FRACTION_DENOMINATOR (x
));
8331 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8332 s_scm_round_number
);
8336 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8338 "Round the number @var{x} towards minus infinity.")
8339 #define FUNC_NAME s_scm_floor
8341 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8343 else if (SCM_REALP (x
))
8344 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8345 else if (SCM_FRACTIONP (x
))
8346 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8347 SCM_FRACTION_DENOMINATOR (x
));
8349 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8353 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8355 "Round the number @var{x} towards infinity.")
8356 #define FUNC_NAME s_scm_ceiling
8358 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8360 else if (SCM_REALP (x
))
8361 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8362 else if (SCM_FRACTIONP (x
))
8363 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8364 SCM_FRACTION_DENOMINATOR (x
));
8366 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8370 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8372 "Return @var{x} raised to the power of @var{y}.")
8373 #define FUNC_NAME s_scm_expt
8375 if (scm_is_integer (y
))
8377 if (scm_is_true (scm_exact_p (y
)))
8378 return scm_integer_expt (x
, y
);
8381 /* Here we handle the case where the exponent is an inexact
8382 integer. We make the exponent exact in order to use
8383 scm_integer_expt, and thus avoid the spurious imaginary
8384 parts that may result from round-off errors in the general
8385 e^(y log x) method below (for example when squaring a large
8386 negative number). In this case, we must return an inexact
8387 result for correctness. We also make the base inexact so
8388 that scm_integer_expt will use fast inexact arithmetic
8389 internally. Note that making the base inexact is not
8390 sufficient to guarantee an inexact result, because
8391 scm_integer_expt will return an exact 1 when the exponent
8392 is 0, even if the base is inexact. */
8393 return scm_exact_to_inexact
8394 (scm_integer_expt (scm_exact_to_inexact (x
),
8395 scm_inexact_to_exact (y
)));
8398 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8400 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8402 else if (scm_is_complex (x
) && scm_is_complex (y
))
8403 return scm_exp (scm_product (scm_log (x
), y
));
8404 else if (scm_is_complex (x
))
8405 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8407 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8411 /* sin/cos/tan/asin/acos/atan
8412 sinh/cosh/tanh/asinh/acosh/atanh
8413 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8414 Written by Jerry D. Hedden, (C) FSF.
8415 See the file `COPYING' for terms applying to this program. */
8417 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8419 "Compute the sine of @var{z}.")
8420 #define FUNC_NAME s_scm_sin
8422 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8423 return z
; /* sin(exact0) = exact0 */
8424 else if (scm_is_real (z
))
8425 return scm_from_double (sin (scm_to_double (z
)));
8426 else if (SCM_COMPLEXP (z
))
8428 x
= SCM_COMPLEX_REAL (z
);
8429 y
= SCM_COMPLEX_IMAG (z
);
8430 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8431 cos (x
) * sinh (y
));
8434 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8438 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8440 "Compute the cosine of @var{z}.")
8441 #define FUNC_NAME s_scm_cos
8443 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8444 return SCM_INUM1
; /* cos(exact0) = exact1 */
8445 else if (scm_is_real (z
))
8446 return scm_from_double (cos (scm_to_double (z
)));
8447 else if (SCM_COMPLEXP (z
))
8449 x
= SCM_COMPLEX_REAL (z
);
8450 y
= SCM_COMPLEX_IMAG (z
);
8451 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8452 -sin (x
) * sinh (y
));
8455 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8459 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8461 "Compute the tangent of @var{z}.")
8462 #define FUNC_NAME s_scm_tan
8464 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8465 return z
; /* tan(exact0) = exact0 */
8466 else if (scm_is_real (z
))
8467 return scm_from_double (tan (scm_to_double (z
)));
8468 else if (SCM_COMPLEXP (z
))
8470 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8471 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8472 w
= cos (x
) + cosh (y
);
8473 #ifndef ALLOW_DIVIDE_BY_ZERO
8475 scm_num_overflow (s_scm_tan
);
8477 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8480 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8484 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8486 "Compute the hyperbolic sine of @var{z}.")
8487 #define FUNC_NAME s_scm_sinh
8489 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8490 return z
; /* sinh(exact0) = exact0 */
8491 else if (scm_is_real (z
))
8492 return scm_from_double (sinh (scm_to_double (z
)));
8493 else if (SCM_COMPLEXP (z
))
8495 x
= SCM_COMPLEX_REAL (z
);
8496 y
= SCM_COMPLEX_IMAG (z
);
8497 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8498 cosh (x
) * sin (y
));
8501 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8505 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8507 "Compute the hyperbolic cosine of @var{z}.")
8508 #define FUNC_NAME s_scm_cosh
8510 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8511 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8512 else if (scm_is_real (z
))
8513 return scm_from_double (cosh (scm_to_double (z
)));
8514 else if (SCM_COMPLEXP (z
))
8516 x
= SCM_COMPLEX_REAL (z
);
8517 y
= SCM_COMPLEX_IMAG (z
);
8518 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8519 sinh (x
) * sin (y
));
8522 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8526 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8528 "Compute the hyperbolic tangent of @var{z}.")
8529 #define FUNC_NAME s_scm_tanh
8531 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8532 return z
; /* tanh(exact0) = exact0 */
8533 else if (scm_is_real (z
))
8534 return scm_from_double (tanh (scm_to_double (z
)));
8535 else if (SCM_COMPLEXP (z
))
8537 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8538 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8539 w
= cosh (x
) + cos (y
);
8540 #ifndef ALLOW_DIVIDE_BY_ZERO
8542 scm_num_overflow (s_scm_tanh
);
8544 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8547 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8551 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8553 "Compute the arc sine of @var{z}.")
8554 #define FUNC_NAME s_scm_asin
8556 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8557 return z
; /* asin(exact0) = exact0 */
8558 else if (scm_is_real (z
))
8560 double w
= scm_to_double (z
);
8561 if (w
>= -1.0 && w
<= 1.0)
8562 return scm_from_double (asin (w
));
8564 return scm_product (scm_c_make_rectangular (0, -1),
8565 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8567 else if (SCM_COMPLEXP (z
))
8569 x
= SCM_COMPLEX_REAL (z
);
8570 y
= SCM_COMPLEX_IMAG (z
);
8571 return scm_product (scm_c_make_rectangular (0, -1),
8572 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8575 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8579 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8581 "Compute the arc cosine of @var{z}.")
8582 #define FUNC_NAME s_scm_acos
8584 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8585 return SCM_INUM0
; /* acos(exact1) = exact0 */
8586 else if (scm_is_real (z
))
8588 double w
= scm_to_double (z
);
8589 if (w
>= -1.0 && w
<= 1.0)
8590 return scm_from_double (acos (w
));
8592 return scm_sum (scm_from_double (acos (0.0)),
8593 scm_product (scm_c_make_rectangular (0, 1),
8594 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8596 else if (SCM_COMPLEXP (z
))
8598 x
= SCM_COMPLEX_REAL (z
);
8599 y
= SCM_COMPLEX_IMAG (z
);
8600 return scm_sum (scm_from_double (acos (0.0)),
8601 scm_product (scm_c_make_rectangular (0, 1),
8602 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8605 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8609 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8611 "With one argument, compute the arc tangent of @var{z}.\n"
8612 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8613 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8614 #define FUNC_NAME s_scm_atan
8618 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8619 return z
; /* atan(exact0) = exact0 */
8620 else if (scm_is_real (z
))
8621 return scm_from_double (atan (scm_to_double (z
)));
8622 else if (SCM_COMPLEXP (z
))
8625 v
= SCM_COMPLEX_REAL (z
);
8626 w
= SCM_COMPLEX_IMAG (z
);
8627 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8628 scm_c_make_rectangular (v
, w
+ 1.0))),
8629 scm_c_make_rectangular (0, 2));
8632 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8634 else if (scm_is_real (z
))
8636 if (scm_is_real (y
))
8637 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8639 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8642 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8646 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8648 "Compute the inverse hyperbolic sine of @var{z}.")
8649 #define FUNC_NAME s_scm_sys_asinh
8651 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8652 return z
; /* asinh(exact0) = exact0 */
8653 else if (scm_is_real (z
))
8654 return scm_from_double (asinh (scm_to_double (z
)));
8655 else if (scm_is_number (z
))
8656 return scm_log (scm_sum (z
,
8657 scm_sqrt (scm_sum (scm_product (z
, z
),
8660 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8664 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8666 "Compute the inverse hyperbolic cosine of @var{z}.")
8667 #define FUNC_NAME s_scm_sys_acosh
8669 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8670 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8671 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8672 return scm_from_double (acosh (scm_to_double (z
)));
8673 else if (scm_is_number (z
))
8674 return scm_log (scm_sum (z
,
8675 scm_sqrt (scm_difference (scm_product (z
, z
),
8678 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8682 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8684 "Compute the inverse hyperbolic tangent of @var{z}.")
8685 #define FUNC_NAME s_scm_sys_atanh
8687 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8688 return z
; /* atanh(exact0) = exact0 */
8689 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8690 return scm_from_double (atanh (scm_to_double (z
)));
8691 else if (scm_is_number (z
))
8692 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8693 scm_difference (SCM_INUM1
, z
))),
8696 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8701 scm_c_make_rectangular (double re
, double im
)
8705 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8707 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8708 SCM_COMPLEX_REAL (z
) = re
;
8709 SCM_COMPLEX_IMAG (z
) = im
;
8713 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8714 (SCM real_part
, SCM imaginary_part
),
8715 "Return a complex number constructed of the given @var{real_part} "
8716 "and @var{imaginary_part} parts.")
8717 #define FUNC_NAME s_scm_make_rectangular
8719 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8720 SCM_ARG1
, FUNC_NAME
, "real");
8721 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8722 SCM_ARG2
, FUNC_NAME
, "real");
8724 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8725 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8728 return scm_c_make_rectangular (scm_to_double (real_part
),
8729 scm_to_double (imaginary_part
));
8734 scm_c_make_polar (double mag
, double ang
)
8738 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8739 use it on Glibc-based systems that have it (it's a GNU extension). See
8740 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8742 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8743 sincos (ang
, &s
, &c
);
8749 /* If s and c are NaNs, this indicates that the angle is a NaN,
8750 infinite, or perhaps simply too large to determine its value
8751 mod 2*pi. However, we know something that the floating-point
8752 implementation doesn't know: We know that s and c are finite.
8753 Therefore, if the magnitude is zero, return a complex zero.
8755 The reason we check for the NaNs instead of using this case
8756 whenever mag == 0.0 is because when the angle is known, we'd
8757 like to return the correct kind of non-real complex zero:
8758 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8759 on which quadrant the angle is in.
8761 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8762 return scm_c_make_rectangular (0.0, 0.0);
8764 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8767 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8769 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8770 #define FUNC_NAME s_scm_make_polar
8772 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8773 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8775 /* If mag is exact0, return exact0 */
8776 if (scm_is_eq (mag
, SCM_INUM0
))
8778 /* Return a real if ang is exact0 */
8779 else if (scm_is_eq (ang
, SCM_INUM0
))
8782 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8787 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8789 "Return the real part of the number @var{z}.")
8790 #define FUNC_NAME s_scm_real_part
8792 if (SCM_COMPLEXP (z
))
8793 return scm_from_double (SCM_COMPLEX_REAL (z
));
8794 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8797 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8802 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8804 "Return the imaginary part of the number @var{z}.")
8805 #define FUNC_NAME s_scm_imag_part
8807 if (SCM_COMPLEXP (z
))
8808 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8809 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8812 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8816 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8818 "Return the numerator of the number @var{z}.")
8819 #define FUNC_NAME s_scm_numerator
8821 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8823 else if (SCM_FRACTIONP (z
))
8824 return SCM_FRACTION_NUMERATOR (z
);
8825 else if (SCM_REALP (z
))
8826 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8828 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8833 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8835 "Return the denominator of the number @var{z}.")
8836 #define FUNC_NAME s_scm_denominator
8838 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8840 else if (SCM_FRACTIONP (z
))
8841 return SCM_FRACTION_DENOMINATOR (z
);
8842 else if (SCM_REALP (z
))
8843 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8845 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8850 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8852 "Return the magnitude of the number @var{z}. This is the same as\n"
8853 "@code{abs} for real arguments, but also allows complex numbers.")
8854 #define FUNC_NAME s_scm_magnitude
8856 if (SCM_I_INUMP (z
))
8858 scm_t_inum zz
= SCM_I_INUM (z
);
8861 else if (SCM_POSFIXABLE (-zz
))
8862 return SCM_I_MAKINUM (-zz
);
8864 return scm_i_inum2big (-zz
);
8866 else if (SCM_BIGP (z
))
8868 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8869 scm_remember_upto_here_1 (z
);
8871 return scm_i_clonebig (z
, 0);
8875 else if (SCM_REALP (z
))
8876 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8877 else if (SCM_COMPLEXP (z
))
8878 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8879 else if (SCM_FRACTIONP (z
))
8881 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8883 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8884 SCM_FRACTION_DENOMINATOR (z
));
8887 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8892 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8894 "Return the angle of the complex number @var{z}.")
8895 #define FUNC_NAME s_scm_angle
8897 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8898 flo0 to save allocating a new flonum with scm_from_double each time.
8899 But if atan2 follows the floating point rounding mode, then the value
8900 is not a constant. Maybe it'd be close enough though. */
8901 if (SCM_I_INUMP (z
))
8903 if (SCM_I_INUM (z
) >= 0)
8906 return scm_from_double (atan2 (0.0, -1.0));
8908 else if (SCM_BIGP (z
))
8910 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8911 scm_remember_upto_here_1 (z
);
8913 return scm_from_double (atan2 (0.0, -1.0));
8917 else if (SCM_REALP (z
))
8919 double x
= SCM_REAL_VALUE (z
);
8920 if (x
> 0.0 || double_is_non_negative_zero (x
))
8923 return scm_from_double (atan2 (0.0, -1.0));
8925 else if (SCM_COMPLEXP (z
))
8926 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8927 else if (SCM_FRACTIONP (z
))
8929 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8931 else return scm_from_double (atan2 (0.0, -1.0));
8934 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8939 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8941 "Convert the number @var{z} to its inexact representation.\n")
8942 #define FUNC_NAME s_scm_exact_to_inexact
8944 if (SCM_I_INUMP (z
))
8945 return scm_from_double ((double) SCM_I_INUM (z
));
8946 else if (SCM_BIGP (z
))
8947 return scm_from_double (scm_i_big2dbl (z
));
8948 else if (SCM_FRACTIONP (z
))
8949 return scm_from_double (scm_i_fraction2double (z
));
8950 else if (SCM_INEXACTP (z
))
8953 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
8958 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8960 "Return an exact number that is numerically closest to @var{z}.")
8961 #define FUNC_NAME s_scm_inexact_to_exact
8963 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8970 val
= SCM_REAL_VALUE (z
);
8971 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8972 val
= SCM_COMPLEX_REAL (z
);
8974 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
8976 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8977 SCM_OUT_OF_RANGE (1, z
);
8984 mpq_set_d (frac
, val
);
8985 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8986 scm_i_mpz2num (mpq_denref (frac
)));
8988 /* When scm_i_make_ratio throws, we leak the memory allocated
8998 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
9000 "Returns the @emph{simplest} rational number differing\n"
9001 "from @var{x} by no more than @var{eps}.\n"
9003 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9004 "exact result when both its arguments are exact. Thus, you might need\n"
9005 "to use @code{inexact->exact} on the arguments.\n"
9008 "(rationalize (inexact->exact 1.2) 1/100)\n"
9011 #define FUNC_NAME s_scm_rationalize
9013 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9014 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9015 eps
= scm_abs (eps
);
9016 if (scm_is_false (scm_positive_p (eps
)))
9018 /* eps is either zero or a NaN */
9019 if (scm_is_true (scm_nan_p (eps
)))
9021 else if (SCM_INEXACTP (eps
))
9022 return scm_exact_to_inexact (x
);
9026 else if (scm_is_false (scm_finite_p (eps
)))
9028 if (scm_is_true (scm_finite_p (x
)))
9033 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9035 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9036 scm_ceiling (scm_difference (x
, eps
)))))
9038 /* There's an integer within range; we want the one closest to zero */
9039 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9041 /* zero is within range */
9042 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9047 else if (scm_is_true (scm_positive_p (x
)))
9048 return scm_ceiling (scm_difference (x
, eps
));
9050 return scm_floor (scm_sum (x
, eps
));
9054 /* Use continued fractions to find closest ratio. All
9055 arithmetic is done with exact numbers.
9058 SCM ex
= scm_inexact_to_exact (x
);
9059 SCM int_part
= scm_floor (ex
);
9061 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9062 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9066 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9067 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9069 /* We stop after a million iterations just to be absolutely sure
9070 that we don't go into an infinite loop. The process normally
9071 converges after less than a dozen iterations.
9074 while (++i
< 1000000)
9076 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9077 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9078 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9080 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9081 eps
))) /* abs(x-a/b) <= eps */
9083 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9084 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9085 return scm_exact_to_inexact (res
);
9089 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9091 tt
= scm_floor (rx
); /* tt = floor (rx) */
9097 scm_num_overflow (s_scm_rationalize
);
9102 /* conversion functions */
9105 scm_is_integer (SCM val
)
9107 return scm_is_true (scm_integer_p (val
));
9111 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9113 if (SCM_I_INUMP (val
))
9115 scm_t_signed_bits n
= SCM_I_INUM (val
);
9116 return n
>= min
&& n
<= max
;
9118 else if (SCM_BIGP (val
))
9120 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9122 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9124 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9126 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9127 return n
>= min
&& n
<= max
;
9137 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9138 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9141 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9142 SCM_I_BIG_MPZ (val
));
9144 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9156 return n
>= min
&& n
<= max
;
9164 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9166 if (SCM_I_INUMP (val
))
9168 scm_t_signed_bits n
= SCM_I_INUM (val
);
9169 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9171 else if (SCM_BIGP (val
))
9173 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9175 else if (max
<= ULONG_MAX
)
9177 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9179 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9180 return n
>= min
&& n
<= max
;
9190 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9193 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9194 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9197 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9198 SCM_I_BIG_MPZ (val
));
9200 return n
>= min
&& n
<= max
;
9208 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9210 scm_error (scm_out_of_range_key
,
9212 "Value out of range ~S to ~S: ~S",
9213 scm_list_3 (min
, max
, bad_val
),
9214 scm_list_1 (bad_val
));
9217 #define TYPE scm_t_intmax
9218 #define TYPE_MIN min
9219 #define TYPE_MAX max
9220 #define SIZEOF_TYPE 0
9221 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9222 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9223 #include "libguile/conv-integer.i.c"
9225 #define TYPE scm_t_uintmax
9226 #define TYPE_MIN min
9227 #define TYPE_MAX max
9228 #define SIZEOF_TYPE 0
9229 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9230 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9231 #include "libguile/conv-uinteger.i.c"
9233 #define TYPE scm_t_int8
9234 #define TYPE_MIN SCM_T_INT8_MIN
9235 #define TYPE_MAX SCM_T_INT8_MAX
9236 #define SIZEOF_TYPE 1
9237 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9238 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9239 #include "libguile/conv-integer.i.c"
9241 #define TYPE scm_t_uint8
9243 #define TYPE_MAX SCM_T_UINT8_MAX
9244 #define SIZEOF_TYPE 1
9245 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9246 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9247 #include "libguile/conv-uinteger.i.c"
9249 #define TYPE scm_t_int16
9250 #define TYPE_MIN SCM_T_INT16_MIN
9251 #define TYPE_MAX SCM_T_INT16_MAX
9252 #define SIZEOF_TYPE 2
9253 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9254 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9255 #include "libguile/conv-integer.i.c"
9257 #define TYPE scm_t_uint16
9259 #define TYPE_MAX SCM_T_UINT16_MAX
9260 #define SIZEOF_TYPE 2
9261 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9262 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9263 #include "libguile/conv-uinteger.i.c"
9265 #define TYPE scm_t_int32
9266 #define TYPE_MIN SCM_T_INT32_MIN
9267 #define TYPE_MAX SCM_T_INT32_MAX
9268 #define SIZEOF_TYPE 4
9269 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9270 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9271 #include "libguile/conv-integer.i.c"
9273 #define TYPE scm_t_uint32
9275 #define TYPE_MAX SCM_T_UINT32_MAX
9276 #define SIZEOF_TYPE 4
9277 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9278 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9279 #include "libguile/conv-uinteger.i.c"
9281 #define TYPE scm_t_wchar
9282 #define TYPE_MIN (scm_t_int32)-1
9283 #define TYPE_MAX (scm_t_int32)0x10ffff
9284 #define SIZEOF_TYPE 4
9285 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9286 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9287 #include "libguile/conv-integer.i.c"
9289 #define TYPE scm_t_int64
9290 #define TYPE_MIN SCM_T_INT64_MIN
9291 #define TYPE_MAX SCM_T_INT64_MAX
9292 #define SIZEOF_TYPE 8
9293 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9294 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9295 #include "libguile/conv-integer.i.c"
9297 #define TYPE scm_t_uint64
9299 #define TYPE_MAX SCM_T_UINT64_MAX
9300 #define SIZEOF_TYPE 8
9301 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9302 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9303 #include "libguile/conv-uinteger.i.c"
9306 scm_to_mpz (SCM val
, mpz_t rop
)
9308 if (SCM_I_INUMP (val
))
9309 mpz_set_si (rop
, SCM_I_INUM (val
));
9310 else if (SCM_BIGP (val
))
9311 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9313 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9317 scm_from_mpz (mpz_t val
)
9319 return scm_i_mpz2num (val
);
9323 scm_is_real (SCM val
)
9325 return scm_is_true (scm_real_p (val
));
9329 scm_is_rational (SCM val
)
9331 return scm_is_true (scm_rational_p (val
));
9335 scm_to_double (SCM val
)
9337 if (SCM_I_INUMP (val
))
9338 return SCM_I_INUM (val
);
9339 else if (SCM_BIGP (val
))
9340 return scm_i_big2dbl (val
);
9341 else if (SCM_FRACTIONP (val
))
9342 return scm_i_fraction2double (val
);
9343 else if (SCM_REALP (val
))
9344 return SCM_REAL_VALUE (val
);
9346 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9350 scm_from_double (double val
)
9354 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9356 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9357 SCM_REAL_VALUE (z
) = val
;
9362 #if SCM_ENABLE_DEPRECATED == 1
9365 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9367 scm_c_issue_deprecation_warning
9368 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9372 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9376 scm_out_of_range (NULL
, num
);
9379 return scm_to_double (num
);
9383 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9385 scm_c_issue_deprecation_warning
9386 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9390 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9394 scm_out_of_range (NULL
, num
);
9397 return scm_to_double (num
);
9403 scm_is_complex (SCM val
)
9405 return scm_is_true (scm_complex_p (val
));
9409 scm_c_real_part (SCM z
)
9411 if (SCM_COMPLEXP (z
))
9412 return SCM_COMPLEX_REAL (z
);
9415 /* Use the scm_real_part to get proper error checking and
9418 return scm_to_double (scm_real_part (z
));
9423 scm_c_imag_part (SCM z
)
9425 if (SCM_COMPLEXP (z
))
9426 return SCM_COMPLEX_IMAG (z
);
9429 /* Use the scm_imag_part to get proper error checking and
9430 dispatching. The result will almost always be 0.0, but not
9433 return scm_to_double (scm_imag_part (z
));
9438 scm_c_magnitude (SCM z
)
9440 return scm_to_double (scm_magnitude (z
));
9446 return scm_to_double (scm_angle (z
));
9450 scm_is_number (SCM z
)
9452 return scm_is_true (scm_number_p (z
));
9456 /* Returns log(x * 2^shift) */
9458 log_of_shifted_double (double x
, long shift
)
9460 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9462 if (x
> 0.0 || double_is_non_negative_zero (x
))
9463 return scm_from_double (ans
);
9465 return scm_c_make_rectangular (ans
, M_PI
);
9468 /* Returns log(n), for exact integer n of integer-length size */
9470 log_of_exact_integer_with_size (SCM n
, long size
)
9472 long shift
= size
- 2 * scm_dblprec
[0];
9475 return log_of_shifted_double
9476 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9479 return log_of_shifted_double (scm_to_double (n
), 0);
9482 /* Returns log(n), for exact integer n */
9484 log_of_exact_integer (SCM n
)
9486 return log_of_exact_integer_with_size
9487 (n
, scm_to_long (scm_integer_length (n
)));
9490 /* Returns log(n/d), for exact non-zero integers n and d */
9492 log_of_fraction (SCM n
, SCM d
)
9494 long n_size
= scm_to_long (scm_integer_length (n
));
9495 long d_size
= scm_to_long (scm_integer_length (d
));
9497 if (abs (n_size
- d_size
) > 1)
9498 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9499 log_of_exact_integer_with_size (d
, d_size
)));
9500 else if (scm_is_false (scm_negative_p (n
)))
9501 return scm_from_double
9502 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9504 return scm_c_make_rectangular
9505 (log1p (scm_to_double (scm_divide2real
9506 (scm_difference (scm_abs (n
), d
),
9512 /* In the following functions we dispatch to the real-arg funcs like log()
9513 when we know the arg is real, instead of just handing everything to
9514 clog() for instance. This is in case clog() doesn't optimize for a
9515 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9516 well use it to go straight to the applicable C func. */
9518 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9520 "Return the natural logarithm of @var{z}.")
9521 #define FUNC_NAME s_scm_log
9523 if (SCM_COMPLEXP (z
))
9525 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9526 && defined (SCM_COMPLEX_VALUE)
9527 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9529 double re
= SCM_COMPLEX_REAL (z
);
9530 double im
= SCM_COMPLEX_IMAG (z
);
9531 return scm_c_make_rectangular (log (hypot (re
, im
)),
9535 else if (SCM_REALP (z
))
9536 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9537 else if (SCM_I_INUMP (z
))
9539 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9540 if (scm_is_eq (z
, SCM_INUM0
))
9541 scm_num_overflow (s_scm_log
);
9543 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9545 else if (SCM_BIGP (z
))
9546 return log_of_exact_integer (z
);
9547 else if (SCM_FRACTIONP (z
))
9548 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9549 SCM_FRACTION_DENOMINATOR (z
));
9551 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9556 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9558 "Return the base 10 logarithm of @var{z}.")
9559 #define FUNC_NAME s_scm_log10
9561 if (SCM_COMPLEXP (z
))
9563 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9564 clog() and a multiply by M_LOG10E, rather than the fallback
9565 log10+hypot+atan2.) */
9566 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9567 && defined SCM_COMPLEX_VALUE
9568 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9570 double re
= SCM_COMPLEX_REAL (z
);
9571 double im
= SCM_COMPLEX_IMAG (z
);
9572 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9573 M_LOG10E
* atan2 (im
, re
));
9576 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9578 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9579 if (scm_is_eq (z
, SCM_INUM0
))
9580 scm_num_overflow (s_scm_log10
);
9583 double re
= scm_to_double (z
);
9584 double l
= log10 (fabs (re
));
9585 if (re
> 0.0 || double_is_non_negative_zero (re
))
9586 return scm_from_double (l
);
9588 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9591 else if (SCM_BIGP (z
))
9592 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9593 else if (SCM_FRACTIONP (z
))
9594 return scm_product (flo_log10e
,
9595 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9596 SCM_FRACTION_DENOMINATOR (z
)));
9598 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9603 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9605 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9606 "base of natural logarithms (2.71828@dots{}).")
9607 #define FUNC_NAME s_scm_exp
9609 if (SCM_COMPLEXP (z
))
9611 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9612 && defined (SCM_COMPLEX_VALUE)
9613 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9615 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9616 SCM_COMPLEX_IMAG (z
));
9619 else if (SCM_NUMBERP (z
))
9621 /* When z is a negative bignum the conversion to double overflows,
9622 giving -infinity, but that's ok, the exp is still 0.0. */
9623 return scm_from_double (exp (scm_to_double (z
)));
9626 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9631 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9633 "Return two exact non-negative integers @var{s} and @var{r}\n"
9634 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9635 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9636 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9639 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9641 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9645 scm_exact_integer_sqrt (k
, &s
, &r
);
9646 return scm_values (scm_list_2 (s
, r
));
9651 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9653 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9655 scm_t_inum kk
= SCM_I_INUM (k
);
9659 if (SCM_LIKELY (kk
> 0))
9664 uu
= (ss
+ kk
/ss
) / 2;
9666 *sp
= SCM_I_MAKINUM (ss
);
9667 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9669 else if (SCM_LIKELY (kk
== 0))
9670 *sp
= *rp
= SCM_INUM0
;
9672 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9673 "exact non-negative integer");
9675 else if (SCM_LIKELY (SCM_BIGP (k
)))
9679 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9680 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9681 "exact non-negative integer");
9684 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9685 scm_remember_upto_here_1 (k
);
9686 *sp
= scm_i_normbig (s
);
9687 *rp
= scm_i_normbig (r
);
9690 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9691 "exact non-negative integer");
9695 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9697 "Return the square root of @var{z}. Of the two possible roots\n"
9698 "(positive and negative), the one with positive real part\n"
9699 "is returned, or if that's zero then a positive imaginary part.\n"
9703 "(sqrt 9.0) @result{} 3.0\n"
9704 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9705 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9706 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9708 #define FUNC_NAME s_scm_sqrt
9710 if (SCM_COMPLEXP (z
))
9712 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9713 && defined SCM_COMPLEX_VALUE
9714 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9716 double re
= SCM_COMPLEX_REAL (z
);
9717 double im
= SCM_COMPLEX_IMAG (z
);
9718 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9719 0.5 * atan2 (im
, re
));
9722 else if (SCM_NUMBERP (z
))
9724 double xx
= scm_to_double (z
);
9726 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9728 return scm_from_double (sqrt (xx
));
9731 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9742 if (scm_install_gmp_memory_functions
)
9743 mp_set_memory_functions (custom_gmp_malloc
,
9747 mpz_init_set_si (z_negative_one
, -1);
9749 /* It may be possible to tune the performance of some algorithms by using
9750 * the following constants to avoid the creation of bignums. Please, before
9751 * using these values, remember the two rules of program optimization:
9752 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9753 scm_c_define ("most-positive-fixnum",
9754 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9755 scm_c_define ("most-negative-fixnum",
9756 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9758 scm_add_feature ("complex");
9759 scm_add_feature ("inexact");
9760 flo0
= scm_from_double (0.0);
9761 flo_log10e
= scm_from_double (M_LOG10E
);
9763 /* determine floating point precision */
9764 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9766 init_dblprec(&scm_dblprec
[i
-2],i
);
9767 init_fx_radix(fx_per_radix
[i
-2],i
);
9770 /* hard code precision for base 10 if the preprocessor tells us to... */
9771 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9774 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9775 #include "libguile/numbers.x"