1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 /* General assumptions:
25 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
26 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
27 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
28 * XXX What about infinities? They are equal to their own floor! -mhw
29 * All objects satisfying SCM_FRACTIONP are never an integer.
34 - see if special casing bignums and reals in integer-exponent when
35 possible (to use mpz_pow and mpf_pow_ui) is faster.
37 - look in to better short-circuiting of common cases in
38 integer-expt and elsewhere.
40 - see if direct mpz operations can help in ash and elsewhere.
59 #include "libguile/_scm.h"
60 #include "libguile/feature.h"
61 #include "libguile/ports.h"
62 #include "libguile/root.h"
63 #include "libguile/smob.h"
64 #include "libguile/strings.h"
65 #include "libguile/bdw-gc.h"
67 #include "libguile/validate.h"
68 #include "libguile/numbers.h"
69 #include "libguile/deprecation.h"
71 #include "libguile/eq.h"
73 /* values per glibc, if not already defined */
75 #define M_LOG10E 0.43429448190325182765
78 #define M_LN2 0.69314718055994530942
81 #define M_PI 3.14159265358979323846
84 typedef scm_t_signed_bits scm_t_inum
;
85 #define scm_from_inum(x) (scm_from_signed_integer (x))
87 /* Tests to see if a C double is neither infinite nor a NaN.
88 TODO: if it's available, use C99's isfinite(x) instead */
89 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
91 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
92 of the infinity, but other platforms return a boolean only. */
93 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
94 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
99 Wonder if this might be faster for some of our code? A switch on
100 the numtag would jump directly to the right case, and the
101 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
103 #define SCM_I_NUMTAG_NOTNUM 0
104 #define SCM_I_NUMTAG_INUM 1
105 #define SCM_I_NUMTAG_BIG scm_tc16_big
106 #define SCM_I_NUMTAG_REAL scm_tc16_real
107 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
108 #define SCM_I_NUMTAG(x) \
109 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
110 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
111 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
112 : SCM_I_NUMTAG_NOTNUM)))
114 /* the macro above will not work as is with fractions */
117 /* Default to 1, because as we used to hard-code `free' as the
118 deallocator, we know that overriding these functions with
119 instrumented `malloc' / `free' is OK. */
120 int scm_install_gmp_memory_functions
= 1;
122 static SCM exactly_one_half
;
123 static SCM flo_log10e
;
125 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
127 /* FLOBUFLEN is the maximum number of characters neccessary for the
128 * printed or scm_string representation of an inexact number.
130 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
133 #if !defined (HAVE_ASINH)
134 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
136 #if !defined (HAVE_ACOSH)
137 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
139 #if !defined (HAVE_ATANH)
140 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
143 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
144 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
145 in March 2006), mpz_cmp_d now handles infinities properly. */
147 #define xmpz_cmp_d(z, d) \
148 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
150 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
154 #if defined (GUILE_I)
155 #if defined HAVE_COMPLEX_DOUBLE
157 /* For an SCM object Z which is a complex number (ie. satisfies
158 SCM_COMPLEXP), return its value as a C level "complex double". */
159 #define SCM_COMPLEX_VALUE(z) \
160 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
162 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
164 /* Convert a C "complex double" to an SCM value. */
166 scm_from_complex_double (complex double z
)
168 return scm_c_make_rectangular (creal (z
), cimag (z
));
171 #endif /* HAVE_COMPLEX_DOUBLE */
176 static mpz_t z_negative_one
;
180 /* Clear the `mpz_t' embedded in bignum PTR. */
182 finalize_bignum (GC_PTR ptr
, GC_PTR data
)
186 bignum
= SCM_PACK_POINTER (ptr
);
187 mpz_clear (SCM_I_BIG_MPZ (bignum
));
190 /* The next three functions (custom_libgmp_*) are passed to
191 mp_set_memory_functions (in GMP) so that memory used by the digits
192 themselves is known to the garbage collector. This is needed so
193 that GC will be run at appropriate times. Otherwise, a program which
194 creates many large bignums would malloc a huge amount of memory
195 before the GC runs. */
197 custom_gmp_malloc (size_t alloc_size
)
199 return scm_malloc (alloc_size
);
203 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
205 return scm_realloc (old_ptr
, new_size
);
209 custom_gmp_free (void *ptr
, size_t size
)
215 /* Return a new uninitialized bignum. */
220 GC_finalization_proc prev_finalizer
;
221 GC_PTR prev_finalizer_data
;
223 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
224 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
228 GC_REGISTER_FINALIZER_NO_ORDER (p
, finalize_bignum
, NULL
,
230 &prev_finalizer_data
);
239 /* Return a newly created bignum. */
240 SCM z
= make_bignum ();
241 mpz_init (SCM_I_BIG_MPZ (z
));
246 scm_i_inum2big (scm_t_inum x
)
248 /* Return a newly created bignum initialized to X. */
249 SCM z
= make_bignum ();
250 #if SIZEOF_VOID_P == SIZEOF_LONG
251 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
253 /* Note that in this case, you'll also have to check all mpz_*_ui and
254 mpz_*_si invocations in Guile. */
255 #error creation of mpz not implemented for this inum size
261 scm_i_long2big (long x
)
263 /* Return a newly created bignum initialized to X. */
264 SCM z
= make_bignum ();
265 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
270 scm_i_ulong2big (unsigned long x
)
272 /* Return a newly created bignum initialized to X. */
273 SCM z
= make_bignum ();
274 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
279 scm_i_clonebig (SCM src_big
, int same_sign_p
)
281 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
282 SCM z
= make_bignum ();
283 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
285 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
290 scm_i_bigcmp (SCM x
, SCM y
)
292 /* Return neg if x < y, pos if x > y, and 0 if x == y */
293 /* presume we already know x and y are bignums */
294 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
295 scm_remember_upto_here_2 (x
, y
);
300 scm_i_dbl2big (double d
)
302 /* results are only defined if d is an integer */
303 SCM z
= make_bignum ();
304 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
308 /* Convert a integer in double representation to a SCM number. */
311 scm_i_dbl2num (double u
)
313 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
314 powers of 2, so there's no rounding when making "double" values
315 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
316 get rounded on a 64-bit machine, hence the "+1".
318 The use of floor() to force to an integer value ensures we get a
319 "numerically closest" value without depending on how a
320 double->long cast or how mpz_set_d will round. For reference,
321 double->long probably follows the hardware rounding mode,
322 mpz_set_d truncates towards zero. */
324 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
325 representable as a double? */
327 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
328 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
329 return SCM_I_MAKINUM ((scm_t_inum
) u
);
331 return scm_i_dbl2big (u
);
334 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
335 with R5RS exact->inexact.
337 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
338 (ie. truncate towards zero), then adjust to get the closest double by
339 examining the next lower bit and adding 1 (to the absolute value) if
342 Bignums exactly half way between representable doubles are rounded to the
343 next higher absolute value (ie. away from zero). This seems like an
344 adequate interpretation of R5RS "numerically closest", and it's easier
345 and faster than a full "nearest-even" style.
347 The bit test must be done on the absolute value of the mpz_t, which means
348 we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
349 negatives as twos complement.
351 In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
352 following the hardware rounding mode, but applied to the absolute
353 value of the mpz_t operand. This is not what we want so we put the
354 high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
355 (released in March 2006) mpz_get_d now always truncates towards zero.
357 ENHANCE-ME: The temporary init+clear to force the rounding in GMP
358 before 4.2 is a slowdown. It'd be faster to pick out the relevant
359 high bits with mpz_getlimbn. */
362 scm_i_big2dbl (SCM b
)
367 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
371 /* For GMP earlier than 4.2, force truncation towards zero */
373 /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
374 _not_ the number of bits, so this code will break badly on a
375 system with non-binary doubles. */
378 if (bits
> DBL_MANT_DIG
)
380 size_t shift
= bits
- DBL_MANT_DIG
;
381 mpz_init2 (tmp
, DBL_MANT_DIG
);
382 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
383 result
= ldexp (mpz_get_d (tmp
), shift
);
388 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
392 /* GMP 4.2 or later */
393 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
396 if (bits
> DBL_MANT_DIG
)
398 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
399 /* test bit number "pos" in absolute value */
400 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
401 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
403 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
407 scm_remember_upto_here_1 (b
);
412 scm_i_normbig (SCM b
)
414 /* convert a big back to a fixnum if it'll fit */
415 /* presume b is a bignum */
416 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
418 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
419 if (SCM_FIXABLE (val
))
420 b
= SCM_I_MAKINUM (val
);
425 static SCM_C_INLINE_KEYWORD SCM
426 scm_i_mpz2num (mpz_t b
)
428 /* convert a mpz number to a SCM number. */
429 if (mpz_fits_slong_p (b
))
431 scm_t_inum val
= mpz_get_si (b
);
432 if (SCM_FIXABLE (val
))
433 return SCM_I_MAKINUM (val
);
437 SCM z
= make_bignum ();
438 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
443 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
444 static SCM
scm_divide2real (SCM x
, SCM y
);
447 scm_i_make_ratio (SCM numerator
, SCM denominator
)
448 #define FUNC_NAME "make-ratio"
450 /* First make sure the arguments are proper.
452 if (SCM_I_INUMP (denominator
))
454 if (scm_is_eq (denominator
, SCM_INUM0
))
455 scm_num_overflow ("make-ratio");
456 if (scm_is_eq (denominator
, SCM_INUM1
))
461 if (!(SCM_BIGP(denominator
)))
462 SCM_WRONG_TYPE_ARG (2, denominator
);
464 if (!SCM_I_INUMP (numerator
) && !SCM_BIGP (numerator
))
465 SCM_WRONG_TYPE_ARG (1, numerator
);
467 /* Then flip signs so that the denominator is positive.
469 if (scm_is_true (scm_negative_p (denominator
)))
471 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
472 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
475 /* Now consider for each of the four fixnum/bignum combinations
476 whether the rational number is really an integer.
478 if (SCM_I_INUMP (numerator
))
480 scm_t_inum x
= SCM_I_INUM (numerator
);
481 if (scm_is_eq (numerator
, SCM_INUM0
))
483 if (SCM_I_INUMP (denominator
))
486 y
= SCM_I_INUM (denominator
);
490 return SCM_I_MAKINUM (x
/ y
);
494 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
495 of that value for the denominator, as a bignum. Apart from
496 that case, abs(bignum) > abs(inum) so inum/bignum is not an
498 if (x
== SCM_MOST_NEGATIVE_FIXNUM
499 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
500 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
501 return SCM_I_MAKINUM(-1);
504 else if (SCM_BIGP (numerator
))
506 if (SCM_I_INUMP (denominator
))
508 scm_t_inum yy
= SCM_I_INUM (denominator
);
509 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
510 return scm_divide (numerator
, denominator
);
514 if (scm_is_eq (numerator
, denominator
))
516 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
517 SCM_I_BIG_MPZ (denominator
)))
518 return scm_divide(numerator
, denominator
);
522 /* No, it's a proper fraction.
525 SCM divisor
= scm_gcd (numerator
, denominator
);
526 if (!(scm_is_eq (divisor
, SCM_INUM1
)))
528 numerator
= scm_divide (numerator
, divisor
);
529 denominator
= scm_divide (denominator
, divisor
);
532 return scm_double_cell (scm_tc16_fraction
,
533 SCM_UNPACK (numerator
),
534 SCM_UNPACK (denominator
), 0);
540 scm_i_fraction2double (SCM z
)
542 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
543 SCM_FRACTION_DENOMINATOR (z
)));
547 double_is_non_negative_zero (double x
)
549 static double zero
= 0.0;
551 return !memcmp (&x
, &zero
, sizeof(double));
554 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
556 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
558 #define FUNC_NAME s_scm_exact_p
560 if (SCM_INEXACTP (x
))
562 else if (SCM_NUMBERP (x
))
565 return scm_wta_dispatch_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
570 scm_is_exact (SCM val
)
572 return scm_is_true (scm_exact_p (val
));
575 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
577 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
579 #define FUNC_NAME s_scm_inexact_p
581 if (SCM_INEXACTP (x
))
583 else if (SCM_NUMBERP (x
))
586 return scm_wta_dispatch_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
591 scm_is_inexact (SCM val
)
593 return scm_is_true (scm_inexact_p (val
));
596 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
598 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
600 #define FUNC_NAME s_scm_odd_p
604 scm_t_inum val
= SCM_I_INUM (n
);
605 return scm_from_bool ((val
& 1L) != 0);
607 else if (SCM_BIGP (n
))
609 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
610 scm_remember_upto_here_1 (n
);
611 return scm_from_bool (odd_p
);
613 else if (SCM_REALP (n
))
615 double val
= SCM_REAL_VALUE (n
);
616 if (DOUBLE_IS_FINITE (val
))
618 double rem
= fabs (fmod (val
, 2.0));
625 return scm_wta_dispatch_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
630 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
632 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
634 #define FUNC_NAME s_scm_even_p
638 scm_t_inum val
= SCM_I_INUM (n
);
639 return scm_from_bool ((val
& 1L) == 0);
641 else if (SCM_BIGP (n
))
643 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
644 scm_remember_upto_here_1 (n
);
645 return scm_from_bool (even_p
);
647 else if (SCM_REALP (n
))
649 double val
= SCM_REAL_VALUE (n
);
650 if (DOUBLE_IS_FINITE (val
))
652 double rem
= fabs (fmod (val
, 2.0));
659 return scm_wta_dispatch_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
663 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
665 "Return @code{#t} if the real number @var{x} is neither\n"
666 "infinite nor a NaN, @code{#f} otherwise.")
667 #define FUNC_NAME s_scm_finite_p
670 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
671 else if (scm_is_real (x
))
674 return scm_wta_dispatch_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
678 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
680 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
681 "@samp{-inf.0}. Otherwise return @code{#f}.")
682 #define FUNC_NAME s_scm_inf_p
685 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
686 else if (scm_is_real (x
))
689 return scm_wta_dispatch_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
693 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
695 "Return @code{#t} if the real number @var{x} is a NaN,\n"
696 "or @code{#f} otherwise.")
697 #define FUNC_NAME s_scm_nan_p
700 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
701 else if (scm_is_real (x
))
704 return scm_wta_dispatch_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
708 /* Guile's idea of infinity. */
709 static double guile_Inf
;
711 /* Guile's idea of not a number. */
712 static double guile_NaN
;
715 guile_ieee_init (void)
717 /* Some version of gcc on some old version of Linux used to crash when
718 trying to make Inf and NaN. */
721 /* C99 INFINITY, when available.
722 FIXME: The standard allows for INFINITY to be something that overflows
723 at compile time. We ought to have a configure test to check for that
724 before trying to use it. (But in practice we believe this is not a
725 problem on any system guile is likely to target.) */
726 guile_Inf
= INFINITY
;
727 #elif defined HAVE_DINFINITY
729 extern unsigned int DINFINITY
[2];
730 guile_Inf
= (*((double *) (DINFINITY
)));
737 if (guile_Inf
== tmp
)
744 /* C99 NAN, when available */
746 #elif defined HAVE_DQNAN
749 extern unsigned int DQNAN
[2];
750 guile_NaN
= (*((double *)(DQNAN
)));
753 guile_NaN
= guile_Inf
/ guile_Inf
;
757 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
760 #define FUNC_NAME s_scm_inf
762 static int initialized
= 0;
768 return scm_from_double (guile_Inf
);
772 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
775 #define FUNC_NAME s_scm_nan
777 static int initialized
= 0;
783 return scm_from_double (guile_NaN
);
788 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
790 "Return the absolute value of @var{x}.")
791 #define FUNC_NAME s_scm_abs
795 scm_t_inum xx
= SCM_I_INUM (x
);
798 else if (SCM_POSFIXABLE (-xx
))
799 return SCM_I_MAKINUM (-xx
);
801 return scm_i_inum2big (-xx
);
803 else if (SCM_LIKELY (SCM_REALP (x
)))
805 double xx
= SCM_REAL_VALUE (x
);
806 /* If x is a NaN then xx<0 is false so we return x unchanged */
808 return scm_from_double (-xx
);
809 /* Handle signed zeroes properly */
810 else if (SCM_UNLIKELY (xx
== 0.0))
815 else if (SCM_BIGP (x
))
817 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
819 return scm_i_clonebig (x
, 0);
823 else if (SCM_FRACTIONP (x
))
825 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
827 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
828 SCM_FRACTION_DENOMINATOR (x
));
831 return scm_wta_dispatch_1 (g_scm_abs
, x
, 1, s_scm_abs
);
836 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
838 "Return the quotient of the numbers @var{x} and @var{y}.")
839 #define FUNC_NAME s_scm_quotient
841 if (SCM_LIKELY (scm_is_integer (x
)))
843 if (SCM_LIKELY (scm_is_integer (y
)))
844 return scm_truncate_quotient (x
, y
);
846 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
849 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
853 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
855 "Return the remainder of the numbers @var{x} and @var{y}.\n"
857 "(remainder 13 4) @result{} 1\n"
858 "(remainder -13 4) @result{} -1\n"
860 #define FUNC_NAME s_scm_remainder
862 if (SCM_LIKELY (scm_is_integer (x
)))
864 if (SCM_LIKELY (scm_is_integer (y
)))
865 return scm_truncate_remainder (x
, y
);
867 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
870 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
875 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
877 "Return the modulo of the numbers @var{x} and @var{y}.\n"
879 "(modulo 13 4) @result{} 1\n"
880 "(modulo -13 4) @result{} 3\n"
882 #define FUNC_NAME s_scm_modulo
884 if (SCM_LIKELY (scm_is_integer (x
)))
886 if (SCM_LIKELY (scm_is_integer (y
)))
887 return scm_floor_remainder (x
, y
);
889 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
892 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
896 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
897 two-valued functions. It is called from primitive generics that take
898 two arguments and return two values, when the core procedure is
899 unable to handle the given argument types. If there are GOOPS
900 methods for this primitive generic, it dispatches to GOOPS and, if
901 successful, expects two values to be returned, which are placed in
902 *rp1 and *rp2. If there are no GOOPS methods, it throws a
903 wrong-type-arg exception.
905 FIXME: This obviously belongs somewhere else, but until we decide on
906 the right API, it is here as a static function, because it is needed
907 by the *_divide functions below.
910 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
911 const char *subr
, SCM
*rp1
, SCM
*rp2
)
913 SCM vals
= scm_wta_dispatch_2 (gf
, a1
, a2
, pos
, subr
);
915 scm_i_extract_values_2 (vals
, rp1
, rp2
);
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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1110 s_scm_floor_quotient
);
1113 return 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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1265 s_scm_floor_remainder
);
1268 return 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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1643 s_scm_ceiling_quotient
);
1646 return 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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1808 s_scm_ceiling_remainder
);
1811 return 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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2175 s_scm_truncate_quotient
);
2178 return 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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2303 s_scm_truncate_remainder
);
2306 return 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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2665 s_scm_centered_quotient
);
2668 return 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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2871 s_scm_centered_remainder
);
2874 return 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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3363 s_scm_round_quotient
);
3366 return 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 return 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 return 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 return 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 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3564 s_scm_round_remainder
);
3567 return 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
)
3896 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3898 if (SCM_I_INUMP (x
))
3900 if (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
;
3915 /* Determine a common factor 2^k */
3916 while (!(1 & (u
| v
)))
3922 /* Now, any factor 2^n can be eliminated */
3942 return (SCM_POSFIXABLE (result
)
3943 ? SCM_I_MAKINUM (result
)
3944 : scm_i_inum2big (result
));
3946 else if (SCM_BIGP (y
))
3952 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3954 else if (SCM_BIGP (x
))
3956 if (SCM_I_INUMP (y
))
3961 yy
= SCM_I_INUM (y
);
3966 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3967 scm_remember_upto_here_1 (x
);
3968 return (SCM_POSFIXABLE (result
)
3969 ? SCM_I_MAKINUM (result
)
3970 : scm_from_unsigned_integer (result
));
3972 else if (SCM_BIGP (y
))
3974 SCM result
= scm_i_mkbig ();
3975 mpz_gcd (SCM_I_BIG_MPZ (result
),
3978 scm_remember_upto_here_2 (x
, y
);
3979 return scm_i_normbig (result
);
3982 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3985 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3988 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3989 (SCM x
, SCM y
, SCM rest
),
3990 "Return the least common multiple of the arguments.\n"
3991 "If called without arguments, 1 is returned.")
3992 #define FUNC_NAME s_scm_i_lcm
3994 while (!scm_is_null (rest
))
3995 { x
= scm_lcm (x
, y
);
3997 rest
= scm_cdr (rest
);
3999 return scm_lcm (x
, y
);
4003 #define s_lcm s_scm_i_lcm
4004 #define g_lcm g_scm_i_lcm
4007 scm_lcm (SCM n1
, SCM n2
)
4009 if (SCM_UNBNDP (n2
))
4011 if (SCM_UNBNDP (n1
))
4012 return SCM_I_MAKINUM (1L);
4013 n2
= SCM_I_MAKINUM (1L);
4016 if (SCM_UNLIKELY (!(SCM_I_INUMP (n1
) || SCM_BIGP (n1
))))
4017 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4019 if (SCM_UNLIKELY (!(SCM_I_INUMP (n2
) || SCM_BIGP (n2
))))
4020 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4022 if (SCM_I_INUMP (n1
))
4024 if (SCM_I_INUMP (n2
))
4026 SCM d
= scm_gcd (n1
, n2
);
4027 if (scm_is_eq (d
, SCM_INUM0
))
4030 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4034 /* inum n1, big n2 */
4037 SCM result
= scm_i_mkbig ();
4038 scm_t_inum nn1
= SCM_I_INUM (n1
);
4039 if (nn1
== 0) return SCM_INUM0
;
4040 if (nn1
< 0) nn1
= - nn1
;
4041 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4042 scm_remember_upto_here_1 (n2
);
4050 if (SCM_I_INUMP (n2
))
4057 SCM result
= scm_i_mkbig ();
4058 mpz_lcm(SCM_I_BIG_MPZ (result
),
4060 SCM_I_BIG_MPZ (n2
));
4061 scm_remember_upto_here_2(n1
, n2
);
4062 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4068 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4073 + + + x (map digit:logand X Y)
4074 + - + x (map digit:logand X (lognot (+ -1 Y)))
4075 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4076 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4081 + + + (map digit:logior X Y)
4082 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4083 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4084 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4089 + + + (map digit:logxor X Y)
4090 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4091 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4092 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4097 + + (any digit:logand X Y)
4098 + - (any digit:logand X (lognot (+ -1 Y)))
4099 - + (any digit:logand (lognot (+ -1 X)) Y)
4104 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4105 (SCM x
, SCM y
, SCM rest
),
4106 "Return the bitwise AND of the integer arguments.\n\n"
4108 "(logand) @result{} -1\n"
4109 "(logand 7) @result{} 7\n"
4110 "(logand #b111 #b011 #b001) @result{} 1\n"
4112 #define FUNC_NAME s_scm_i_logand
4114 while (!scm_is_null (rest
))
4115 { x
= scm_logand (x
, y
);
4117 rest
= scm_cdr (rest
);
4119 return scm_logand (x
, y
);
4123 #define s_scm_logand s_scm_i_logand
4125 SCM
scm_logand (SCM n1
, SCM n2
)
4126 #define FUNC_NAME s_scm_logand
4130 if (SCM_UNBNDP (n2
))
4132 if (SCM_UNBNDP (n1
))
4133 return SCM_I_MAKINUM (-1);
4134 else if (!SCM_NUMBERP (n1
))
4135 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4136 else if (SCM_NUMBERP (n1
))
4139 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4142 if (SCM_I_INUMP (n1
))
4144 nn1
= SCM_I_INUM (n1
);
4145 if (SCM_I_INUMP (n2
))
4147 scm_t_inum nn2
= SCM_I_INUM (n2
);
4148 return SCM_I_MAKINUM (nn1
& nn2
);
4150 else if SCM_BIGP (n2
)
4156 SCM result_z
= scm_i_mkbig ();
4158 mpz_init_set_si (nn1_z
, nn1
);
4159 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4160 scm_remember_upto_here_1 (n2
);
4162 return scm_i_normbig (result_z
);
4166 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4168 else if (SCM_BIGP (n1
))
4170 if (SCM_I_INUMP (n2
))
4173 nn1
= SCM_I_INUM (n1
);
4176 else if (SCM_BIGP (n2
))
4178 SCM result_z
= scm_i_mkbig ();
4179 mpz_and (SCM_I_BIG_MPZ (result_z
),
4181 SCM_I_BIG_MPZ (n2
));
4182 scm_remember_upto_here_2 (n1
, n2
);
4183 return scm_i_normbig (result_z
);
4186 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4189 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4194 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4195 (SCM x
, SCM y
, SCM rest
),
4196 "Return the bitwise OR of the integer arguments.\n\n"
4198 "(logior) @result{} 0\n"
4199 "(logior 7) @result{} 7\n"
4200 "(logior #b000 #b001 #b011) @result{} 3\n"
4202 #define FUNC_NAME s_scm_i_logior
4204 while (!scm_is_null (rest
))
4205 { x
= scm_logior (x
, y
);
4207 rest
= scm_cdr (rest
);
4209 return scm_logior (x
, y
);
4213 #define s_scm_logior s_scm_i_logior
4215 SCM
scm_logior (SCM n1
, SCM n2
)
4216 #define FUNC_NAME s_scm_logior
4220 if (SCM_UNBNDP (n2
))
4222 if (SCM_UNBNDP (n1
))
4224 else if (SCM_NUMBERP (n1
))
4227 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4230 if (SCM_I_INUMP (n1
))
4232 nn1
= SCM_I_INUM (n1
);
4233 if (SCM_I_INUMP (n2
))
4235 long nn2
= SCM_I_INUM (n2
);
4236 return SCM_I_MAKINUM (nn1
| nn2
);
4238 else if (SCM_BIGP (n2
))
4244 SCM result_z
= scm_i_mkbig ();
4246 mpz_init_set_si (nn1_z
, nn1
);
4247 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4248 scm_remember_upto_here_1 (n2
);
4250 return scm_i_normbig (result_z
);
4254 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4256 else if (SCM_BIGP (n1
))
4258 if (SCM_I_INUMP (n2
))
4261 nn1
= SCM_I_INUM (n1
);
4264 else if (SCM_BIGP (n2
))
4266 SCM result_z
= scm_i_mkbig ();
4267 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4269 SCM_I_BIG_MPZ (n2
));
4270 scm_remember_upto_here_2 (n1
, n2
);
4271 return scm_i_normbig (result_z
);
4274 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4277 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4282 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4283 (SCM x
, SCM y
, SCM rest
),
4284 "Return the bitwise XOR of the integer arguments. A bit is\n"
4285 "set in the result if it is set in an odd number of arguments.\n"
4287 "(logxor) @result{} 0\n"
4288 "(logxor 7) @result{} 7\n"
4289 "(logxor #b000 #b001 #b011) @result{} 2\n"
4290 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4292 #define FUNC_NAME s_scm_i_logxor
4294 while (!scm_is_null (rest
))
4295 { x
= scm_logxor (x
, y
);
4297 rest
= scm_cdr (rest
);
4299 return scm_logxor (x
, y
);
4303 #define s_scm_logxor s_scm_i_logxor
4305 SCM
scm_logxor (SCM n1
, SCM n2
)
4306 #define FUNC_NAME s_scm_logxor
4310 if (SCM_UNBNDP (n2
))
4312 if (SCM_UNBNDP (n1
))
4314 else if (SCM_NUMBERP (n1
))
4317 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4320 if (SCM_I_INUMP (n1
))
4322 nn1
= SCM_I_INUM (n1
);
4323 if (SCM_I_INUMP (n2
))
4325 scm_t_inum nn2
= SCM_I_INUM (n2
);
4326 return SCM_I_MAKINUM (nn1
^ nn2
);
4328 else if (SCM_BIGP (n2
))
4332 SCM result_z
= scm_i_mkbig ();
4334 mpz_init_set_si (nn1_z
, nn1
);
4335 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4336 scm_remember_upto_here_1 (n2
);
4338 return scm_i_normbig (result_z
);
4342 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4344 else if (SCM_BIGP (n1
))
4346 if (SCM_I_INUMP (n2
))
4349 nn1
= SCM_I_INUM (n1
);
4352 else if (SCM_BIGP (n2
))
4354 SCM result_z
= scm_i_mkbig ();
4355 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4357 SCM_I_BIG_MPZ (n2
));
4358 scm_remember_upto_here_2 (n1
, n2
);
4359 return scm_i_normbig (result_z
);
4362 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4365 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4370 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4372 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4373 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4374 "without actually calculating the @code{logand}, just testing\n"
4378 "(logtest #b0100 #b1011) @result{} #f\n"
4379 "(logtest #b0100 #b0111) @result{} #t\n"
4381 #define FUNC_NAME s_scm_logtest
4385 if (SCM_I_INUMP (j
))
4387 nj
= SCM_I_INUM (j
);
4388 if (SCM_I_INUMP (k
))
4390 scm_t_inum nk
= SCM_I_INUM (k
);
4391 return scm_from_bool (nj
& nk
);
4393 else if (SCM_BIGP (k
))
4401 mpz_init_set_si (nj_z
, nj
);
4402 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4403 scm_remember_upto_here_1 (k
);
4404 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4410 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4412 else if (SCM_BIGP (j
))
4414 if (SCM_I_INUMP (k
))
4417 nj
= SCM_I_INUM (j
);
4420 else if (SCM_BIGP (k
))
4424 mpz_init (result_z
);
4428 scm_remember_upto_here_2 (j
, k
);
4429 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4430 mpz_clear (result_z
);
4434 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4437 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4442 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4444 "Test whether bit number @var{index} in @var{j} is set.\n"
4445 "@var{index} starts from 0 for the least significant bit.\n"
4448 "(logbit? 0 #b1101) @result{} #t\n"
4449 "(logbit? 1 #b1101) @result{} #f\n"
4450 "(logbit? 2 #b1101) @result{} #t\n"
4451 "(logbit? 3 #b1101) @result{} #t\n"
4452 "(logbit? 4 #b1101) @result{} #f\n"
4454 #define FUNC_NAME s_scm_logbit_p
4456 unsigned long int iindex
;
4457 iindex
= scm_to_ulong (index
);
4459 if (SCM_I_INUMP (j
))
4461 /* bits above what's in an inum follow the sign bit */
4462 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4463 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4465 else if (SCM_BIGP (j
))
4467 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4468 scm_remember_upto_here_1 (j
);
4469 return scm_from_bool (val
);
4472 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4477 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4479 "Return the integer which is the ones-complement of the integer\n"
4483 "(number->string (lognot #b10000000) 2)\n"
4484 " @result{} \"-10000001\"\n"
4485 "(number->string (lognot #b0) 2)\n"
4486 " @result{} \"-1\"\n"
4488 #define FUNC_NAME s_scm_lognot
4490 if (SCM_I_INUMP (n
)) {
4491 /* No overflow here, just need to toggle all the bits making up the inum.
4492 Enhancement: No need to strip the tag and add it back, could just xor
4493 a block of 1 bits, if that worked with the various debug versions of
4495 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4497 } else if (SCM_BIGP (n
)) {
4498 SCM result
= scm_i_mkbig ();
4499 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4500 scm_remember_upto_here_1 (n
);
4504 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4509 /* returns 0 if IN is not an integer. OUT must already be
4512 coerce_to_big (SCM in
, mpz_t out
)
4515 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4516 else if (SCM_I_INUMP (in
))
4517 mpz_set_si (out
, SCM_I_INUM (in
));
4524 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4525 (SCM n
, SCM k
, SCM m
),
4526 "Return @var{n} raised to the integer exponent\n"
4527 "@var{k}, modulo @var{m}.\n"
4530 "(modulo-expt 2 3 5)\n"
4533 #define FUNC_NAME s_scm_modulo_expt
4539 /* There are two classes of error we might encounter --
4540 1) Math errors, which we'll report by calling scm_num_overflow,
4542 2) wrong-type errors, which of course we'll report by calling
4544 We don't report those errors immediately, however; instead we do
4545 some cleanup first. These variables tell us which error (if
4546 any) we should report after cleaning up.
4548 int report_overflow
= 0;
4550 int position_of_wrong_type
= 0;
4551 SCM value_of_wrong_type
= SCM_INUM0
;
4553 SCM result
= SCM_UNDEFINED
;
4559 if (scm_is_eq (m
, SCM_INUM0
))
4561 report_overflow
= 1;
4565 if (!coerce_to_big (n
, n_tmp
))
4567 value_of_wrong_type
= n
;
4568 position_of_wrong_type
= 1;
4572 if (!coerce_to_big (k
, k_tmp
))
4574 value_of_wrong_type
= k
;
4575 position_of_wrong_type
= 2;
4579 if (!coerce_to_big (m
, m_tmp
))
4581 value_of_wrong_type
= m
;
4582 position_of_wrong_type
= 3;
4586 /* if the exponent K is negative, and we simply call mpz_powm, we
4587 will get a divide-by-zero exception when an inverse 1/n mod m
4588 doesn't exist (or is not unique). Since exceptions are hard to
4589 handle, we'll attempt the inversion "by hand" -- that way, we get
4590 a simple failure code, which is easy to handle. */
4592 if (-1 == mpz_sgn (k_tmp
))
4594 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4596 report_overflow
= 1;
4599 mpz_neg (k_tmp
, k_tmp
);
4602 result
= scm_i_mkbig ();
4603 mpz_powm (SCM_I_BIG_MPZ (result
),
4608 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4609 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4616 if (report_overflow
)
4617 scm_num_overflow (FUNC_NAME
);
4619 if (position_of_wrong_type
)
4620 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4621 value_of_wrong_type
);
4623 return scm_i_normbig (result
);
4627 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4629 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4630 "exact integer, @var{n} can be any number.\n"
4632 "Negative @var{k} is supported, and results in\n"
4633 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4634 "@math{@var{n}^0} is 1, as usual, and that\n"
4635 "includes @math{0^0} is 1.\n"
4638 "(integer-expt 2 5) @result{} 32\n"
4639 "(integer-expt -3 3) @result{} -27\n"
4640 "(integer-expt 5 -3) @result{} 1/125\n"
4641 "(integer-expt 0 0) @result{} 1\n"
4643 #define FUNC_NAME s_scm_integer_expt
4646 SCM z_i2
= SCM_BOOL_F
;
4648 SCM acc
= SCM_I_MAKINUM (1L);
4650 /* Specifically refrain from checking the type of the first argument.
4651 This allows us to exponentiate any object that can be multiplied.
4652 If we must raise to a negative power, we must also be able to
4653 take its reciprocal. */
4654 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4655 SCM_WRONG_TYPE_ARG (2, k
);
4657 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4658 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4659 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4660 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4661 /* The next check is necessary only because R6RS specifies different
4662 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4663 we simply skip this case and move on. */
4664 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4666 /* k cannot be 0 at this point, because we
4667 have already checked for that case above */
4668 if (scm_is_true (scm_positive_p (k
)))
4670 else /* return NaN for (0 ^ k) for negative k per R6RS */
4674 if (SCM_I_INUMP (k
))
4675 i2
= SCM_I_INUM (k
);
4676 else if (SCM_BIGP (k
))
4678 z_i2
= scm_i_clonebig (k
, 1);
4679 scm_remember_upto_here_1 (k
);
4683 SCM_WRONG_TYPE_ARG (2, k
);
4687 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4689 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4690 n
= scm_divide (n
, SCM_UNDEFINED
);
4694 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4698 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4700 return scm_product (acc
, n
);
4702 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4703 acc
= scm_product (acc
, n
);
4704 n
= scm_product (n
, n
);
4705 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4713 n
= scm_divide (n
, SCM_UNDEFINED
);
4720 return scm_product (acc
, n
);
4722 acc
= scm_product (acc
, n
);
4723 n
= scm_product (n
, n
);
4730 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4732 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4733 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4735 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4736 "@var{cnt} is negative it's a division, rounded towards negative\n"
4737 "infinity. (Note that this is not the same rounding as\n"
4738 "@code{quotient} does.)\n"
4740 "With @var{n} viewed as an infinite precision twos complement,\n"
4741 "@code{ash} means a left shift introducing zero bits, or a right\n"
4742 "shift dropping bits.\n"
4745 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4746 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4748 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4749 "(ash -23 -2) @result{} -6\n"
4751 #define FUNC_NAME s_scm_ash
4754 bits_to_shift
= scm_to_long (cnt
);
4756 if (SCM_I_INUMP (n
))
4758 scm_t_inum nn
= SCM_I_INUM (n
);
4760 if (bits_to_shift
> 0)
4762 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4763 overflow a non-zero fixnum. For smaller shifts we check the
4764 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4765 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4766 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4772 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4774 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4777 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4781 SCM result
= scm_i_inum2big (nn
);
4782 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4789 bits_to_shift
= -bits_to_shift
;
4790 if (bits_to_shift
>= SCM_LONG_BIT
)
4791 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4793 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4797 else if (SCM_BIGP (n
))
4801 if (bits_to_shift
== 0)
4804 result
= scm_i_mkbig ();
4805 if (bits_to_shift
>= 0)
4807 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4813 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4814 we have to allocate a bignum even if the result is going to be a
4816 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4818 return scm_i_normbig (result
);
4824 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4830 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4831 (SCM n
, SCM start
, SCM end
),
4832 "Return the integer composed of the @var{start} (inclusive)\n"
4833 "through @var{end} (exclusive) bits of @var{n}. The\n"
4834 "@var{start}th bit becomes the 0-th bit in the result.\n"
4837 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4838 " @result{} \"1010\"\n"
4839 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4840 " @result{} \"10110\"\n"
4842 #define FUNC_NAME s_scm_bit_extract
4844 unsigned long int istart
, iend
, bits
;
4845 istart
= scm_to_ulong (start
);
4846 iend
= scm_to_ulong (end
);
4847 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4849 /* how many bits to keep */
4850 bits
= iend
- istart
;
4852 if (SCM_I_INUMP (n
))
4854 scm_t_inum in
= SCM_I_INUM (n
);
4856 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4857 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4858 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4860 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4862 /* Since we emulate two's complement encoded numbers, this
4863 * special case requires us to produce a result that has
4864 * more bits than can be stored in a fixnum.
4866 SCM result
= scm_i_inum2big (in
);
4867 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4872 /* mask down to requisite bits */
4873 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4874 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4876 else if (SCM_BIGP (n
))
4881 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4885 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4886 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4887 such bits into a ulong. */
4888 result
= scm_i_mkbig ();
4889 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4890 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4891 result
= scm_i_normbig (result
);
4893 scm_remember_upto_here_1 (n
);
4897 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4902 static const char scm_logtab
[] = {
4903 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4906 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4908 "Return the number of bits in integer @var{n}. If integer is\n"
4909 "positive, the 1-bits in its binary representation are counted.\n"
4910 "If negative, the 0-bits in its two's-complement binary\n"
4911 "representation are counted. If 0, 0 is returned.\n"
4914 "(logcount #b10101010)\n"
4921 #define FUNC_NAME s_scm_logcount
4923 if (SCM_I_INUMP (n
))
4925 unsigned long c
= 0;
4926 scm_t_inum nn
= SCM_I_INUM (n
);
4931 c
+= scm_logtab
[15 & nn
];
4934 return SCM_I_MAKINUM (c
);
4936 else if (SCM_BIGP (n
))
4938 unsigned long count
;
4939 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4940 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4942 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4943 scm_remember_upto_here_1 (n
);
4944 return SCM_I_MAKINUM (count
);
4947 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4952 static const char scm_ilentab
[] = {
4953 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4957 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4959 "Return the number of bits necessary to represent @var{n}.\n"
4962 "(integer-length #b10101010)\n"
4964 "(integer-length 0)\n"
4966 "(integer-length #b1111)\n"
4969 #define FUNC_NAME s_scm_integer_length
4971 if (SCM_I_INUMP (n
))
4973 unsigned long c
= 0;
4975 scm_t_inum nn
= SCM_I_INUM (n
);
4981 l
= scm_ilentab
[15 & nn
];
4984 return SCM_I_MAKINUM (c
- 4 + l
);
4986 else if (SCM_BIGP (n
))
4988 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4989 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4990 1 too big, so check for that and adjust. */
4991 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4992 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4993 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4994 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4996 scm_remember_upto_here_1 (n
);
4997 return SCM_I_MAKINUM (size
);
5000 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5004 /*** NUMBERS -> STRINGS ***/
5005 #define SCM_MAX_DBL_PREC 60
5006 #define SCM_MAX_DBL_RADIX 36
5008 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
5009 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
5010 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
5013 void init_dblprec(int *prec
, int radix
) {
5014 /* determine floating point precision by adding successively
5015 smaller increments to 1.0 until it is considered == 1.0 */
5016 double f
= ((double)1.0)/radix
;
5017 double fsum
= 1.0 + f
;
5022 if (++(*prec
) > SCM_MAX_DBL_PREC
)
5034 void init_fx_radix(double *fx_list
, int radix
)
5036 /* initialize a per-radix list of tolerances. When added
5037 to a number < 1.0, we can determine if we should raund
5038 up and quit converting a number to a string. */
5042 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5043 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5046 /* use this array as a way to generate a single digit */
5047 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5050 idbl2str (double f
, char *a
, int radix
)
5052 int efmt
, dpt
, d
, i
, wp
;
5054 #ifdef DBL_MIN_10_EXP
5057 #endif /* DBL_MIN_10_EXP */
5062 radix
> SCM_MAX_DBL_RADIX
)
5064 /* revert to existing behavior */
5068 wp
= scm_dblprec
[radix
-2];
5069 fx
= fx_per_radix
[radix
-2];
5073 #ifdef HAVE_COPYSIGN
5074 double sgn
= copysign (1.0, f
);
5079 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5085 strcpy (a
, "-inf.0");
5087 strcpy (a
, "+inf.0");
5092 strcpy (a
, "+nan.0");
5102 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5103 make-uniform-vector, from causing infinite loops. */
5104 /* just do the checking...if it passes, we do the conversion for our
5105 radix again below */
5112 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5120 while (f_cpy
> 10.0)
5123 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5144 if (f
+ fx
[wp
] >= radix
)
5150 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5171 a
[ch
++] = number_chars
[d
];
5174 if (f
+ fx
[wp
] >= 1.0)
5176 a
[ch
- 1] = number_chars
[d
+1];
5187 if ((dpt
> 4) && (exp
> 6))
5189 d
= (a
[0] == '-' ? 2 : 1);
5190 for (i
= ch
++; i
> d
; i
--)
5202 if (a
[ch
- 1] == '.')
5203 a
[ch
++] = '0'; /* trailing zero */
5212 for (i
= radix
; i
<= exp
; i
*= radix
);
5213 for (i
/= radix
; i
; i
/= radix
)
5215 a
[ch
++] = number_chars
[exp
/ i
];
5224 icmplx2str (double real
, double imag
, char *str
, int radix
)
5229 i
= idbl2str (real
, str
, radix
);
5230 #ifdef HAVE_COPYSIGN
5231 sgn
= copysign (1.0, imag
);
5235 /* Don't output a '+' for negative numbers or for Inf and
5236 NaN. They will provide their own sign. */
5237 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5239 i
+= idbl2str (imag
, &str
[i
], radix
);
5245 iflo2str (SCM flt
, char *str
, int radix
)
5248 if (SCM_REALP (flt
))
5249 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5251 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5256 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5257 characters in the result.
5259 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5261 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5266 return scm_iuint2str (-num
, rad
, p
) + 1;
5269 return scm_iuint2str (num
, rad
, p
);
5272 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5273 characters in the result.
5275 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5277 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5281 scm_t_uintmax n
= num
;
5283 if (rad
< 2 || rad
> 36)
5284 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5286 for (n
/= rad
; n
> 0; n
/= rad
)
5296 p
[i
] = number_chars
[d
];
5301 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5303 "Return a string holding the external representation of the\n"
5304 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5305 "inexact, a radix of 10 will be used.")
5306 #define FUNC_NAME s_scm_number_to_string
5310 if (SCM_UNBNDP (radix
))
5313 base
= scm_to_signed_integer (radix
, 2, 36);
5315 if (SCM_I_INUMP (n
))
5317 char num_buf
[SCM_INTBUFLEN
];
5318 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5319 return scm_from_locale_stringn (num_buf
, length
);
5321 else if (SCM_BIGP (n
))
5323 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5324 size_t len
= strlen (str
);
5325 void (*freefunc
) (void *, size_t);
5327 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5328 scm_remember_upto_here_1 (n
);
5329 ret
= scm_from_latin1_stringn (str
, len
);
5330 freefunc (str
, len
+ 1);
5333 else if (SCM_FRACTIONP (n
))
5335 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5336 scm_from_locale_string ("/"),
5337 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5339 else if (SCM_INEXACTP (n
))
5341 char num_buf
[FLOBUFLEN
];
5342 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5345 SCM_WRONG_TYPE_ARG (1, n
);
5350 /* These print routines used to be stubbed here so that scm_repl.c
5351 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5354 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5356 char num_buf
[FLOBUFLEN
];
5357 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5362 scm_i_print_double (double val
, SCM port
)
5364 char num_buf
[FLOBUFLEN
];
5365 scm_lfwrite_unlocked (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5369 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5372 char num_buf
[FLOBUFLEN
];
5373 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5378 scm_i_print_complex (double real
, double imag
, SCM port
)
5380 char num_buf
[FLOBUFLEN
];
5381 scm_lfwrite_unlocked (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5385 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5388 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5389 scm_display (str
, port
);
5390 scm_remember_upto_here_1 (str
);
5395 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5397 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5398 size_t len
= strlen (str
);
5399 void (*freefunc
) (void *, size_t);
5400 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5401 scm_remember_upto_here_1 (exp
);
5402 scm_lfwrite_unlocked (str
, len
, port
);
5403 freefunc (str
, len
+ 1);
5406 /*** END nums->strs ***/
5409 /*** STRINGS -> NUMBERS ***/
5411 /* The following functions implement the conversion from strings to numbers.
5412 * The implementation somehow follows the grammar for numbers as it is given
5413 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5414 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5415 * points should be noted about the implementation:
5417 * * Each function keeps a local index variable 'idx' that points at the
5418 * current position within the parsed string. The global index is only
5419 * updated if the function could parse the corresponding syntactic unit
5422 * * Similarly, the functions keep track of indicators of inexactness ('#',
5423 * '.' or exponents) using local variables ('hash_seen', 'x').
5425 * * Sequences of digits are parsed into temporary variables holding fixnums.
5426 * Only if these fixnums would overflow, the result variables are updated
5427 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5428 * the temporary variables holding the fixnums are cleared, and the process
5429 * starts over again. If for example fixnums were able to store five decimal
5430 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5431 * and the result was computed as 12345 * 100000 + 67890. In other words,
5432 * only every five digits two bignum operations were performed.
5434 * Notes on the handling of exactness specifiers:
5436 * When parsing non-real complex numbers, we apply exactness specifiers on
5437 * per-component basis, as is done in PLT Scheme. For complex numbers
5438 * written in rectangular form, exactness specifiers are applied to the
5439 * real and imaginary parts before calling scm_make_rectangular. For
5440 * complex numbers written in polar form, exactness specifiers are applied
5441 * to the magnitude and angle before calling scm_make_polar.
5443 * There are two kinds of exactness specifiers: forced and implicit. A
5444 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5445 * the entire number, and applies to both components of a complex number.
5446 * "#e" causes each component to be made exact, and "#i" causes each
5447 * component to be made inexact. If no forced exactness specifier is
5448 * present, then the exactness of each component is determined
5449 * independently by the presence or absence of a decimal point or hash mark
5450 * within that component. If a decimal point or hash mark is present, the
5451 * component is made inexact, otherwise it is made exact.
5453 * After the exactness specifiers have been applied to each component, they
5454 * are passed to either scm_make_rectangular or scm_make_polar to produce
5455 * the final result. Note that this will result in a real number if the
5456 * imaginary part, magnitude, or angle is an exact 0.
5458 * For example, (string->number "#i5.0+0i") does the equivalent of:
5460 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5463 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5465 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5467 /* Caller is responsible for checking that the return value is in range
5468 for the given radix, which should be <= 36. */
5470 char_decimal_value (scm_t_uint32 c
)
5472 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5473 that's certainly above any valid decimal, so we take advantage of
5474 that to elide some tests. */
5475 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5477 /* If that failed, try extended hexadecimals, then. Only accept ascii
5482 if (c
>= (scm_t_uint32
) 'a')
5483 d
= c
- (scm_t_uint32
)'a' + 10U;
5488 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5489 in base RADIX. Upon success, return the unsigned integer and update
5490 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5492 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5493 unsigned int radix
, enum t_exactness
*p_exactness
)
5495 unsigned int idx
= *p_idx
;
5496 unsigned int hash_seen
= 0;
5497 scm_t_bits shift
= 1;
5499 unsigned int digit_value
;
5502 size_t len
= scm_i_string_length (mem
);
5507 c
= scm_i_string_ref (mem
, idx
);
5508 digit_value
= char_decimal_value (c
);
5509 if (digit_value
>= radix
)
5513 result
= SCM_I_MAKINUM (digit_value
);
5516 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5526 digit_value
= char_decimal_value (c
);
5527 /* This check catches non-decimals in addition to out-of-range
5529 if (digit_value
>= radix
)
5534 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5536 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5538 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5545 shift
= shift
* radix
;
5546 add
= add
* radix
+ digit_value
;
5551 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5553 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5557 *p_exactness
= INEXACT
;
5563 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5564 * covers the parts of the rules that start at a potential point. The value
5565 * of the digits up to the point have been parsed by the caller and are given
5566 * in variable result. The content of *p_exactness indicates, whether a hash
5567 * has already been seen in the digits before the point.
5570 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5573 mem2decimal_from_point (SCM result
, SCM mem
,
5574 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5576 unsigned int idx
= *p_idx
;
5577 enum t_exactness x
= *p_exactness
;
5578 size_t len
= scm_i_string_length (mem
);
5583 if (scm_i_string_ref (mem
, idx
) == '.')
5585 scm_t_bits shift
= 1;
5587 unsigned int digit_value
;
5588 SCM big_shift
= SCM_INUM1
;
5593 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5594 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5599 digit_value
= DIGIT2UINT (c
);
5610 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5612 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5613 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5615 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5623 add
= add
* 10 + digit_value
;
5629 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5630 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5631 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5634 result
= scm_divide (result
, big_shift
);
5636 /* We've seen a decimal point, thus the value is implicitly inexact. */
5648 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5650 switch (scm_i_string_ref (mem
, idx
))
5662 c
= scm_i_string_ref (mem
, idx
);
5670 c
= scm_i_string_ref (mem
, idx
);
5679 c
= scm_i_string_ref (mem
, idx
);
5684 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5688 exponent
= DIGIT2UINT (c
);
5691 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5692 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5695 if (exponent
<= SCM_MAXEXP
)
5696 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5702 if (exponent
> SCM_MAXEXP
)
5704 size_t exp_len
= idx
- start
;
5705 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5706 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5707 scm_out_of_range ("string->number", exp_num
);
5710 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5712 result
= scm_product (result
, e
);
5714 result
= scm_divide (result
, e
);
5716 /* We've seen an exponent, thus the value is implicitly inexact. */
5734 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5737 mem2ureal (SCM mem
, unsigned int *p_idx
,
5738 unsigned int radix
, enum t_exactness forced_x
)
5740 unsigned int idx
= *p_idx
;
5742 size_t len
= scm_i_string_length (mem
);
5744 /* Start off believing that the number will be exact. This changes
5745 to INEXACT if we see a decimal point or a hash. */
5746 enum t_exactness implicit_x
= EXACT
;
5751 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5757 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5759 /* Cobble up the fractional part. We might want to set the
5760 NaN's mantissa from it. */
5762 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
), SCM_INUM0
))
5764 #if SCM_ENABLE_DEPRECATED == 1
5765 scm_c_issue_deprecation_warning
5766 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5776 if (scm_i_string_ref (mem
, idx
) == '.')
5780 else if (idx
+ 1 == len
)
5782 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5785 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5786 p_idx
, &implicit_x
);
5792 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5793 if (scm_is_false (uinteger
))
5798 else if (scm_i_string_ref (mem
, idx
) == '/')
5806 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5807 if (scm_is_false (divisor
))
5810 /* both are int/big here, I assume */
5811 result
= scm_i_make_ratio (uinteger
, divisor
);
5813 else if (radix
== 10)
5815 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5816 if (scm_is_false (result
))
5828 if (SCM_INEXACTP (result
))
5829 return scm_inexact_to_exact (result
);
5833 if (SCM_INEXACTP (result
))
5836 return scm_exact_to_inexact (result
);
5838 if (implicit_x
== INEXACT
)
5840 if (SCM_INEXACTP (result
))
5843 return scm_exact_to_inexact (result
);
5849 /* We should never get here */
5850 scm_syserror ("mem2ureal");
5854 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5857 mem2complex (SCM mem
, unsigned int idx
,
5858 unsigned int radix
, enum t_exactness forced_x
)
5863 size_t len
= scm_i_string_length (mem
);
5868 c
= scm_i_string_ref (mem
, idx
);
5883 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5884 if (scm_is_false (ureal
))
5886 /* input must be either +i or -i */
5891 if (scm_i_string_ref (mem
, idx
) == 'i'
5892 || scm_i_string_ref (mem
, idx
) == 'I')
5898 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5905 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5906 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5911 c
= scm_i_string_ref (mem
, idx
);
5915 /* either +<ureal>i or -<ureal>i */
5922 return scm_make_rectangular (SCM_INUM0
, ureal
);
5925 /* polar input: <real>@<real>. */
5936 c
= scm_i_string_ref (mem
, idx
);
5954 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5955 if (scm_is_false (angle
))
5960 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5961 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5963 result
= scm_make_polar (ureal
, angle
);
5968 /* expecting input matching <real>[+-]<ureal>?i */
5975 int sign
= (c
== '+') ? 1 : -1;
5976 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5978 if (scm_is_false (imag
))
5979 imag
= SCM_I_MAKINUM (sign
);
5980 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5981 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5985 if (scm_i_string_ref (mem
, idx
) != 'i'
5986 && scm_i_string_ref (mem
, idx
) != 'I')
5993 return scm_make_rectangular (ureal
, imag
);
6002 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6004 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6007 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6009 unsigned int idx
= 0;
6010 unsigned int radix
= NO_RADIX
;
6011 enum t_exactness forced_x
= NO_EXACTNESS
;
6012 size_t len
= scm_i_string_length (mem
);
6014 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6015 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6017 switch (scm_i_string_ref (mem
, idx
+ 1))
6020 if (radix
!= NO_RADIX
)
6025 if (radix
!= NO_RADIX
)
6030 if (forced_x
!= NO_EXACTNESS
)
6035 if (forced_x
!= NO_EXACTNESS
)
6040 if (radix
!= NO_RADIX
)
6045 if (radix
!= NO_RADIX
)
6055 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6056 if (radix
== NO_RADIX
)
6057 radix
= default_radix
;
6059 return mem2complex (mem
, idx
, radix
, forced_x
);
6063 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6064 unsigned int default_radix
)
6066 SCM str
= scm_from_locale_stringn (mem
, len
);
6068 return scm_i_string_to_number (str
, default_radix
);
6072 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6073 (SCM string
, SCM radix
),
6074 "Return a number of the maximally precise representation\n"
6075 "expressed by the given @var{string}. @var{radix} must be an\n"
6076 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6077 "is a default radix that may be overridden by an explicit radix\n"
6078 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6079 "supplied, then the default radix is 10. If string is not a\n"
6080 "syntactically valid notation for a number, then\n"
6081 "@code{string->number} returns @code{#f}.")
6082 #define FUNC_NAME s_scm_string_to_number
6086 SCM_VALIDATE_STRING (1, string
);
6088 if (SCM_UNBNDP (radix
))
6091 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6093 answer
= scm_i_string_to_number (string
, base
);
6094 scm_remember_upto_here_1 (string
);
6100 /*** END strs->nums ***/
6103 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6105 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6107 #define FUNC_NAME s_scm_number_p
6109 return scm_from_bool (SCM_NUMBERP (x
));
6113 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6115 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6116 "otherwise. Note that the sets of real, rational and integer\n"
6117 "values form subsets of the set of complex numbers, i. e. the\n"
6118 "predicate will also be fulfilled if @var{x} is a real,\n"
6119 "rational or integer number.")
6120 #define FUNC_NAME s_scm_complex_p
6122 /* all numbers are complex. */
6123 return scm_number_p (x
);
6127 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6129 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6130 "otherwise. Note that the set of integer values forms a subset of\n"
6131 "the set of real numbers, i. e. the predicate will also be\n"
6132 "fulfilled if @var{x} is an integer number.")
6133 #define FUNC_NAME s_scm_real_p
6135 return scm_from_bool
6136 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6140 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6142 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6143 "otherwise. Note that the set of integer values forms a subset of\n"
6144 "the set of rational numbers, i. e. the predicate will also be\n"
6145 "fulfilled if @var{x} is an integer number.")
6146 #define FUNC_NAME s_scm_rational_p
6148 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6150 else if (SCM_REALP (x
))
6151 /* due to their limited precision, finite floating point numbers are
6152 rational as well. (finite means neither infinity nor a NaN) */
6153 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6159 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6161 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6163 #define FUNC_NAME s_scm_integer_p
6165 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6167 else if (SCM_REALP (x
))
6169 double val
= SCM_REAL_VALUE (x
);
6170 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6178 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6179 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6180 (SCM x
, SCM y
, SCM rest
),
6181 "Return @code{#t} if all parameters are numerically equal.")
6182 #define FUNC_NAME s_scm_i_num_eq_p
6184 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6186 while (!scm_is_null (rest
))
6188 if (scm_is_false (scm_num_eq_p (x
, y
)))
6192 rest
= scm_cdr (rest
);
6194 return scm_num_eq_p (x
, y
);
6198 scm_num_eq_p (SCM x
, SCM y
)
6201 if (SCM_I_INUMP (x
))
6203 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6204 if (SCM_I_INUMP (y
))
6206 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6207 return scm_from_bool (xx
== yy
);
6209 else if (SCM_BIGP (y
))
6211 else if (SCM_REALP (y
))
6213 /* On a 32-bit system an inum fits a double, we can cast the inum
6214 to a double and compare.
6216 But on a 64-bit system an inum is bigger than a double and
6217 casting it to a double (call that dxx) will round. dxx is at
6218 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6219 an integer and fits a long. So we cast yy to a long and
6220 compare with plain xx.
6222 An alternative (for any size system actually) would be to check
6223 yy is an integer (with floor) and is in range of an inum
6224 (compare against appropriate powers of 2) then test
6225 xx==(scm_t_signed_bits)yy. It's just a matter of which
6226 casts/comparisons might be fastest or easiest for the cpu. */
6228 double yy
= SCM_REAL_VALUE (y
);
6229 return scm_from_bool ((double) xx
== yy
6230 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6231 || xx
== (scm_t_signed_bits
) yy
));
6233 else if (SCM_COMPLEXP (y
))
6234 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6235 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6236 else if (SCM_FRACTIONP (y
))
6239 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6242 else if (SCM_BIGP (x
))
6244 if (SCM_I_INUMP (y
))
6246 else if (SCM_BIGP (y
))
6248 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6249 scm_remember_upto_here_2 (x
, y
);
6250 return scm_from_bool (0 == cmp
);
6252 else if (SCM_REALP (y
))
6255 if (isnan (SCM_REAL_VALUE (y
)))
6257 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6258 scm_remember_upto_here_1 (x
);
6259 return scm_from_bool (0 == cmp
);
6261 else if (SCM_COMPLEXP (y
))
6264 if (0.0 != SCM_COMPLEX_IMAG (y
))
6266 if (isnan (SCM_COMPLEX_REAL (y
)))
6268 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6269 scm_remember_upto_here_1 (x
);
6270 return scm_from_bool (0 == cmp
);
6272 else if (SCM_FRACTIONP (y
))
6275 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6278 else if (SCM_REALP (x
))
6280 double xx
= SCM_REAL_VALUE (x
);
6281 if (SCM_I_INUMP (y
))
6283 /* see comments with inum/real above */
6284 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6285 return scm_from_bool (xx
== (double) yy
6286 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6287 || (scm_t_signed_bits
) xx
== yy
));
6289 else if (SCM_BIGP (y
))
6292 if (isnan (SCM_REAL_VALUE (x
)))
6294 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6295 scm_remember_upto_here_1 (y
);
6296 return scm_from_bool (0 == cmp
);
6298 else if (SCM_REALP (y
))
6299 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6300 else if (SCM_COMPLEXP (y
))
6301 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6302 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6303 else if (SCM_FRACTIONP (y
))
6305 double xx
= SCM_REAL_VALUE (x
);
6309 return scm_from_bool (xx
< 0.0);
6310 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6314 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6317 else if (SCM_COMPLEXP (x
))
6319 if (SCM_I_INUMP (y
))
6320 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6321 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6322 else if (SCM_BIGP (y
))
6325 if (0.0 != SCM_COMPLEX_IMAG (x
))
6327 if (isnan (SCM_COMPLEX_REAL (x
)))
6329 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6330 scm_remember_upto_here_1 (y
);
6331 return scm_from_bool (0 == cmp
);
6333 else if (SCM_REALP (y
))
6334 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6335 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6336 else if (SCM_COMPLEXP (y
))
6337 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6338 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6339 else if (SCM_FRACTIONP (y
))
6342 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6344 xx
= SCM_COMPLEX_REAL (x
);
6348 return scm_from_bool (xx
< 0.0);
6349 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6353 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6356 else if (SCM_FRACTIONP (x
))
6358 if (SCM_I_INUMP (y
))
6360 else if (SCM_BIGP (y
))
6362 else if (SCM_REALP (y
))
6364 double yy
= SCM_REAL_VALUE (y
);
6368 return scm_from_bool (0.0 < yy
);
6369 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6372 else if (SCM_COMPLEXP (y
))
6375 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6377 yy
= SCM_COMPLEX_REAL (y
);
6381 return scm_from_bool (0.0 < yy
);
6382 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6385 else if (SCM_FRACTIONP (y
))
6386 return scm_i_fraction_equalp (x
, y
);
6388 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6392 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6397 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6398 done are good for inums, but for bignums an answer can almost always be
6399 had by just examining a few high bits of the operands, as done by GMP in
6400 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6401 of the float exponent to take into account. */
6403 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6404 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6405 (SCM x
, SCM y
, SCM rest
),
6406 "Return @code{#t} if the list of parameters is monotonically\n"
6408 #define FUNC_NAME s_scm_i_num_less_p
6410 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6412 while (!scm_is_null (rest
))
6414 if (scm_is_false (scm_less_p (x
, y
)))
6418 rest
= scm_cdr (rest
);
6420 return scm_less_p (x
, y
);
6424 scm_less_p (SCM x
, SCM y
)
6427 if (SCM_I_INUMP (x
))
6429 scm_t_inum xx
= SCM_I_INUM (x
);
6430 if (SCM_I_INUMP (y
))
6432 scm_t_inum yy
= SCM_I_INUM (y
);
6433 return scm_from_bool (xx
< yy
);
6435 else if (SCM_BIGP (y
))
6437 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6438 scm_remember_upto_here_1 (y
);
6439 return scm_from_bool (sgn
> 0);
6441 else if (SCM_REALP (y
))
6442 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6443 else if (SCM_FRACTIONP (y
))
6445 /* "x < a/b" becomes "x*b < a" */
6447 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6448 y
= SCM_FRACTION_NUMERATOR (y
);
6452 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6453 s_scm_i_num_less_p
);
6455 else if (SCM_BIGP (x
))
6457 if (SCM_I_INUMP (y
))
6459 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6460 scm_remember_upto_here_1 (x
);
6461 return scm_from_bool (sgn
< 0);
6463 else if (SCM_BIGP (y
))
6465 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6466 scm_remember_upto_here_2 (x
, y
);
6467 return scm_from_bool (cmp
< 0);
6469 else if (SCM_REALP (y
))
6472 if (isnan (SCM_REAL_VALUE (y
)))
6474 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6475 scm_remember_upto_here_1 (x
);
6476 return scm_from_bool (cmp
< 0);
6478 else if (SCM_FRACTIONP (y
))
6481 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6482 s_scm_i_num_less_p
);
6484 else if (SCM_REALP (x
))
6486 if (SCM_I_INUMP (y
))
6487 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6488 else if (SCM_BIGP (y
))
6491 if (isnan (SCM_REAL_VALUE (x
)))
6493 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6494 scm_remember_upto_here_1 (y
);
6495 return scm_from_bool (cmp
> 0);
6497 else if (SCM_REALP (y
))
6498 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6499 else if (SCM_FRACTIONP (y
))
6501 double xx
= SCM_REAL_VALUE (x
);
6505 return scm_from_bool (xx
< 0.0);
6506 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6510 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6511 s_scm_i_num_less_p
);
6513 else if (SCM_FRACTIONP (x
))
6515 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6517 /* "a/b < y" becomes "a < y*b" */
6518 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6519 x
= SCM_FRACTION_NUMERATOR (x
);
6522 else if (SCM_REALP (y
))
6524 double yy
= SCM_REAL_VALUE (y
);
6528 return scm_from_bool (0.0 < yy
);
6529 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6532 else if (SCM_FRACTIONP (y
))
6534 /* "a/b < c/d" becomes "a*d < c*b" */
6535 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6536 SCM_FRACTION_DENOMINATOR (y
));
6537 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6538 SCM_FRACTION_DENOMINATOR (x
));
6544 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6545 s_scm_i_num_less_p
);
6548 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6549 s_scm_i_num_less_p
);
6553 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6554 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6555 (SCM x
, SCM y
, SCM rest
),
6556 "Return @code{#t} if the list of parameters is monotonically\n"
6558 #define FUNC_NAME s_scm_i_num_gr_p
6560 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6562 while (!scm_is_null (rest
))
6564 if (scm_is_false (scm_gr_p (x
, y
)))
6568 rest
= scm_cdr (rest
);
6570 return scm_gr_p (x
, y
);
6573 #define FUNC_NAME s_scm_i_num_gr_p
6575 scm_gr_p (SCM x
, SCM y
)
6577 if (!SCM_NUMBERP (x
))
6578 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6579 else if (!SCM_NUMBERP (y
))
6580 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6582 return scm_less_p (y
, x
);
6587 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6588 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6589 (SCM x
, SCM y
, SCM rest
),
6590 "Return @code{#t} if the list of parameters is monotonically\n"
6592 #define FUNC_NAME s_scm_i_num_leq_p
6594 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6596 while (!scm_is_null (rest
))
6598 if (scm_is_false (scm_leq_p (x
, y
)))
6602 rest
= scm_cdr (rest
);
6604 return scm_leq_p (x
, y
);
6607 #define FUNC_NAME s_scm_i_num_leq_p
6609 scm_leq_p (SCM x
, SCM y
)
6611 if (!SCM_NUMBERP (x
))
6612 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6613 else if (!SCM_NUMBERP (y
))
6614 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6615 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6618 return scm_not (scm_less_p (y
, x
));
6623 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6624 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6625 (SCM x
, SCM y
, SCM rest
),
6626 "Return @code{#t} if the list of parameters is monotonically\n"
6628 #define FUNC_NAME s_scm_i_num_geq_p
6630 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6632 while (!scm_is_null (rest
))
6634 if (scm_is_false (scm_geq_p (x
, y
)))
6638 rest
= scm_cdr (rest
);
6640 return scm_geq_p (x
, y
);
6643 #define FUNC_NAME s_scm_i_num_geq_p
6645 scm_geq_p (SCM x
, SCM y
)
6647 if (!SCM_NUMBERP (x
))
6648 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6649 else if (!SCM_NUMBERP (y
))
6650 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6651 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6654 return scm_not (scm_less_p (x
, y
));
6659 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6661 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6663 #define FUNC_NAME s_scm_zero_p
6665 if (SCM_I_INUMP (z
))
6666 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6667 else if (SCM_BIGP (z
))
6669 else if (SCM_REALP (z
))
6670 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6671 else if (SCM_COMPLEXP (z
))
6672 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6673 && SCM_COMPLEX_IMAG (z
) == 0.0);
6674 else if (SCM_FRACTIONP (z
))
6677 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6682 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6684 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6686 #define FUNC_NAME s_scm_positive_p
6688 if (SCM_I_INUMP (x
))
6689 return scm_from_bool (SCM_I_INUM (x
) > 0);
6690 else if (SCM_BIGP (x
))
6692 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6693 scm_remember_upto_here_1 (x
);
6694 return scm_from_bool (sgn
> 0);
6696 else if (SCM_REALP (x
))
6697 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6698 else if (SCM_FRACTIONP (x
))
6699 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6701 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6706 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6708 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6710 #define FUNC_NAME s_scm_negative_p
6712 if (SCM_I_INUMP (x
))
6713 return scm_from_bool (SCM_I_INUM (x
) < 0);
6714 else if (SCM_BIGP (x
))
6716 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6717 scm_remember_upto_here_1 (x
);
6718 return scm_from_bool (sgn
< 0);
6720 else if (SCM_REALP (x
))
6721 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6722 else if (SCM_FRACTIONP (x
))
6723 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6725 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6730 /* scm_min and scm_max return an inexact when either argument is inexact, as
6731 required by r5rs. On that basis, for exact/inexact combinations the
6732 exact is converted to inexact to compare and possibly return. This is
6733 unlike scm_less_p above which takes some trouble to preserve all bits in
6734 its test, such trouble is not required for min and max. */
6736 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6737 (SCM x
, SCM y
, SCM rest
),
6738 "Return the maximum of all parameter values.")
6739 #define FUNC_NAME s_scm_i_max
6741 while (!scm_is_null (rest
))
6742 { x
= scm_max (x
, y
);
6744 rest
= scm_cdr (rest
);
6746 return scm_max (x
, y
);
6750 #define s_max s_scm_i_max
6751 #define g_max g_scm_i_max
6754 scm_max (SCM x
, SCM y
)
6759 return scm_wta_dispatch_0 (g_max
, s_max
);
6760 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6763 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
6766 if (SCM_I_INUMP (x
))
6768 scm_t_inum xx
= SCM_I_INUM (x
);
6769 if (SCM_I_INUMP (y
))
6771 scm_t_inum yy
= SCM_I_INUM (y
);
6772 return (xx
< yy
) ? y
: x
;
6774 else if (SCM_BIGP (y
))
6776 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6777 scm_remember_upto_here_1 (y
);
6778 return (sgn
< 0) ? x
: y
;
6780 else if (SCM_REALP (y
))
6783 double yyd
= SCM_REAL_VALUE (y
);
6786 return scm_from_double (xxd
);
6787 /* If y is a NaN, then "==" is false and we return the NaN */
6788 else if (SCM_LIKELY (!(xxd
== yyd
)))
6790 /* Handle signed zeroes properly */
6796 else if (SCM_FRACTIONP (y
))
6799 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6802 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6804 else if (SCM_BIGP (x
))
6806 if (SCM_I_INUMP (y
))
6808 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6809 scm_remember_upto_here_1 (x
);
6810 return (sgn
< 0) ? y
: x
;
6812 else if (SCM_BIGP (y
))
6814 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6815 scm_remember_upto_here_2 (x
, y
);
6816 return (cmp
> 0) ? x
: y
;
6818 else if (SCM_REALP (y
))
6820 /* if y==NaN then xx>yy is false, so we return the NaN y */
6823 xx
= scm_i_big2dbl (x
);
6824 yy
= SCM_REAL_VALUE (y
);
6825 return (xx
> yy
? scm_from_double (xx
) : y
);
6827 else if (SCM_FRACTIONP (y
))
6832 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6834 else if (SCM_REALP (x
))
6836 if (SCM_I_INUMP (y
))
6838 scm_t_inum yy
= SCM_I_INUM (y
);
6839 double xxd
= SCM_REAL_VALUE (x
);
6843 return scm_from_double (yyd
);
6844 /* If x is a NaN, then "==" is false and we return the NaN */
6845 else if (SCM_LIKELY (!(xxd
== yyd
)))
6847 /* Handle signed zeroes properly */
6853 else if (SCM_BIGP (y
))
6858 else if (SCM_REALP (y
))
6860 double xx
= SCM_REAL_VALUE (x
);
6861 double yy
= SCM_REAL_VALUE (y
);
6863 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6866 else if (SCM_LIKELY (xx
< yy
))
6868 /* If neither (xx > yy) nor (xx < yy), then
6869 either they're equal or one is a NaN */
6870 else if (SCM_UNLIKELY (isnan (xx
)))
6871 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6872 else if (SCM_UNLIKELY (isnan (yy
)))
6873 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6874 /* xx == yy, but handle signed zeroes properly */
6875 else if (double_is_non_negative_zero (yy
))
6880 else if (SCM_FRACTIONP (y
))
6882 double yy
= scm_i_fraction2double (y
);
6883 double xx
= SCM_REAL_VALUE (x
);
6884 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6887 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6889 else if (SCM_FRACTIONP (x
))
6891 if (SCM_I_INUMP (y
))
6895 else if (SCM_BIGP (y
))
6899 else if (SCM_REALP (y
))
6901 double xx
= scm_i_fraction2double (x
);
6902 /* if y==NaN then ">" is false, so we return the NaN y */
6903 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6905 else if (SCM_FRACTIONP (y
))
6910 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6913 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6917 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6918 (SCM x
, SCM y
, SCM rest
),
6919 "Return the minimum of all parameter values.")
6920 #define FUNC_NAME s_scm_i_min
6922 while (!scm_is_null (rest
))
6923 { x
= scm_min (x
, y
);
6925 rest
= scm_cdr (rest
);
6927 return scm_min (x
, y
);
6931 #define s_min s_scm_i_min
6932 #define g_min g_scm_i_min
6935 scm_min (SCM x
, SCM y
)
6940 return scm_wta_dispatch_0 (g_min
, s_min
);
6941 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6944 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
6947 if (SCM_I_INUMP (x
))
6949 scm_t_inum xx
= SCM_I_INUM (x
);
6950 if (SCM_I_INUMP (y
))
6952 scm_t_inum yy
= SCM_I_INUM (y
);
6953 return (xx
< yy
) ? x
: y
;
6955 else if (SCM_BIGP (y
))
6957 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6958 scm_remember_upto_here_1 (y
);
6959 return (sgn
< 0) ? y
: x
;
6961 else if (SCM_REALP (y
))
6964 /* if y==NaN then "<" is false and we return NaN */
6965 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6967 else if (SCM_FRACTIONP (y
))
6970 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6973 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6975 else if (SCM_BIGP (x
))
6977 if (SCM_I_INUMP (y
))
6979 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6980 scm_remember_upto_here_1 (x
);
6981 return (sgn
< 0) ? x
: y
;
6983 else if (SCM_BIGP (y
))
6985 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6986 scm_remember_upto_here_2 (x
, y
);
6987 return (cmp
> 0) ? y
: x
;
6989 else if (SCM_REALP (y
))
6991 /* if y==NaN then xx<yy is false, so we return the NaN y */
6994 xx
= scm_i_big2dbl (x
);
6995 yy
= SCM_REAL_VALUE (y
);
6996 return (xx
< yy
? scm_from_double (xx
) : y
);
6998 else if (SCM_FRACTIONP (y
))
7003 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7005 else if (SCM_REALP (x
))
7007 if (SCM_I_INUMP (y
))
7009 double z
= SCM_I_INUM (y
);
7010 /* if x==NaN then "<" is false and we return NaN */
7011 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7013 else if (SCM_BIGP (y
))
7018 else if (SCM_REALP (y
))
7020 double xx
= SCM_REAL_VALUE (x
);
7021 double yy
= SCM_REAL_VALUE (y
);
7023 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7026 else if (SCM_LIKELY (xx
> yy
))
7028 /* If neither (xx < yy) nor (xx > yy), then
7029 either they're equal or one is a NaN */
7030 else if (SCM_UNLIKELY (isnan (xx
)))
7031 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7032 else if (SCM_UNLIKELY (isnan (yy
)))
7033 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7034 /* xx == yy, but handle signed zeroes properly */
7035 else if (double_is_non_negative_zero (xx
))
7040 else if (SCM_FRACTIONP (y
))
7042 double yy
= scm_i_fraction2double (y
);
7043 double xx
= SCM_REAL_VALUE (x
);
7044 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7047 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7049 else if (SCM_FRACTIONP (x
))
7051 if (SCM_I_INUMP (y
))
7055 else if (SCM_BIGP (y
))
7059 else if (SCM_REALP (y
))
7061 double xx
= scm_i_fraction2double (x
);
7062 /* if y==NaN then "<" is false, so we return the NaN y */
7063 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7065 else if (SCM_FRACTIONP (y
))
7070 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7073 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7077 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7078 (SCM x
, SCM y
, SCM rest
),
7079 "Return the sum of all parameter values. Return 0 if called without\n"
7081 #define FUNC_NAME s_scm_i_sum
7083 while (!scm_is_null (rest
))
7084 { x
= scm_sum (x
, y
);
7086 rest
= scm_cdr (rest
);
7088 return scm_sum (x
, y
);
7092 #define s_sum s_scm_i_sum
7093 #define g_sum g_scm_i_sum
7096 scm_sum (SCM x
, SCM y
)
7098 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7100 if (SCM_NUMBERP (x
)) return x
;
7101 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7102 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7105 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7107 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7109 scm_t_inum xx
= SCM_I_INUM (x
);
7110 scm_t_inum yy
= SCM_I_INUM (y
);
7111 scm_t_inum z
= xx
+ yy
;
7112 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7114 else if (SCM_BIGP (y
))
7119 else if (SCM_REALP (y
))
7121 scm_t_inum xx
= SCM_I_INUM (x
);
7122 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7124 else if (SCM_COMPLEXP (y
))
7126 scm_t_inum xx
= SCM_I_INUM (x
);
7127 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7128 SCM_COMPLEX_IMAG (y
));
7130 else if (SCM_FRACTIONP (y
))
7131 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7132 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7133 SCM_FRACTION_DENOMINATOR (y
));
7135 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7136 } else if (SCM_BIGP (x
))
7138 if (SCM_I_INUMP (y
))
7143 inum
= SCM_I_INUM (y
);
7146 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7149 SCM result
= scm_i_mkbig ();
7150 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7151 scm_remember_upto_here_1 (x
);
7152 /* we know the result will have to be a bignum */
7155 return scm_i_normbig (result
);
7159 SCM result
= scm_i_mkbig ();
7160 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7161 scm_remember_upto_here_1 (x
);
7162 /* we know the result will have to be a bignum */
7165 return scm_i_normbig (result
);
7168 else if (SCM_BIGP (y
))
7170 SCM result
= scm_i_mkbig ();
7171 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7172 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7173 mpz_add (SCM_I_BIG_MPZ (result
),
7176 scm_remember_upto_here_2 (x
, y
);
7177 /* we know the result will have to be a bignum */
7180 return scm_i_normbig (result
);
7182 else if (SCM_REALP (y
))
7184 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7185 scm_remember_upto_here_1 (x
);
7186 return scm_from_double (result
);
7188 else if (SCM_COMPLEXP (y
))
7190 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7191 + SCM_COMPLEX_REAL (y
));
7192 scm_remember_upto_here_1 (x
);
7193 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7195 else if (SCM_FRACTIONP (y
))
7196 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7197 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7198 SCM_FRACTION_DENOMINATOR (y
));
7200 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7202 else if (SCM_REALP (x
))
7204 if (SCM_I_INUMP (y
))
7205 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7206 else if (SCM_BIGP (y
))
7208 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7209 scm_remember_upto_here_1 (y
);
7210 return scm_from_double (result
);
7212 else if (SCM_REALP (y
))
7213 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7214 else if (SCM_COMPLEXP (y
))
7215 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7216 SCM_COMPLEX_IMAG (y
));
7217 else if (SCM_FRACTIONP (y
))
7218 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7220 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7222 else if (SCM_COMPLEXP (x
))
7224 if (SCM_I_INUMP (y
))
7225 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7226 SCM_COMPLEX_IMAG (x
));
7227 else if (SCM_BIGP (y
))
7229 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7230 + SCM_COMPLEX_REAL (x
));
7231 scm_remember_upto_here_1 (y
);
7232 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7234 else if (SCM_REALP (y
))
7235 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7236 SCM_COMPLEX_IMAG (x
));
7237 else if (SCM_COMPLEXP (y
))
7238 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7239 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7240 else if (SCM_FRACTIONP (y
))
7241 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7242 SCM_COMPLEX_IMAG (x
));
7244 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7246 else if (SCM_FRACTIONP (x
))
7248 if (SCM_I_INUMP (y
))
7249 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7250 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7251 SCM_FRACTION_DENOMINATOR (x
));
7252 else if (SCM_BIGP (y
))
7253 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7254 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7255 SCM_FRACTION_DENOMINATOR (x
));
7256 else if (SCM_REALP (y
))
7257 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7258 else if (SCM_COMPLEXP (y
))
7259 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7260 SCM_COMPLEX_IMAG (y
));
7261 else if (SCM_FRACTIONP (y
))
7262 /* a/b + c/d = (ad + bc) / bd */
7263 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7264 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7265 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7267 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7270 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7274 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7276 "Return @math{@var{x}+1}.")
7277 #define FUNC_NAME s_scm_oneplus
7279 return scm_sum (x
, SCM_INUM1
);
7284 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7285 (SCM x
, SCM y
, SCM rest
),
7286 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7287 "the sum of all but the first argument are subtracted from the first\n"
7289 #define FUNC_NAME s_scm_i_difference
7291 while (!scm_is_null (rest
))
7292 { x
= scm_difference (x
, y
);
7294 rest
= scm_cdr (rest
);
7296 return scm_difference (x
, y
);
7300 #define s_difference s_scm_i_difference
7301 #define g_difference g_scm_i_difference
7304 scm_difference (SCM x
, SCM y
)
7305 #define FUNC_NAME s_difference
7307 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7310 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7312 if (SCM_I_INUMP (x
))
7314 scm_t_inum xx
= -SCM_I_INUM (x
);
7315 if (SCM_FIXABLE (xx
))
7316 return SCM_I_MAKINUM (xx
);
7318 return scm_i_inum2big (xx
);
7320 else if (SCM_BIGP (x
))
7321 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7322 bignum, but negating that gives a fixnum. */
7323 return scm_i_normbig (scm_i_clonebig (x
, 0));
7324 else if (SCM_REALP (x
))
7325 return scm_from_double (-SCM_REAL_VALUE (x
));
7326 else if (SCM_COMPLEXP (x
))
7327 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7328 -SCM_COMPLEX_IMAG (x
));
7329 else if (SCM_FRACTIONP (x
))
7330 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7331 SCM_FRACTION_DENOMINATOR (x
));
7333 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7336 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7338 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7340 scm_t_inum xx
= SCM_I_INUM (x
);
7341 scm_t_inum yy
= SCM_I_INUM (y
);
7342 scm_t_inum z
= xx
- yy
;
7343 if (SCM_FIXABLE (z
))
7344 return SCM_I_MAKINUM (z
);
7346 return scm_i_inum2big (z
);
7348 else if (SCM_BIGP (y
))
7350 /* inum-x - big-y */
7351 scm_t_inum xx
= SCM_I_INUM (x
);
7355 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7356 bignum, but negating that gives a fixnum. */
7357 return scm_i_normbig (scm_i_clonebig (y
, 0));
7361 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7362 SCM result
= scm_i_mkbig ();
7365 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7368 /* x - y == -(y + -x) */
7369 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7370 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7372 scm_remember_upto_here_1 (y
);
7374 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7375 /* we know the result will have to be a bignum */
7378 return scm_i_normbig (result
);
7381 else if (SCM_REALP (y
))
7383 scm_t_inum xx
= SCM_I_INUM (x
);
7386 * We need to handle x == exact 0
7387 * specially because R6RS states that:
7388 * (- 0.0) ==> -0.0 and
7389 * (- 0.0 0.0) ==> 0.0
7390 * and the scheme compiler changes
7391 * (- 0.0) into (- 0 0.0)
7392 * So we need to treat (- 0 0.0) like (- 0.0).
7393 * At the C level, (-x) is different than (0.0 - x).
7394 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7397 return scm_from_double (- SCM_REAL_VALUE (y
));
7399 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7401 else if (SCM_COMPLEXP (y
))
7403 scm_t_inum xx
= SCM_I_INUM (x
);
7405 /* We need to handle x == exact 0 specially.
7406 See the comment above (for SCM_REALP (y)) */
7408 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7409 - SCM_COMPLEX_IMAG (y
));
7411 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7412 - SCM_COMPLEX_IMAG (y
));
7414 else if (SCM_FRACTIONP (y
))
7415 /* a - b/c = (ac - b) / c */
7416 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7417 SCM_FRACTION_NUMERATOR (y
)),
7418 SCM_FRACTION_DENOMINATOR (y
));
7420 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7422 else if (SCM_BIGP (x
))
7424 if (SCM_I_INUMP (y
))
7426 /* big-x - inum-y */
7427 scm_t_inum yy
= SCM_I_INUM (y
);
7428 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7430 scm_remember_upto_here_1 (x
);
7432 return (SCM_FIXABLE (-yy
) ?
7433 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7436 SCM result
= scm_i_mkbig ();
7439 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7441 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7442 scm_remember_upto_here_1 (x
);
7444 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7445 /* we know the result will have to be a bignum */
7448 return scm_i_normbig (result
);
7451 else if (SCM_BIGP (y
))
7453 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7454 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7455 SCM result
= scm_i_mkbig ();
7456 mpz_sub (SCM_I_BIG_MPZ (result
),
7459 scm_remember_upto_here_2 (x
, y
);
7460 /* we know the result will have to be a bignum */
7461 if ((sgn_x
== 1) && (sgn_y
== -1))
7463 if ((sgn_x
== -1) && (sgn_y
== 1))
7465 return scm_i_normbig (result
);
7467 else if (SCM_REALP (y
))
7469 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7470 scm_remember_upto_here_1 (x
);
7471 return scm_from_double (result
);
7473 else if (SCM_COMPLEXP (y
))
7475 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7476 - SCM_COMPLEX_REAL (y
));
7477 scm_remember_upto_here_1 (x
);
7478 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7480 else if (SCM_FRACTIONP (y
))
7481 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7482 SCM_FRACTION_NUMERATOR (y
)),
7483 SCM_FRACTION_DENOMINATOR (y
));
7485 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7487 else if (SCM_REALP (x
))
7489 if (SCM_I_INUMP (y
))
7490 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7491 else if (SCM_BIGP (y
))
7493 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7494 scm_remember_upto_here_1 (x
);
7495 return scm_from_double (result
);
7497 else if (SCM_REALP (y
))
7498 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7499 else if (SCM_COMPLEXP (y
))
7500 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7501 -SCM_COMPLEX_IMAG (y
));
7502 else if (SCM_FRACTIONP (y
))
7503 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7505 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7507 else if (SCM_COMPLEXP (x
))
7509 if (SCM_I_INUMP (y
))
7510 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7511 SCM_COMPLEX_IMAG (x
));
7512 else if (SCM_BIGP (y
))
7514 double real_part
= (SCM_COMPLEX_REAL (x
)
7515 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7516 scm_remember_upto_here_1 (x
);
7517 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7519 else if (SCM_REALP (y
))
7520 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7521 SCM_COMPLEX_IMAG (x
));
7522 else if (SCM_COMPLEXP (y
))
7523 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7524 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7525 else if (SCM_FRACTIONP (y
))
7526 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7527 SCM_COMPLEX_IMAG (x
));
7529 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7531 else if (SCM_FRACTIONP (x
))
7533 if (SCM_I_INUMP (y
))
7534 /* a/b - c = (a - cb) / b */
7535 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7536 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7537 SCM_FRACTION_DENOMINATOR (x
));
7538 else if (SCM_BIGP (y
))
7539 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7540 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7541 SCM_FRACTION_DENOMINATOR (x
));
7542 else if (SCM_REALP (y
))
7543 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7544 else if (SCM_COMPLEXP (y
))
7545 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7546 -SCM_COMPLEX_IMAG (y
));
7547 else if (SCM_FRACTIONP (y
))
7548 /* a/b - c/d = (ad - bc) / bd */
7549 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7550 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7551 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7553 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7556 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7561 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7563 "Return @math{@var{x}-1}.")
7564 #define FUNC_NAME s_scm_oneminus
7566 return scm_difference (x
, SCM_INUM1
);
7571 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7572 (SCM x
, SCM y
, SCM rest
),
7573 "Return the product of all arguments. If called without arguments,\n"
7575 #define FUNC_NAME s_scm_i_product
7577 while (!scm_is_null (rest
))
7578 { x
= scm_product (x
, y
);
7580 rest
= scm_cdr (rest
);
7582 return scm_product (x
, y
);
7586 #define s_product s_scm_i_product
7587 #define g_product g_scm_i_product
7590 scm_product (SCM x
, SCM y
)
7592 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7595 return SCM_I_MAKINUM (1L);
7596 else if (SCM_NUMBERP (x
))
7599 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
7602 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7607 xx
= SCM_I_INUM (x
);
7612 /* exact1 is the universal multiplicative identity */
7616 /* exact0 times a fixnum is exact0: optimize this case */
7617 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7619 /* if the other argument is inexact, the result is inexact,
7620 and we must do the multiplication in order to handle
7621 infinities and NaNs properly. */
7622 else if (SCM_REALP (y
))
7623 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7624 else if (SCM_COMPLEXP (y
))
7625 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7626 0.0 * SCM_COMPLEX_IMAG (y
));
7627 /* we've already handled inexact numbers,
7628 so y must be exact, and we return exact0 */
7629 else if (SCM_NUMP (y
))
7632 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7636 * This case is important for more than just optimization.
7637 * It handles the case of negating
7638 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7639 * which is a bignum that must be changed back into a fixnum.
7640 * Failure to do so will cause the following to return #f:
7641 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7643 return scm_difference(y
, SCM_UNDEFINED
);
7647 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7649 scm_t_inum yy
= SCM_I_INUM (y
);
7650 scm_t_inum kk
= xx
* yy
;
7651 SCM k
= SCM_I_MAKINUM (kk
);
7652 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7656 SCM result
= scm_i_inum2big (xx
);
7657 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7658 return scm_i_normbig (result
);
7661 else if (SCM_BIGP (y
))
7663 SCM result
= scm_i_mkbig ();
7664 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7665 scm_remember_upto_here_1 (y
);
7668 else if (SCM_REALP (y
))
7669 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7670 else if (SCM_COMPLEXP (y
))
7671 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7672 xx
* SCM_COMPLEX_IMAG (y
));
7673 else if (SCM_FRACTIONP (y
))
7674 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7675 SCM_FRACTION_DENOMINATOR (y
));
7677 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7679 else if (SCM_BIGP (x
))
7681 if (SCM_I_INUMP (y
))
7686 else if (SCM_BIGP (y
))
7688 SCM result
= scm_i_mkbig ();
7689 mpz_mul (SCM_I_BIG_MPZ (result
),
7692 scm_remember_upto_here_2 (x
, y
);
7695 else if (SCM_REALP (y
))
7697 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7698 scm_remember_upto_here_1 (x
);
7699 return scm_from_double (result
);
7701 else if (SCM_COMPLEXP (y
))
7703 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7704 scm_remember_upto_here_1 (x
);
7705 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7706 z
* SCM_COMPLEX_IMAG (y
));
7708 else if (SCM_FRACTIONP (y
))
7709 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7710 SCM_FRACTION_DENOMINATOR (y
));
7712 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7714 else if (SCM_REALP (x
))
7716 if (SCM_I_INUMP (y
))
7721 else if (SCM_BIGP (y
))
7723 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7724 scm_remember_upto_here_1 (y
);
7725 return scm_from_double (result
);
7727 else if (SCM_REALP (y
))
7728 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7729 else if (SCM_COMPLEXP (y
))
7730 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7731 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7732 else if (SCM_FRACTIONP (y
))
7733 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7735 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7737 else if (SCM_COMPLEXP (x
))
7739 if (SCM_I_INUMP (y
))
7744 else if (SCM_BIGP (y
))
7746 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7747 scm_remember_upto_here_1 (y
);
7748 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7749 z
* SCM_COMPLEX_IMAG (x
));
7751 else if (SCM_REALP (y
))
7752 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7753 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7754 else if (SCM_COMPLEXP (y
))
7756 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7757 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7758 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7759 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7761 else if (SCM_FRACTIONP (y
))
7763 double yy
= scm_i_fraction2double (y
);
7764 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7765 yy
* SCM_COMPLEX_IMAG (x
));
7768 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7770 else if (SCM_FRACTIONP (x
))
7772 if (SCM_I_INUMP (y
))
7773 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7774 SCM_FRACTION_DENOMINATOR (x
));
7775 else if (SCM_BIGP (y
))
7776 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7777 SCM_FRACTION_DENOMINATOR (x
));
7778 else if (SCM_REALP (y
))
7779 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7780 else if (SCM_COMPLEXP (y
))
7782 double xx
= scm_i_fraction2double (x
);
7783 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7784 xx
* SCM_COMPLEX_IMAG (y
));
7786 else if (SCM_FRACTIONP (y
))
7787 /* a/b * c/d = ac / bd */
7788 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7789 SCM_FRACTION_NUMERATOR (y
)),
7790 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7791 SCM_FRACTION_DENOMINATOR (y
)));
7793 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7796 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7799 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7800 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7801 #define ALLOW_DIVIDE_BY_ZERO
7802 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7805 /* The code below for complex division is adapted from the GNU
7806 libstdc++, which adapted it from f2c's libF77, and is subject to
7809 /****************************************************************
7810 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7812 Permission to use, copy, modify, and distribute this software
7813 and its documentation for any purpose and without fee is hereby
7814 granted, provided that the above copyright notice appear in all
7815 copies and that both that the copyright notice and this
7816 permission notice and warranty disclaimer appear in supporting
7817 documentation, and that the names of AT&T Bell Laboratories or
7818 Bellcore or any of their entities not be used in advertising or
7819 publicity pertaining to distribution of the software without
7820 specific, written prior permission.
7822 AT&T and Bellcore disclaim all warranties with regard to this
7823 software, including all implied warranties of merchantability
7824 and fitness. In no event shall AT&T or Bellcore be liable for
7825 any special, indirect or consequential damages or any damages
7826 whatsoever resulting from loss of use, data or profits, whether
7827 in an action of contract, negligence or other tortious action,
7828 arising out of or in connection with the use or performance of
7830 ****************************************************************/
7832 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7833 (SCM x
, SCM y
, SCM rest
),
7834 "Divide the first argument by the product of the remaining\n"
7835 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7837 #define FUNC_NAME s_scm_i_divide
7839 while (!scm_is_null (rest
))
7840 { x
= scm_divide (x
, y
);
7842 rest
= scm_cdr (rest
);
7844 return scm_divide (x
, y
);
7848 #define s_divide s_scm_i_divide
7849 #define g_divide g_scm_i_divide
7852 do_divide (SCM x
, SCM y
, int inexact
)
7853 #define FUNC_NAME s_divide
7857 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7860 return scm_wta_dispatch_0 (g_divide
, s_divide
);
7861 else if (SCM_I_INUMP (x
))
7863 scm_t_inum xx
= SCM_I_INUM (x
);
7864 if (xx
== 1 || xx
== -1)
7866 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7868 scm_num_overflow (s_divide
);
7873 return scm_from_double (1.0 / (double) xx
);
7874 else return scm_i_make_ratio (SCM_INUM1
, x
);
7877 else if (SCM_BIGP (x
))
7880 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7881 else return scm_i_make_ratio (SCM_INUM1
, x
);
7883 else if (SCM_REALP (x
))
7885 double xx
= SCM_REAL_VALUE (x
);
7886 #ifndef ALLOW_DIVIDE_BY_ZERO
7888 scm_num_overflow (s_divide
);
7891 return scm_from_double (1.0 / xx
);
7893 else if (SCM_COMPLEXP (x
))
7895 double r
= SCM_COMPLEX_REAL (x
);
7896 double i
= SCM_COMPLEX_IMAG (x
);
7897 if (fabs(r
) <= fabs(i
))
7900 double d
= i
* (1.0 + t
* t
);
7901 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7906 double d
= r
* (1.0 + t
* t
);
7907 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7910 else if (SCM_FRACTIONP (x
))
7911 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7912 SCM_FRACTION_NUMERATOR (x
));
7914 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7917 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7919 scm_t_inum xx
= SCM_I_INUM (x
);
7920 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7922 scm_t_inum yy
= SCM_I_INUM (y
);
7925 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7926 scm_num_overflow (s_divide
);
7928 return scm_from_double ((double) xx
/ (double) yy
);
7931 else if (xx
% yy
!= 0)
7934 return scm_from_double ((double) xx
/ (double) yy
);
7935 else return scm_i_make_ratio (x
, y
);
7939 scm_t_inum z
= xx
/ yy
;
7940 if (SCM_FIXABLE (z
))
7941 return SCM_I_MAKINUM (z
);
7943 return scm_i_inum2big (z
);
7946 else if (SCM_BIGP (y
))
7949 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7950 else return scm_i_make_ratio (x
, y
);
7952 else if (SCM_REALP (y
))
7954 double yy
= SCM_REAL_VALUE (y
);
7955 #ifndef ALLOW_DIVIDE_BY_ZERO
7957 scm_num_overflow (s_divide
);
7960 return scm_from_double ((double) xx
/ yy
);
7962 else if (SCM_COMPLEXP (y
))
7965 complex_div
: /* y _must_ be a complex number */
7967 double r
= SCM_COMPLEX_REAL (y
);
7968 double i
= SCM_COMPLEX_IMAG (y
);
7969 if (fabs(r
) <= fabs(i
))
7972 double d
= i
* (1.0 + t
* t
);
7973 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7978 double d
= r
* (1.0 + t
* t
);
7979 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7983 else if (SCM_FRACTIONP (y
))
7984 /* a / b/c = ac / b */
7985 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7986 SCM_FRACTION_NUMERATOR (y
));
7988 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7990 else if (SCM_BIGP (x
))
7992 if (SCM_I_INUMP (y
))
7994 scm_t_inum yy
= SCM_I_INUM (y
);
7997 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7998 scm_num_overflow (s_divide
);
8000 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
8001 scm_remember_upto_here_1 (x
);
8002 return (sgn
== 0) ? scm_nan () : scm_inf ();
8009 /* FIXME: HMM, what are the relative performance issues here?
8010 We need to test. Is it faster on average to test
8011 divisible_p, then perform whichever operation, or is it
8012 faster to perform the integer div opportunistically and
8013 switch to real if there's a remainder? For now we take the
8014 middle ground: test, then if divisible, use the faster div
8017 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8018 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8022 SCM result
= scm_i_mkbig ();
8023 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8024 scm_remember_upto_here_1 (x
);
8026 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8027 return scm_i_normbig (result
);
8032 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
8033 else return scm_i_make_ratio (x
, y
);
8037 else if (SCM_BIGP (y
))
8042 /* It's easily possible for the ratio x/y to fit a double
8043 but one or both x and y be too big to fit a double,
8044 hence the use of mpq_get_d rather than converting and
8047 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8048 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8049 return scm_from_double (mpq_get_d (q
));
8053 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8057 SCM result
= scm_i_mkbig ();
8058 mpz_divexact (SCM_I_BIG_MPZ (result
),
8061 scm_remember_upto_here_2 (x
, y
);
8062 return scm_i_normbig (result
);
8065 return scm_i_make_ratio (x
, y
);
8068 else if (SCM_REALP (y
))
8070 double yy
= SCM_REAL_VALUE (y
);
8071 #ifndef ALLOW_DIVIDE_BY_ZERO
8073 scm_num_overflow (s_divide
);
8076 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8078 else if (SCM_COMPLEXP (y
))
8080 a
= scm_i_big2dbl (x
);
8083 else if (SCM_FRACTIONP (y
))
8084 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8085 SCM_FRACTION_NUMERATOR (y
));
8087 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8089 else if (SCM_REALP (x
))
8091 double rx
= SCM_REAL_VALUE (x
);
8092 if (SCM_I_INUMP (y
))
8094 scm_t_inum yy
= SCM_I_INUM (y
);
8095 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8097 scm_num_overflow (s_divide
);
8100 return scm_from_double (rx
/ (double) yy
);
8102 else if (SCM_BIGP (y
))
8104 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8105 scm_remember_upto_here_1 (y
);
8106 return scm_from_double (rx
/ dby
);
8108 else if (SCM_REALP (y
))
8110 double yy
= SCM_REAL_VALUE (y
);
8111 #ifndef ALLOW_DIVIDE_BY_ZERO
8113 scm_num_overflow (s_divide
);
8116 return scm_from_double (rx
/ yy
);
8118 else if (SCM_COMPLEXP (y
))
8123 else if (SCM_FRACTIONP (y
))
8124 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8126 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8128 else if (SCM_COMPLEXP (x
))
8130 double rx
= SCM_COMPLEX_REAL (x
);
8131 double ix
= SCM_COMPLEX_IMAG (x
);
8132 if (SCM_I_INUMP (y
))
8134 scm_t_inum yy
= SCM_I_INUM (y
);
8135 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8137 scm_num_overflow (s_divide
);
8142 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8145 else if (SCM_BIGP (y
))
8147 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8148 scm_remember_upto_here_1 (y
);
8149 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8151 else if (SCM_REALP (y
))
8153 double yy
= SCM_REAL_VALUE (y
);
8154 #ifndef ALLOW_DIVIDE_BY_ZERO
8156 scm_num_overflow (s_divide
);
8159 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8161 else if (SCM_COMPLEXP (y
))
8163 double ry
= SCM_COMPLEX_REAL (y
);
8164 double iy
= SCM_COMPLEX_IMAG (y
);
8165 if (fabs(ry
) <= fabs(iy
))
8168 double d
= iy
* (1.0 + t
* t
);
8169 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8174 double d
= ry
* (1.0 + t
* t
);
8175 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8178 else if (SCM_FRACTIONP (y
))
8180 double yy
= scm_i_fraction2double (y
);
8181 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8184 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8186 else if (SCM_FRACTIONP (x
))
8188 if (SCM_I_INUMP (y
))
8190 scm_t_inum yy
= SCM_I_INUM (y
);
8191 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8193 scm_num_overflow (s_divide
);
8196 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8197 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8199 else if (SCM_BIGP (y
))
8201 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8202 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8204 else if (SCM_REALP (y
))
8206 double yy
= SCM_REAL_VALUE (y
);
8207 #ifndef ALLOW_DIVIDE_BY_ZERO
8209 scm_num_overflow (s_divide
);
8212 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8214 else if (SCM_COMPLEXP (y
))
8216 a
= scm_i_fraction2double (x
);
8219 else if (SCM_FRACTIONP (y
))
8220 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8221 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8223 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8226 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8230 scm_divide (SCM x
, SCM y
)
8232 return do_divide (x
, y
, 0);
8235 static SCM
scm_divide2real (SCM x
, SCM y
)
8237 return do_divide (x
, y
, 1);
8243 scm_c_truncate (double x
)
8248 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8249 half-way case (ie. when x is an integer plus 0.5) going upwards.
8250 Then half-way cases are identified and adjusted down if the
8251 round-upwards didn't give the desired even integer.
8253 "plus_half == result" identifies a half-way case. If plus_half, which is
8254 x + 0.5, is an integer then x must be an integer plus 0.5.
8256 An odd "result" value is identified with result/2 != floor(result/2).
8257 This is done with plus_half, since that value is ready for use sooner in
8258 a pipelined cpu, and we're already requiring plus_half == result.
8260 Note however that we need to be careful when x is big and already an
8261 integer. In that case "x+0.5" may round to an adjacent integer, causing
8262 us to return such a value, incorrectly. For instance if the hardware is
8263 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8264 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8265 returned. Or if the hardware is in round-upwards mode, then other bigger
8266 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8267 representable value, 2^128+2^76 (or whatever), again incorrect.
8269 These bad roundings of x+0.5 are avoided by testing at the start whether
8270 x is already an integer. If it is then clearly that's the desired result
8271 already. And if it's not then the exponent must be small enough to allow
8272 an 0.5 to be represented, and hence added without a bad rounding. */
8275 scm_c_round (double x
)
8277 double plus_half
, result
;
8282 plus_half
= x
+ 0.5;
8283 result
= floor (plus_half
);
8284 /* Adjust so that the rounding is towards even. */
8285 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8290 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8292 "Round the number @var{x} towards zero.")
8293 #define FUNC_NAME s_scm_truncate_number
8295 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8297 else if (SCM_REALP (x
))
8298 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8299 else if (SCM_FRACTIONP (x
))
8300 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8301 SCM_FRACTION_DENOMINATOR (x
));
8303 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8304 s_scm_truncate_number
);
8308 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8310 "Round the number @var{x} towards the nearest integer. "
8311 "When it is exactly halfway between two integers, "
8312 "round towards the even one.")
8313 #define FUNC_NAME s_scm_round_number
8315 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8317 else if (SCM_REALP (x
))
8318 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8319 else if (SCM_FRACTIONP (x
))
8320 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8321 SCM_FRACTION_DENOMINATOR (x
));
8323 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8324 s_scm_round_number
);
8328 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8330 "Round the number @var{x} towards minus infinity.")
8331 #define FUNC_NAME s_scm_floor
8333 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8335 else if (SCM_REALP (x
))
8336 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8337 else if (SCM_FRACTIONP (x
))
8338 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8339 SCM_FRACTION_DENOMINATOR (x
));
8341 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8345 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8347 "Round the number @var{x} towards infinity.")
8348 #define FUNC_NAME s_scm_ceiling
8350 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8352 else if (SCM_REALP (x
))
8353 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8354 else if (SCM_FRACTIONP (x
))
8355 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8356 SCM_FRACTION_DENOMINATOR (x
));
8358 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8362 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8364 "Return @var{x} raised to the power of @var{y}.")
8365 #define FUNC_NAME s_scm_expt
8367 if (scm_is_integer (y
))
8369 if (scm_is_true (scm_exact_p (y
)))
8370 return scm_integer_expt (x
, y
);
8373 /* Here we handle the case where the exponent is an inexact
8374 integer. We make the exponent exact in order to use
8375 scm_integer_expt, and thus avoid the spurious imaginary
8376 parts that may result from round-off errors in the general
8377 e^(y log x) method below (for example when squaring a large
8378 negative number). In this case, we must return an inexact
8379 result for correctness. We also make the base inexact so
8380 that scm_integer_expt will use fast inexact arithmetic
8381 internally. Note that making the base inexact is not
8382 sufficient to guarantee an inexact result, because
8383 scm_integer_expt will return an exact 1 when the exponent
8384 is 0, even if the base is inexact. */
8385 return scm_exact_to_inexact
8386 (scm_integer_expt (scm_exact_to_inexact (x
),
8387 scm_inexact_to_exact (y
)));
8390 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8392 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8394 else if (scm_is_complex (x
) && scm_is_complex (y
))
8395 return scm_exp (scm_product (scm_log (x
), y
));
8396 else if (scm_is_complex (x
))
8397 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8399 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8403 /* sin/cos/tan/asin/acos/atan
8404 sinh/cosh/tanh/asinh/acosh/atanh
8405 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8406 Written by Jerry D. Hedden, (C) FSF.
8407 See the file `COPYING' for terms applying to this program. */
8409 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8411 "Compute the sine of @var{z}.")
8412 #define FUNC_NAME s_scm_sin
8414 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8415 return z
; /* sin(exact0) = exact0 */
8416 else if (scm_is_real (z
))
8417 return scm_from_double (sin (scm_to_double (z
)));
8418 else if (SCM_COMPLEXP (z
))
8420 x
= SCM_COMPLEX_REAL (z
);
8421 y
= SCM_COMPLEX_IMAG (z
);
8422 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8423 cos (x
) * sinh (y
));
8426 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8430 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8432 "Compute the cosine of @var{z}.")
8433 #define FUNC_NAME s_scm_cos
8435 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8436 return SCM_INUM1
; /* cos(exact0) = exact1 */
8437 else if (scm_is_real (z
))
8438 return scm_from_double (cos (scm_to_double (z
)));
8439 else if (SCM_COMPLEXP (z
))
8441 x
= SCM_COMPLEX_REAL (z
);
8442 y
= SCM_COMPLEX_IMAG (z
);
8443 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8444 -sin (x
) * sinh (y
));
8447 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8451 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8453 "Compute the tangent of @var{z}.")
8454 #define FUNC_NAME s_scm_tan
8456 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8457 return z
; /* tan(exact0) = exact0 */
8458 else if (scm_is_real (z
))
8459 return scm_from_double (tan (scm_to_double (z
)));
8460 else if (SCM_COMPLEXP (z
))
8462 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8463 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8464 w
= cos (x
) + cosh (y
);
8465 #ifndef ALLOW_DIVIDE_BY_ZERO
8467 scm_num_overflow (s_scm_tan
);
8469 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8472 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8476 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8478 "Compute the hyperbolic sine of @var{z}.")
8479 #define FUNC_NAME s_scm_sinh
8481 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8482 return z
; /* sinh(exact0) = exact0 */
8483 else if (scm_is_real (z
))
8484 return scm_from_double (sinh (scm_to_double (z
)));
8485 else if (SCM_COMPLEXP (z
))
8487 x
= SCM_COMPLEX_REAL (z
);
8488 y
= SCM_COMPLEX_IMAG (z
);
8489 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8490 cosh (x
) * sin (y
));
8493 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8497 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8499 "Compute the hyperbolic cosine of @var{z}.")
8500 #define FUNC_NAME s_scm_cosh
8502 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8503 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8504 else if (scm_is_real (z
))
8505 return scm_from_double (cosh (scm_to_double (z
)));
8506 else if (SCM_COMPLEXP (z
))
8508 x
= SCM_COMPLEX_REAL (z
);
8509 y
= SCM_COMPLEX_IMAG (z
);
8510 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8511 sinh (x
) * sin (y
));
8514 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8518 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8520 "Compute the hyperbolic tangent of @var{z}.")
8521 #define FUNC_NAME s_scm_tanh
8523 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8524 return z
; /* tanh(exact0) = exact0 */
8525 else if (scm_is_real (z
))
8526 return scm_from_double (tanh (scm_to_double (z
)));
8527 else if (SCM_COMPLEXP (z
))
8529 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8530 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8531 w
= cosh (x
) + cos (y
);
8532 #ifndef ALLOW_DIVIDE_BY_ZERO
8534 scm_num_overflow (s_scm_tanh
);
8536 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8539 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8543 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8545 "Compute the arc sine of @var{z}.")
8546 #define FUNC_NAME s_scm_asin
8548 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8549 return z
; /* asin(exact0) = exact0 */
8550 else if (scm_is_real (z
))
8552 double w
= scm_to_double (z
);
8553 if (w
>= -1.0 && w
<= 1.0)
8554 return scm_from_double (asin (w
));
8556 return scm_product (scm_c_make_rectangular (0, -1),
8557 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8559 else if (SCM_COMPLEXP (z
))
8561 x
= SCM_COMPLEX_REAL (z
);
8562 y
= SCM_COMPLEX_IMAG (z
);
8563 return scm_product (scm_c_make_rectangular (0, -1),
8564 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8567 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8571 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8573 "Compute the arc cosine of @var{z}.")
8574 #define FUNC_NAME s_scm_acos
8576 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8577 return SCM_INUM0
; /* acos(exact1) = exact0 */
8578 else if (scm_is_real (z
))
8580 double w
= scm_to_double (z
);
8581 if (w
>= -1.0 && w
<= 1.0)
8582 return scm_from_double (acos (w
));
8584 return scm_sum (scm_from_double (acos (0.0)),
8585 scm_product (scm_c_make_rectangular (0, 1),
8586 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8588 else if (SCM_COMPLEXP (z
))
8590 x
= SCM_COMPLEX_REAL (z
);
8591 y
= SCM_COMPLEX_IMAG (z
);
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 (-y
, x
))));
8597 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8601 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8603 "With one argument, compute the arc tangent of @var{z}.\n"
8604 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8605 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8606 #define FUNC_NAME s_scm_atan
8610 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8611 return z
; /* atan(exact0) = exact0 */
8612 else if (scm_is_real (z
))
8613 return scm_from_double (atan (scm_to_double (z
)));
8614 else if (SCM_COMPLEXP (z
))
8617 v
= SCM_COMPLEX_REAL (z
);
8618 w
= SCM_COMPLEX_IMAG (z
);
8619 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8620 scm_c_make_rectangular (v
, w
+ 1.0))),
8621 scm_c_make_rectangular (0, 2));
8624 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8626 else if (scm_is_real (z
))
8628 if (scm_is_real (y
))
8629 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8631 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8634 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8638 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8640 "Compute the inverse hyperbolic sine of @var{z}.")
8641 #define FUNC_NAME s_scm_sys_asinh
8643 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8644 return z
; /* asinh(exact0) = exact0 */
8645 else if (scm_is_real (z
))
8646 return scm_from_double (asinh (scm_to_double (z
)));
8647 else if (scm_is_number (z
))
8648 return scm_log (scm_sum (z
,
8649 scm_sqrt (scm_sum (scm_product (z
, z
),
8652 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8656 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8658 "Compute the inverse hyperbolic cosine of @var{z}.")
8659 #define FUNC_NAME s_scm_sys_acosh
8661 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8662 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8663 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8664 return scm_from_double (acosh (scm_to_double (z
)));
8665 else if (scm_is_number (z
))
8666 return scm_log (scm_sum (z
,
8667 scm_sqrt (scm_difference (scm_product (z
, z
),
8670 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8674 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8676 "Compute the inverse hyperbolic tangent of @var{z}.")
8677 #define FUNC_NAME s_scm_sys_atanh
8679 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8680 return z
; /* atanh(exact0) = exact0 */
8681 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8682 return scm_from_double (atanh (scm_to_double (z
)));
8683 else if (scm_is_number (z
))
8684 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8685 scm_difference (SCM_INUM1
, z
))),
8688 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8693 scm_c_make_rectangular (double re
, double im
)
8697 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8699 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8700 SCM_COMPLEX_REAL (z
) = re
;
8701 SCM_COMPLEX_IMAG (z
) = im
;
8705 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8706 (SCM real_part
, SCM imaginary_part
),
8707 "Return a complex number constructed of the given @var{real_part} "
8708 "and @var{imaginary_part} parts.")
8709 #define FUNC_NAME s_scm_make_rectangular
8711 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8712 SCM_ARG1
, FUNC_NAME
, "real");
8713 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8714 SCM_ARG2
, FUNC_NAME
, "real");
8716 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8717 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8720 return scm_c_make_rectangular (scm_to_double (real_part
),
8721 scm_to_double (imaginary_part
));
8726 scm_c_make_polar (double mag
, double ang
)
8730 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8731 use it on Glibc-based systems that have it (it's a GNU extension). See
8732 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8734 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8735 sincos (ang
, &s
, &c
);
8741 /* If s and c are NaNs, this indicates that the angle is a NaN,
8742 infinite, or perhaps simply too large to determine its value
8743 mod 2*pi. However, we know something that the floating-point
8744 implementation doesn't know: We know that s and c are finite.
8745 Therefore, if the magnitude is zero, return a complex zero.
8747 The reason we check for the NaNs instead of using this case
8748 whenever mag == 0.0 is because when the angle is known, we'd
8749 like to return the correct kind of non-real complex zero:
8750 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8751 on which quadrant the angle is in.
8753 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8754 return scm_c_make_rectangular (0.0, 0.0);
8756 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8759 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8761 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8762 #define FUNC_NAME s_scm_make_polar
8764 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8765 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8767 /* If mag is exact0, return exact0 */
8768 if (scm_is_eq (mag
, SCM_INUM0
))
8770 /* Return a real if ang is exact0 */
8771 else if (scm_is_eq (ang
, SCM_INUM0
))
8774 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8779 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8781 "Return the real part of the number @var{z}.")
8782 #define FUNC_NAME s_scm_real_part
8784 if (SCM_COMPLEXP (z
))
8785 return scm_from_double (SCM_COMPLEX_REAL (z
));
8786 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8789 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8794 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8796 "Return the imaginary part of the number @var{z}.")
8797 #define FUNC_NAME s_scm_imag_part
8799 if (SCM_COMPLEXP (z
))
8800 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8801 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8804 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8808 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8810 "Return the numerator of the number @var{z}.")
8811 #define FUNC_NAME s_scm_numerator
8813 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8815 else if (SCM_FRACTIONP (z
))
8816 return SCM_FRACTION_NUMERATOR (z
);
8817 else if (SCM_REALP (z
))
8818 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8820 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8825 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8827 "Return the denominator of the number @var{z}.")
8828 #define FUNC_NAME s_scm_denominator
8830 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8832 else if (SCM_FRACTIONP (z
))
8833 return SCM_FRACTION_DENOMINATOR (z
);
8834 else if (SCM_REALP (z
))
8835 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8837 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
8843 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8845 "Return the magnitude of the number @var{z}. This is the same as\n"
8846 "@code{abs} for real arguments, but also allows complex numbers.")
8847 #define FUNC_NAME s_scm_magnitude
8849 if (SCM_I_INUMP (z
))
8851 scm_t_inum zz
= SCM_I_INUM (z
);
8854 else if (SCM_POSFIXABLE (-zz
))
8855 return SCM_I_MAKINUM (-zz
);
8857 return scm_i_inum2big (-zz
);
8859 else if (SCM_BIGP (z
))
8861 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8862 scm_remember_upto_here_1 (z
);
8864 return scm_i_clonebig (z
, 0);
8868 else if (SCM_REALP (z
))
8869 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8870 else if (SCM_COMPLEXP (z
))
8871 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8872 else if (SCM_FRACTIONP (z
))
8874 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8876 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8877 SCM_FRACTION_DENOMINATOR (z
));
8880 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
8886 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8888 "Return the angle of the complex number @var{z}.")
8889 #define FUNC_NAME s_scm_angle
8891 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8892 flo0 to save allocating a new flonum with scm_from_double each time.
8893 But if atan2 follows the floating point rounding mode, then the value
8894 is not a constant. Maybe it'd be close enough though. */
8895 if (SCM_I_INUMP (z
))
8897 if (SCM_I_INUM (z
) >= 0)
8900 return scm_from_double (atan2 (0.0, -1.0));
8902 else if (SCM_BIGP (z
))
8904 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8905 scm_remember_upto_here_1 (z
);
8907 return scm_from_double (atan2 (0.0, -1.0));
8911 else if (SCM_REALP (z
))
8913 if (SCM_REAL_VALUE (z
) >= 0)
8916 return scm_from_double (atan2 (0.0, -1.0));
8918 else if (SCM_COMPLEXP (z
))
8919 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8920 else if (SCM_FRACTIONP (z
))
8922 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8924 else return scm_from_double (atan2 (0.0, -1.0));
8927 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8932 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8934 "Convert the number @var{z} to its inexact representation.\n")
8935 #define FUNC_NAME s_scm_exact_to_inexact
8937 if (SCM_I_INUMP (z
))
8938 return scm_from_double ((double) SCM_I_INUM (z
));
8939 else if (SCM_BIGP (z
))
8940 return scm_from_double (scm_i_big2dbl (z
));
8941 else if (SCM_FRACTIONP (z
))
8942 return scm_from_double (scm_i_fraction2double (z
));
8943 else if (SCM_INEXACTP (z
))
8946 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
8947 s_scm_exact_to_inexact
);
8952 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8954 "Return an exact number that is numerically closest to @var{z}.")
8955 #define FUNC_NAME s_scm_inexact_to_exact
8957 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8964 val
= SCM_REAL_VALUE (z
);
8965 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8966 val
= SCM_COMPLEX_REAL (z
);
8968 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
8969 s_scm_inexact_to_exact
);
8971 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8972 SCM_OUT_OF_RANGE (1, z
);
8979 mpq_set_d (frac
, val
);
8980 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8981 scm_i_mpz2num (mpq_denref (frac
)));
8983 /* When scm_i_make_ratio throws, we leak the memory allocated
8993 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8995 "Returns the @emph{simplest} rational number differing\n"
8996 "from @var{x} by no more than @var{eps}.\n"
8998 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8999 "exact result when both its arguments are exact. Thus, you might need\n"
9000 "to use @code{inexact->exact} on the arguments.\n"
9003 "(rationalize (inexact->exact 1.2) 1/100)\n"
9006 #define FUNC_NAME s_scm_rationalize
9008 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9009 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9010 eps
= scm_abs (eps
);
9011 if (scm_is_false (scm_positive_p (eps
)))
9013 /* eps is either zero or a NaN */
9014 if (scm_is_true (scm_nan_p (eps
)))
9016 else if (SCM_INEXACTP (eps
))
9017 return scm_exact_to_inexact (x
);
9021 else if (scm_is_false (scm_finite_p (eps
)))
9023 if (scm_is_true (scm_finite_p (x
)))
9028 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9030 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9031 scm_ceiling (scm_difference (x
, eps
)))))
9033 /* There's an integer within range; we want the one closest to zero */
9034 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9036 /* zero is within range */
9037 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9042 else if (scm_is_true (scm_positive_p (x
)))
9043 return scm_ceiling (scm_difference (x
, eps
));
9045 return scm_floor (scm_sum (x
, eps
));
9049 /* Use continued fractions to find closest ratio. All
9050 arithmetic is done with exact numbers.
9053 SCM ex
= scm_inexact_to_exact (x
);
9054 SCM int_part
= scm_floor (ex
);
9056 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9057 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9061 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9062 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9064 /* We stop after a million iterations just to be absolutely sure
9065 that we don't go into an infinite loop. The process normally
9066 converges after less than a dozen iterations.
9069 while (++i
< 1000000)
9071 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9072 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9073 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9075 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9076 eps
))) /* abs(x-a/b) <= eps */
9078 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9079 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9080 return scm_exact_to_inexact (res
);
9084 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9086 tt
= scm_floor (rx
); /* tt = floor (rx) */
9092 scm_num_overflow (s_scm_rationalize
);
9097 /* conversion functions */
9100 scm_is_integer (SCM val
)
9102 return scm_is_true (scm_integer_p (val
));
9106 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9108 if (SCM_I_INUMP (val
))
9110 scm_t_signed_bits n
= SCM_I_INUM (val
);
9111 return n
>= min
&& n
<= max
;
9113 else if (SCM_BIGP (val
))
9115 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9117 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9119 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9121 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9122 return n
>= min
&& n
<= max
;
9132 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9133 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9136 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9137 SCM_I_BIG_MPZ (val
));
9139 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9151 return n
>= min
&& n
<= max
;
9159 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9161 if (SCM_I_INUMP (val
))
9163 scm_t_signed_bits n
= SCM_I_INUM (val
);
9164 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9166 else if (SCM_BIGP (val
))
9168 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9170 else if (max
<= ULONG_MAX
)
9172 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9174 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9175 return n
>= min
&& n
<= max
;
9185 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9188 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9189 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9192 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9193 SCM_I_BIG_MPZ (val
));
9195 return n
>= min
&& n
<= max
;
9203 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9205 scm_error (scm_out_of_range_key
,
9207 "Value out of range ~S to ~S: ~S",
9208 scm_list_3 (min
, max
, bad_val
),
9209 scm_list_1 (bad_val
));
9212 #define TYPE scm_t_intmax
9213 #define TYPE_MIN min
9214 #define TYPE_MAX max
9215 #define SIZEOF_TYPE 0
9216 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9217 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9218 #include "libguile/conv-integer.i.c"
9220 #define TYPE scm_t_uintmax
9221 #define TYPE_MIN min
9222 #define TYPE_MAX max
9223 #define SIZEOF_TYPE 0
9224 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9225 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9226 #include "libguile/conv-uinteger.i.c"
9228 #define TYPE scm_t_int8
9229 #define TYPE_MIN SCM_T_INT8_MIN
9230 #define TYPE_MAX SCM_T_INT8_MAX
9231 #define SIZEOF_TYPE 1
9232 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9233 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9234 #include "libguile/conv-integer.i.c"
9236 #define TYPE scm_t_uint8
9238 #define TYPE_MAX SCM_T_UINT8_MAX
9239 #define SIZEOF_TYPE 1
9240 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9241 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9242 #include "libguile/conv-uinteger.i.c"
9244 #define TYPE scm_t_int16
9245 #define TYPE_MIN SCM_T_INT16_MIN
9246 #define TYPE_MAX SCM_T_INT16_MAX
9247 #define SIZEOF_TYPE 2
9248 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9249 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9250 #include "libguile/conv-integer.i.c"
9252 #define TYPE scm_t_uint16
9254 #define TYPE_MAX SCM_T_UINT16_MAX
9255 #define SIZEOF_TYPE 2
9256 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9257 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9258 #include "libguile/conv-uinteger.i.c"
9260 #define TYPE scm_t_int32
9261 #define TYPE_MIN SCM_T_INT32_MIN
9262 #define TYPE_MAX SCM_T_INT32_MAX
9263 #define SIZEOF_TYPE 4
9264 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9265 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9266 #include "libguile/conv-integer.i.c"
9268 #define TYPE scm_t_uint32
9270 #define TYPE_MAX SCM_T_UINT32_MAX
9271 #define SIZEOF_TYPE 4
9272 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9273 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9274 #include "libguile/conv-uinteger.i.c"
9276 #define TYPE scm_t_wchar
9277 #define TYPE_MIN (scm_t_int32)-1
9278 #define TYPE_MAX (scm_t_int32)0x10ffff
9279 #define SIZEOF_TYPE 4
9280 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9281 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9282 #include "libguile/conv-integer.i.c"
9284 #define TYPE scm_t_int64
9285 #define TYPE_MIN SCM_T_INT64_MIN
9286 #define TYPE_MAX SCM_T_INT64_MAX
9287 #define SIZEOF_TYPE 8
9288 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9289 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9290 #include "libguile/conv-integer.i.c"
9292 #define TYPE scm_t_uint64
9294 #define TYPE_MAX SCM_T_UINT64_MAX
9295 #define SIZEOF_TYPE 8
9296 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9297 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9298 #include "libguile/conv-uinteger.i.c"
9301 scm_to_mpz (SCM val
, mpz_t rop
)
9303 if (SCM_I_INUMP (val
))
9304 mpz_set_si (rop
, SCM_I_INUM (val
));
9305 else if (SCM_BIGP (val
))
9306 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9308 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9312 scm_from_mpz (mpz_t val
)
9314 return scm_i_mpz2num (val
);
9318 scm_is_real (SCM val
)
9320 return scm_is_true (scm_real_p (val
));
9324 scm_is_rational (SCM val
)
9326 return scm_is_true (scm_rational_p (val
));
9330 scm_to_double (SCM val
)
9332 if (SCM_I_INUMP (val
))
9333 return SCM_I_INUM (val
);
9334 else if (SCM_BIGP (val
))
9335 return scm_i_big2dbl (val
);
9336 else if (SCM_FRACTIONP (val
))
9337 return scm_i_fraction2double (val
);
9338 else if (SCM_REALP (val
))
9339 return SCM_REAL_VALUE (val
);
9341 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9345 scm_from_double (double val
)
9349 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9351 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9352 SCM_REAL_VALUE (z
) = val
;
9358 scm_is_complex (SCM val
)
9360 return scm_is_true (scm_complex_p (val
));
9364 scm_c_real_part (SCM z
)
9366 if (SCM_COMPLEXP (z
))
9367 return SCM_COMPLEX_REAL (z
);
9370 /* Use the scm_real_part to get proper error checking and
9373 return scm_to_double (scm_real_part (z
));
9378 scm_c_imag_part (SCM z
)
9380 if (SCM_COMPLEXP (z
))
9381 return SCM_COMPLEX_IMAG (z
);
9384 /* Use the scm_imag_part to get proper error checking and
9385 dispatching. The result will almost always be 0.0, but not
9388 return scm_to_double (scm_imag_part (z
));
9393 scm_c_magnitude (SCM z
)
9395 return scm_to_double (scm_magnitude (z
));
9401 return scm_to_double (scm_angle (z
));
9405 scm_is_number (SCM z
)
9407 return scm_is_true (scm_number_p (z
));
9411 /* Returns log(x * 2^shift) */
9413 log_of_shifted_double (double x
, long shift
)
9415 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9417 if (x
> 0.0 || double_is_non_negative_zero (x
))
9418 return scm_from_double (ans
);
9420 return scm_c_make_rectangular (ans
, M_PI
);
9423 /* Returns log(n), for exact integer n of integer-length size */
9425 log_of_exact_integer_with_size (SCM n
, long size
)
9427 long shift
= size
- 2 * scm_dblprec
[0];
9430 return log_of_shifted_double
9431 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9434 return log_of_shifted_double (scm_to_double (n
), 0);
9437 /* Returns log(n), for exact integer n */
9439 log_of_exact_integer (SCM n
)
9441 return log_of_exact_integer_with_size
9442 (n
, scm_to_long (scm_integer_length (n
)));
9445 /* Returns log(n/d), for exact non-zero integers n and d */
9447 log_of_fraction (SCM n
, SCM d
)
9449 long n_size
= scm_to_long (scm_integer_length (n
));
9450 long d_size
= scm_to_long (scm_integer_length (d
));
9452 if (abs (n_size
- d_size
) > 1)
9453 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9454 log_of_exact_integer_with_size (d
, d_size
)));
9455 else if (scm_is_false (scm_negative_p (n
)))
9456 return scm_from_double
9457 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9459 return scm_c_make_rectangular
9460 (log1p (scm_to_double (scm_divide2real
9461 (scm_difference (scm_abs (n
), d
),
9467 /* In the following functions we dispatch to the real-arg funcs like log()
9468 when we know the arg is real, instead of just handing everything to
9469 clog() for instance. This is in case clog() doesn't optimize for a
9470 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9471 well use it to go straight to the applicable C func. */
9473 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9475 "Return the natural logarithm of @var{z}.")
9476 #define FUNC_NAME s_scm_log
9478 if (SCM_COMPLEXP (z
))
9480 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9481 && defined (SCM_COMPLEX_VALUE)
9482 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9484 double re
= SCM_COMPLEX_REAL (z
);
9485 double im
= SCM_COMPLEX_IMAG (z
);
9486 return scm_c_make_rectangular (log (hypot (re
, im
)),
9490 else if (SCM_REALP (z
))
9491 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9492 else if (SCM_I_INUMP (z
))
9494 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9495 if (scm_is_eq (z
, SCM_INUM0
))
9496 scm_num_overflow (s_scm_log
);
9498 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9500 else if (SCM_BIGP (z
))
9501 return log_of_exact_integer (z
);
9502 else if (SCM_FRACTIONP (z
))
9503 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9504 SCM_FRACTION_DENOMINATOR (z
));
9506 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
9511 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9513 "Return the base 10 logarithm of @var{z}.")
9514 #define FUNC_NAME s_scm_log10
9516 if (SCM_COMPLEXP (z
))
9518 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9519 clog() and a multiply by M_LOG10E, rather than the fallback
9520 log10+hypot+atan2.) */
9521 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9522 && defined SCM_COMPLEX_VALUE
9523 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9525 double re
= SCM_COMPLEX_REAL (z
);
9526 double im
= SCM_COMPLEX_IMAG (z
);
9527 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9528 M_LOG10E
* atan2 (im
, re
));
9531 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9533 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9534 if (scm_is_eq (z
, SCM_INUM0
))
9535 scm_num_overflow (s_scm_log10
);
9538 double re
= scm_to_double (z
);
9539 double l
= log10 (fabs (re
));
9540 if (re
> 0.0 || double_is_non_negative_zero (re
))
9541 return scm_from_double (l
);
9543 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9546 else if (SCM_BIGP (z
))
9547 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9548 else if (SCM_FRACTIONP (z
))
9549 return scm_product (flo_log10e
,
9550 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9551 SCM_FRACTION_DENOMINATOR (z
)));
9553 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9558 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9560 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9561 "base of natural logarithms (2.71828@dots{}).")
9562 #define FUNC_NAME s_scm_exp
9564 if (SCM_COMPLEXP (z
))
9566 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9567 && defined (SCM_COMPLEX_VALUE)
9568 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9570 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9571 SCM_COMPLEX_IMAG (z
));
9574 else if (SCM_NUMBERP (z
))
9576 /* When z is a negative bignum the conversion to double overflows,
9577 giving -infinity, but that's ok, the exp is still 0.0. */
9578 return scm_from_double (exp (scm_to_double (z
)));
9581 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9586 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9588 "Return two exact non-negative integers @var{s} and @var{r}\n"
9589 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9590 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9591 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9594 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9596 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9600 scm_exact_integer_sqrt (k
, &s
, &r
);
9601 return scm_values (scm_list_2 (s
, r
));
9606 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9608 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9610 scm_t_inum kk
= SCM_I_INUM (k
);
9614 if (SCM_LIKELY (kk
> 0))
9619 uu
= (ss
+ kk
/ss
) / 2;
9621 *sp
= SCM_I_MAKINUM (ss
);
9622 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9624 else if (SCM_LIKELY (kk
== 0))
9625 *sp
= *rp
= SCM_INUM0
;
9627 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9628 "exact non-negative integer");
9630 else if (SCM_LIKELY (SCM_BIGP (k
)))
9634 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9635 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9636 "exact non-negative integer");
9639 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9640 scm_remember_upto_here_1 (k
);
9641 *sp
= scm_i_normbig (s
);
9642 *rp
= scm_i_normbig (r
);
9645 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9646 "exact non-negative integer");
9650 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9652 "Return the square root of @var{z}. Of the two possible roots\n"
9653 "(positive and negative), the one with positive real part\n"
9654 "is returned, or if that's zero then a positive imaginary part.\n"
9658 "(sqrt 9.0) @result{} 3.0\n"
9659 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9660 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9661 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9663 #define FUNC_NAME s_scm_sqrt
9665 if (SCM_COMPLEXP (z
))
9667 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9668 && defined SCM_COMPLEX_VALUE
9669 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9671 double re
= SCM_COMPLEX_REAL (z
);
9672 double im
= SCM_COMPLEX_IMAG (z
);
9673 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9674 0.5 * atan2 (im
, re
));
9677 else if (SCM_NUMBERP (z
))
9679 double xx
= scm_to_double (z
);
9681 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9683 return scm_from_double (sqrt (xx
));
9686 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9697 if (scm_install_gmp_memory_functions
)
9698 mp_set_memory_functions (custom_gmp_malloc
,
9702 mpz_init_set_si (z_negative_one
, -1);
9704 /* It may be possible to tune the performance of some algorithms by using
9705 * the following constants to avoid the creation of bignums. Please, before
9706 * using these values, remember the two rules of program optimization:
9707 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9708 scm_c_define ("most-positive-fixnum",
9709 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9710 scm_c_define ("most-negative-fixnum",
9711 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9713 scm_add_feature ("complex");
9714 scm_add_feature ("inexact");
9715 flo0
= scm_from_double (0.0);
9716 flo_log10e
= scm_from_double (M_LOG10E
);
9718 /* determine floating point precision */
9719 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9721 init_dblprec(&scm_dblprec
[i
-2],i
);
9722 init_fx_radix(fx_per_radix
[i
-2],i
);
9725 /* hard code precision for base 10 if the preprocessor tells us to... */
9726 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9729 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9730 #include "libguile/numbers.x"