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
= PTR2SCM (ptr
);
187 mpz_clear (SCM_I_BIG_MPZ (bignum
));
190 /* The next three functions (custom_libgmp_*) are passed to
191 mp_set_memory_functions (in GMP) so that memory used by the digits
192 themselves is known to the garbage collector. This is needed so
193 that GC will be run at appropriate times. Otherwise, a program which
194 creates many large bignums would malloc a huge amount of memory
195 before the GC runs. */
197 custom_gmp_malloc (size_t alloc_size
)
199 return scm_malloc (alloc_size
);
203 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
205 return scm_realloc (old_ptr
, new_size
);
209 custom_gmp_free (void *ptr
, size_t size
)
215 /* Return a new uninitialized bignum. */
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 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 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 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 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 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 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 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 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 SCM_WTA_DISPATCH_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
849 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 SCM_WTA_DISPATCH_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
870 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 SCM_WTA_DISPATCH_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
892 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
)
914 scm_i_extract_values_2 (scm_call_generic_2 (gf
, a1
, a2
), rp1
, rp2
);
916 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
919 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
921 "Return the integer @var{q} such that\n"
922 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
923 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
925 "(euclidean-quotient 123 10) @result{} 12\n"
926 "(euclidean-quotient 123 -10) @result{} -12\n"
927 "(euclidean-quotient -123 10) @result{} -13\n"
928 "(euclidean-quotient -123 -10) @result{} 13\n"
929 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
930 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
932 #define FUNC_NAME s_scm_euclidean_quotient
934 if (scm_is_false (scm_negative_p (y
)))
935 return scm_floor_quotient (x
, y
);
937 return scm_ceiling_quotient (x
, y
);
941 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
943 "Return the real number @var{r} such that\n"
944 "@math{0 <= @var{r} < abs(@var{y})} and\n"
945 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
946 "for some integer @var{q}.\n"
948 "(euclidean-remainder 123 10) @result{} 3\n"
949 "(euclidean-remainder 123 -10) @result{} 3\n"
950 "(euclidean-remainder -123 10) @result{} 7\n"
951 "(euclidean-remainder -123 -10) @result{} 7\n"
952 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
953 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
955 #define FUNC_NAME s_scm_euclidean_remainder
957 if (scm_is_false (scm_negative_p (y
)))
958 return scm_floor_remainder (x
, y
);
960 return scm_ceiling_remainder (x
, y
);
964 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
966 "Return the integer @var{q} and the real number @var{r}\n"
967 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
968 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
970 "(euclidean/ 123 10) @result{} 12 and 3\n"
971 "(euclidean/ 123 -10) @result{} -12 and 3\n"
972 "(euclidean/ -123 10) @result{} -13 and 7\n"
973 "(euclidean/ -123 -10) @result{} 13 and 7\n"
974 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
975 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
977 #define FUNC_NAME s_scm_i_euclidean_divide
979 if (scm_is_false (scm_negative_p (y
)))
980 return scm_i_floor_divide (x
, y
);
982 return scm_i_ceiling_divide (x
, y
);
987 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
989 if (scm_is_false (scm_negative_p (y
)))
990 return scm_floor_divide (x
, y
, qp
, rp
);
992 return scm_ceiling_divide (x
, y
, qp
, rp
);
995 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
996 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
998 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
1000 "Return the floor of @math{@var{x} / @var{y}}.\n"
1002 "(floor-quotient 123 10) @result{} 12\n"
1003 "(floor-quotient 123 -10) @result{} -13\n"
1004 "(floor-quotient -123 10) @result{} -13\n"
1005 "(floor-quotient -123 -10) @result{} 12\n"
1006 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1007 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1009 #define FUNC_NAME s_scm_floor_quotient
1011 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1013 scm_t_inum xx
= SCM_I_INUM (x
);
1014 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1016 scm_t_inum yy
= SCM_I_INUM (y
);
1017 scm_t_inum xx1
= xx
;
1019 if (SCM_LIKELY (yy
> 0))
1021 if (SCM_UNLIKELY (xx
< 0))
1024 else if (SCM_UNLIKELY (yy
== 0))
1025 scm_num_overflow (s_scm_floor_quotient
);
1029 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1030 return SCM_I_MAKINUM (qq
);
1032 return scm_i_inum2big (qq
);
1034 else if (SCM_BIGP (y
))
1036 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1037 scm_remember_upto_here_1 (y
);
1039 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1041 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1043 else if (SCM_REALP (y
))
1044 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1045 else if (SCM_FRACTIONP (y
))
1046 return scm_i_exact_rational_floor_quotient (x
, y
);
1048 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1049 s_scm_floor_quotient
);
1051 else if (SCM_BIGP (x
))
1053 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1055 scm_t_inum yy
= SCM_I_INUM (y
);
1056 if (SCM_UNLIKELY (yy
== 0))
1057 scm_num_overflow (s_scm_floor_quotient
);
1058 else if (SCM_UNLIKELY (yy
== 1))
1062 SCM q
= scm_i_mkbig ();
1064 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1067 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1068 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1070 scm_remember_upto_here_1 (x
);
1071 return scm_i_normbig (q
);
1074 else if (SCM_BIGP (y
))
1076 SCM q
= scm_i_mkbig ();
1077 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1080 scm_remember_upto_here_2 (x
, y
);
1081 return scm_i_normbig (q
);
1083 else if (SCM_REALP (y
))
1084 return scm_i_inexact_floor_quotient
1085 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1086 else if (SCM_FRACTIONP (y
))
1087 return scm_i_exact_rational_floor_quotient (x
, y
);
1089 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1090 s_scm_floor_quotient
);
1092 else if (SCM_REALP (x
))
1094 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1095 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1096 return scm_i_inexact_floor_quotient
1097 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1099 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1100 s_scm_floor_quotient
);
1102 else if (SCM_FRACTIONP (x
))
1105 return scm_i_inexact_floor_quotient
1106 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1107 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1108 return scm_i_exact_rational_floor_quotient (x
, y
);
1110 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1111 s_scm_floor_quotient
);
1114 SCM_WTA_DISPATCH_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1115 s_scm_floor_quotient
);
1120 scm_i_inexact_floor_quotient (double x
, double y
)
1122 if (SCM_UNLIKELY (y
== 0))
1123 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1125 return scm_from_double (floor (x
/ y
));
1129 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1131 return scm_floor_quotient
1132 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1133 scm_product (scm_numerator (y
), scm_denominator (x
)));
1136 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1137 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1139 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1141 "Return the real number @var{r} such that\n"
1142 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1143 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1145 "(floor-remainder 123 10) @result{} 3\n"
1146 "(floor-remainder 123 -10) @result{} -7\n"
1147 "(floor-remainder -123 10) @result{} 7\n"
1148 "(floor-remainder -123 -10) @result{} -3\n"
1149 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1150 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1152 #define FUNC_NAME s_scm_floor_remainder
1154 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1156 scm_t_inum xx
= SCM_I_INUM (x
);
1157 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1159 scm_t_inum yy
= SCM_I_INUM (y
);
1160 if (SCM_UNLIKELY (yy
== 0))
1161 scm_num_overflow (s_scm_floor_remainder
);
1164 scm_t_inum rr
= xx
% yy
;
1165 int needs_adjustment
;
1167 if (SCM_LIKELY (yy
> 0))
1168 needs_adjustment
= (rr
< 0);
1170 needs_adjustment
= (rr
> 0);
1172 if (needs_adjustment
)
1174 return SCM_I_MAKINUM (rr
);
1177 else if (SCM_BIGP (y
))
1179 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1180 scm_remember_upto_here_1 (y
);
1185 SCM r
= scm_i_mkbig ();
1186 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1187 scm_remember_upto_here_1 (y
);
1188 return scm_i_normbig (r
);
1197 SCM r
= scm_i_mkbig ();
1198 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1199 scm_remember_upto_here_1 (y
);
1200 return scm_i_normbig (r
);
1203 else if (SCM_REALP (y
))
1204 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1205 else if (SCM_FRACTIONP (y
))
1206 return scm_i_exact_rational_floor_remainder (x
, y
);
1208 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1209 s_scm_floor_remainder
);
1211 else if (SCM_BIGP (x
))
1213 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1215 scm_t_inum yy
= SCM_I_INUM (y
);
1216 if (SCM_UNLIKELY (yy
== 0))
1217 scm_num_overflow (s_scm_floor_remainder
);
1222 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1224 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1225 scm_remember_upto_here_1 (x
);
1226 return SCM_I_MAKINUM (rr
);
1229 else if (SCM_BIGP (y
))
1231 SCM r
= scm_i_mkbig ();
1232 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1235 scm_remember_upto_here_2 (x
, y
);
1236 return scm_i_normbig (r
);
1238 else if (SCM_REALP (y
))
1239 return scm_i_inexact_floor_remainder
1240 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1241 else if (SCM_FRACTIONP (y
))
1242 return scm_i_exact_rational_floor_remainder (x
, y
);
1244 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1245 s_scm_floor_remainder
);
1247 else if (SCM_REALP (x
))
1249 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1250 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1251 return scm_i_inexact_floor_remainder
1252 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1254 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1255 s_scm_floor_remainder
);
1257 else if (SCM_FRACTIONP (x
))
1260 return scm_i_inexact_floor_remainder
1261 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1262 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1263 return scm_i_exact_rational_floor_remainder (x
, y
);
1265 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1266 s_scm_floor_remainder
);
1269 SCM_WTA_DISPATCH_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1270 s_scm_floor_remainder
);
1275 scm_i_inexact_floor_remainder (double x
, double y
)
1277 /* Although it would be more efficient to use fmod here, we can't
1278 because it would in some cases produce results inconsistent with
1279 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1280 close). In particular, when x is very close to a multiple of y,
1281 then r might be either 0.0 or y, but those two cases must
1282 correspond to different choices of q. If r = 0.0 then q must be
1283 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1284 and remainder chooses the other, it would be bad. */
1285 if (SCM_UNLIKELY (y
== 0))
1286 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1288 return scm_from_double (x
- y
* floor (x
/ y
));
1292 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1294 SCM xd
= scm_denominator (x
);
1295 SCM yd
= scm_denominator (y
);
1296 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1297 scm_product (scm_numerator (y
), xd
));
1298 return scm_divide (r1
, scm_product (xd
, yd
));
1302 static void scm_i_inexact_floor_divide (double x
, double y
,
1304 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1307 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1309 "Return the integer @var{q} and the real number @var{r}\n"
1310 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1311 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1313 "(floor/ 123 10) @result{} 12 and 3\n"
1314 "(floor/ 123 -10) @result{} -13 and -7\n"
1315 "(floor/ -123 10) @result{} -13 and 7\n"
1316 "(floor/ -123 -10) @result{} 12 and -3\n"
1317 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1318 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1320 #define FUNC_NAME s_scm_i_floor_divide
1324 scm_floor_divide(x
, y
, &q
, &r
);
1325 return scm_values (scm_list_2 (q
, r
));
1329 #define s_scm_floor_divide s_scm_i_floor_divide
1330 #define g_scm_floor_divide g_scm_i_floor_divide
1333 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1335 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1337 scm_t_inum xx
= SCM_I_INUM (x
);
1338 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1340 scm_t_inum yy
= SCM_I_INUM (y
);
1341 if (SCM_UNLIKELY (yy
== 0))
1342 scm_num_overflow (s_scm_floor_divide
);
1345 scm_t_inum qq
= xx
/ yy
;
1346 scm_t_inum rr
= xx
% yy
;
1347 int needs_adjustment
;
1349 if (SCM_LIKELY (yy
> 0))
1350 needs_adjustment
= (rr
< 0);
1352 needs_adjustment
= (rr
> 0);
1354 if (needs_adjustment
)
1360 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1361 *qp
= SCM_I_MAKINUM (qq
);
1363 *qp
= scm_i_inum2big (qq
);
1364 *rp
= SCM_I_MAKINUM (rr
);
1368 else if (SCM_BIGP (y
))
1370 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1371 scm_remember_upto_here_1 (y
);
1376 SCM r
= scm_i_mkbig ();
1377 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1378 scm_remember_upto_here_1 (y
);
1379 *qp
= SCM_I_MAKINUM (-1);
1380 *rp
= scm_i_normbig (r
);
1395 SCM r
= scm_i_mkbig ();
1396 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1397 scm_remember_upto_here_1 (y
);
1398 *qp
= SCM_I_MAKINUM (-1);
1399 *rp
= scm_i_normbig (r
);
1403 else if (SCM_REALP (y
))
1404 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1405 else if (SCM_FRACTIONP (y
))
1406 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1408 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1409 s_scm_floor_divide
, qp
, rp
);
1411 else if (SCM_BIGP (x
))
1413 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1415 scm_t_inum yy
= SCM_I_INUM (y
);
1416 if (SCM_UNLIKELY (yy
== 0))
1417 scm_num_overflow (s_scm_floor_divide
);
1420 SCM q
= scm_i_mkbig ();
1421 SCM r
= scm_i_mkbig ();
1423 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1424 SCM_I_BIG_MPZ (x
), yy
);
1427 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1428 SCM_I_BIG_MPZ (x
), -yy
);
1429 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1431 scm_remember_upto_here_1 (x
);
1432 *qp
= scm_i_normbig (q
);
1433 *rp
= scm_i_normbig (r
);
1437 else if (SCM_BIGP (y
))
1439 SCM q
= scm_i_mkbig ();
1440 SCM r
= scm_i_mkbig ();
1441 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1442 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1443 scm_remember_upto_here_2 (x
, y
);
1444 *qp
= scm_i_normbig (q
);
1445 *rp
= scm_i_normbig (r
);
1448 else if (SCM_REALP (y
))
1449 return scm_i_inexact_floor_divide
1450 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1451 else if (SCM_FRACTIONP (y
))
1452 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1454 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1455 s_scm_floor_divide
, qp
, rp
);
1457 else if (SCM_REALP (x
))
1459 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1460 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1461 return scm_i_inexact_floor_divide
1462 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1464 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1465 s_scm_floor_divide
, qp
, rp
);
1467 else if (SCM_FRACTIONP (x
))
1470 return scm_i_inexact_floor_divide
1471 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1472 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1473 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1475 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1476 s_scm_floor_divide
, qp
, rp
);
1479 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1480 s_scm_floor_divide
, qp
, rp
);
1484 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1486 if (SCM_UNLIKELY (y
== 0))
1487 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1490 double q
= floor (x
/ y
);
1491 double r
= x
- q
* y
;
1492 *qp
= scm_from_double (q
);
1493 *rp
= scm_from_double (r
);
1498 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1501 SCM xd
= scm_denominator (x
);
1502 SCM yd
= scm_denominator (y
);
1504 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1505 scm_product (scm_numerator (y
), xd
),
1507 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1510 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1511 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1513 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1515 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1517 "(ceiling-quotient 123 10) @result{} 13\n"
1518 "(ceiling-quotient 123 -10) @result{} -12\n"
1519 "(ceiling-quotient -123 10) @result{} -12\n"
1520 "(ceiling-quotient -123 -10) @result{} 13\n"
1521 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1522 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1524 #define FUNC_NAME s_scm_ceiling_quotient
1526 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1528 scm_t_inum xx
= SCM_I_INUM (x
);
1529 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1531 scm_t_inum yy
= SCM_I_INUM (y
);
1532 if (SCM_UNLIKELY (yy
== 0))
1533 scm_num_overflow (s_scm_ceiling_quotient
);
1536 scm_t_inum xx1
= xx
;
1538 if (SCM_LIKELY (yy
> 0))
1540 if (SCM_LIKELY (xx
>= 0))
1546 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1547 return SCM_I_MAKINUM (qq
);
1549 return scm_i_inum2big (qq
);
1552 else if (SCM_BIGP (y
))
1554 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1555 scm_remember_upto_here_1 (y
);
1556 if (SCM_LIKELY (sign
> 0))
1558 if (SCM_LIKELY (xx
> 0))
1560 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1561 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1562 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1564 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1565 scm_remember_upto_here_1 (y
);
1566 return SCM_I_MAKINUM (-1);
1576 else if (SCM_REALP (y
))
1577 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1578 else if (SCM_FRACTIONP (y
))
1579 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1581 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1582 s_scm_ceiling_quotient
);
1584 else if (SCM_BIGP (x
))
1586 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1588 scm_t_inum yy
= SCM_I_INUM (y
);
1589 if (SCM_UNLIKELY (yy
== 0))
1590 scm_num_overflow (s_scm_ceiling_quotient
);
1591 else if (SCM_UNLIKELY (yy
== 1))
1595 SCM q
= scm_i_mkbig ();
1597 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1600 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1601 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1603 scm_remember_upto_here_1 (x
);
1604 return scm_i_normbig (q
);
1607 else if (SCM_BIGP (y
))
1609 SCM q
= scm_i_mkbig ();
1610 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1613 scm_remember_upto_here_2 (x
, y
);
1614 return scm_i_normbig (q
);
1616 else if (SCM_REALP (y
))
1617 return scm_i_inexact_ceiling_quotient
1618 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1619 else if (SCM_FRACTIONP (y
))
1620 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1622 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1623 s_scm_ceiling_quotient
);
1625 else if (SCM_REALP (x
))
1627 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1628 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1629 return scm_i_inexact_ceiling_quotient
1630 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1632 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1633 s_scm_ceiling_quotient
);
1635 else if (SCM_FRACTIONP (x
))
1638 return scm_i_inexact_ceiling_quotient
1639 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1640 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1641 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1643 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1644 s_scm_ceiling_quotient
);
1647 SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1648 s_scm_ceiling_quotient
);
1653 scm_i_inexact_ceiling_quotient (double x
, double y
)
1655 if (SCM_UNLIKELY (y
== 0))
1656 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1658 return scm_from_double (ceil (x
/ y
));
1662 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1664 return scm_ceiling_quotient
1665 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1666 scm_product (scm_numerator (y
), scm_denominator (x
)));
1669 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1670 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1672 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1674 "Return the real number @var{r} such that\n"
1675 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1676 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1678 "(ceiling-remainder 123 10) @result{} -7\n"
1679 "(ceiling-remainder 123 -10) @result{} 3\n"
1680 "(ceiling-remainder -123 10) @result{} -3\n"
1681 "(ceiling-remainder -123 -10) @result{} 7\n"
1682 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1683 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1685 #define FUNC_NAME s_scm_ceiling_remainder
1687 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1689 scm_t_inum xx
= SCM_I_INUM (x
);
1690 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1692 scm_t_inum yy
= SCM_I_INUM (y
);
1693 if (SCM_UNLIKELY (yy
== 0))
1694 scm_num_overflow (s_scm_ceiling_remainder
);
1697 scm_t_inum rr
= xx
% yy
;
1698 int needs_adjustment
;
1700 if (SCM_LIKELY (yy
> 0))
1701 needs_adjustment
= (rr
> 0);
1703 needs_adjustment
= (rr
< 0);
1705 if (needs_adjustment
)
1707 return SCM_I_MAKINUM (rr
);
1710 else if (SCM_BIGP (y
))
1712 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1713 scm_remember_upto_here_1 (y
);
1714 if (SCM_LIKELY (sign
> 0))
1716 if (SCM_LIKELY (xx
> 0))
1718 SCM r
= scm_i_mkbig ();
1719 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1720 scm_remember_upto_here_1 (y
);
1721 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1722 return scm_i_normbig (r
);
1724 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1725 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1726 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1728 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1729 scm_remember_upto_here_1 (y
);
1739 SCM r
= scm_i_mkbig ();
1740 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1741 scm_remember_upto_here_1 (y
);
1742 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1743 return scm_i_normbig (r
);
1746 else if (SCM_REALP (y
))
1747 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1748 else if (SCM_FRACTIONP (y
))
1749 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1751 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1752 s_scm_ceiling_remainder
);
1754 else if (SCM_BIGP (x
))
1756 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1758 scm_t_inum yy
= SCM_I_INUM (y
);
1759 if (SCM_UNLIKELY (yy
== 0))
1760 scm_num_overflow (s_scm_ceiling_remainder
);
1765 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1767 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1768 scm_remember_upto_here_1 (x
);
1769 return SCM_I_MAKINUM (rr
);
1772 else if (SCM_BIGP (y
))
1774 SCM r
= scm_i_mkbig ();
1775 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1778 scm_remember_upto_here_2 (x
, y
);
1779 return scm_i_normbig (r
);
1781 else if (SCM_REALP (y
))
1782 return scm_i_inexact_ceiling_remainder
1783 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1784 else if (SCM_FRACTIONP (y
))
1785 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1787 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1788 s_scm_ceiling_remainder
);
1790 else if (SCM_REALP (x
))
1792 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1793 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1794 return scm_i_inexact_ceiling_remainder
1795 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1797 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1798 s_scm_ceiling_remainder
);
1800 else if (SCM_FRACTIONP (x
))
1803 return scm_i_inexact_ceiling_remainder
1804 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1805 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1806 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1808 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1809 s_scm_ceiling_remainder
);
1812 SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1813 s_scm_ceiling_remainder
);
1818 scm_i_inexact_ceiling_remainder (double x
, double y
)
1820 /* Although it would be more efficient to use fmod here, we can't
1821 because it would in some cases produce results inconsistent with
1822 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1823 close). In particular, when x is very close to a multiple of y,
1824 then r might be either 0.0 or -y, but those two cases must
1825 correspond to different choices of q. If r = 0.0 then q must be
1826 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1827 and remainder chooses the other, it would be bad. */
1828 if (SCM_UNLIKELY (y
== 0))
1829 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1831 return scm_from_double (x
- y
* ceil (x
/ y
));
1835 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1837 SCM xd
= scm_denominator (x
);
1838 SCM yd
= scm_denominator (y
);
1839 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1840 scm_product (scm_numerator (y
), xd
));
1841 return scm_divide (r1
, scm_product (xd
, yd
));
1844 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1846 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1849 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1851 "Return the integer @var{q} and the real number @var{r}\n"
1852 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1853 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1855 "(ceiling/ 123 10) @result{} 13 and -7\n"
1856 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1857 "(ceiling/ -123 10) @result{} -12 and -3\n"
1858 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1859 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1860 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1862 #define FUNC_NAME s_scm_i_ceiling_divide
1866 scm_ceiling_divide(x
, y
, &q
, &r
);
1867 return scm_values (scm_list_2 (q
, r
));
1871 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1872 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1875 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1877 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1879 scm_t_inum xx
= SCM_I_INUM (x
);
1880 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1882 scm_t_inum yy
= SCM_I_INUM (y
);
1883 if (SCM_UNLIKELY (yy
== 0))
1884 scm_num_overflow (s_scm_ceiling_divide
);
1887 scm_t_inum qq
= xx
/ yy
;
1888 scm_t_inum rr
= xx
% yy
;
1889 int needs_adjustment
;
1891 if (SCM_LIKELY (yy
> 0))
1892 needs_adjustment
= (rr
> 0);
1894 needs_adjustment
= (rr
< 0);
1896 if (needs_adjustment
)
1901 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1902 *qp
= SCM_I_MAKINUM (qq
);
1904 *qp
= scm_i_inum2big (qq
);
1905 *rp
= SCM_I_MAKINUM (rr
);
1909 else if (SCM_BIGP (y
))
1911 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1912 scm_remember_upto_here_1 (y
);
1913 if (SCM_LIKELY (sign
> 0))
1915 if (SCM_LIKELY (xx
> 0))
1917 SCM r
= scm_i_mkbig ();
1918 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1919 scm_remember_upto_here_1 (y
);
1920 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1922 *rp
= scm_i_normbig (r
);
1924 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1925 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1926 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1928 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1929 scm_remember_upto_here_1 (y
);
1930 *qp
= SCM_I_MAKINUM (-1);
1946 SCM r
= scm_i_mkbig ();
1947 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1948 scm_remember_upto_here_1 (y
);
1949 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1951 *rp
= scm_i_normbig (r
);
1955 else if (SCM_REALP (y
))
1956 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1957 else if (SCM_FRACTIONP (y
))
1958 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1960 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1961 s_scm_ceiling_divide
, qp
, rp
);
1963 else if (SCM_BIGP (x
))
1965 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1967 scm_t_inum yy
= SCM_I_INUM (y
);
1968 if (SCM_UNLIKELY (yy
== 0))
1969 scm_num_overflow (s_scm_ceiling_divide
);
1972 SCM q
= scm_i_mkbig ();
1973 SCM r
= scm_i_mkbig ();
1975 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1976 SCM_I_BIG_MPZ (x
), yy
);
1979 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1980 SCM_I_BIG_MPZ (x
), -yy
);
1981 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1983 scm_remember_upto_here_1 (x
);
1984 *qp
= scm_i_normbig (q
);
1985 *rp
= scm_i_normbig (r
);
1989 else if (SCM_BIGP (y
))
1991 SCM q
= scm_i_mkbig ();
1992 SCM r
= scm_i_mkbig ();
1993 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1994 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1995 scm_remember_upto_here_2 (x
, y
);
1996 *qp
= scm_i_normbig (q
);
1997 *rp
= scm_i_normbig (r
);
2000 else if (SCM_REALP (y
))
2001 return scm_i_inexact_ceiling_divide
2002 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2003 else if (SCM_FRACTIONP (y
))
2004 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2006 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2007 s_scm_ceiling_divide
, qp
, rp
);
2009 else if (SCM_REALP (x
))
2011 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2012 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2013 return scm_i_inexact_ceiling_divide
2014 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2016 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2017 s_scm_ceiling_divide
, qp
, rp
);
2019 else if (SCM_FRACTIONP (x
))
2022 return scm_i_inexact_ceiling_divide
2023 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2024 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2025 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2027 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2028 s_scm_ceiling_divide
, qp
, rp
);
2031 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2032 s_scm_ceiling_divide
, qp
, rp
);
2036 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2038 if (SCM_UNLIKELY (y
== 0))
2039 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2042 double q
= ceil (x
/ y
);
2043 double r
= x
- q
* y
;
2044 *qp
= scm_from_double (q
);
2045 *rp
= scm_from_double (r
);
2050 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2053 SCM xd
= scm_denominator (x
);
2054 SCM yd
= scm_denominator (y
);
2056 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2057 scm_product (scm_numerator (y
), xd
),
2059 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2062 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2063 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2065 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2067 "Return @math{@var{x} / @var{y}} rounded toward zero.\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 -10) @result{} 12\n"
2073 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2074 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2076 #define FUNC_NAME s_scm_truncate_quotient
2078 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2080 scm_t_inum xx
= SCM_I_INUM (x
);
2081 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2083 scm_t_inum yy
= SCM_I_INUM (y
);
2084 if (SCM_UNLIKELY (yy
== 0))
2085 scm_num_overflow (s_scm_truncate_quotient
);
2088 scm_t_inum qq
= xx
/ yy
;
2089 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2090 return SCM_I_MAKINUM (qq
);
2092 return scm_i_inum2big (qq
);
2095 else if (SCM_BIGP (y
))
2097 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2098 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2099 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2101 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2102 scm_remember_upto_here_1 (y
);
2103 return SCM_I_MAKINUM (-1);
2108 else if (SCM_REALP (y
))
2109 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2110 else if (SCM_FRACTIONP (y
))
2111 return scm_i_exact_rational_truncate_quotient (x
, y
);
2113 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2114 s_scm_truncate_quotient
);
2116 else if (SCM_BIGP (x
))
2118 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2120 scm_t_inum yy
= SCM_I_INUM (y
);
2121 if (SCM_UNLIKELY (yy
== 0))
2122 scm_num_overflow (s_scm_truncate_quotient
);
2123 else if (SCM_UNLIKELY (yy
== 1))
2127 SCM q
= scm_i_mkbig ();
2129 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2132 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2133 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2135 scm_remember_upto_here_1 (x
);
2136 return scm_i_normbig (q
);
2139 else if (SCM_BIGP (y
))
2141 SCM q
= scm_i_mkbig ();
2142 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2145 scm_remember_upto_here_2 (x
, y
);
2146 return scm_i_normbig (q
);
2148 else if (SCM_REALP (y
))
2149 return scm_i_inexact_truncate_quotient
2150 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2151 else if (SCM_FRACTIONP (y
))
2152 return scm_i_exact_rational_truncate_quotient (x
, y
);
2154 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2155 s_scm_truncate_quotient
);
2157 else if (SCM_REALP (x
))
2159 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2160 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2161 return scm_i_inexact_truncate_quotient
2162 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2164 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2165 s_scm_truncate_quotient
);
2167 else if (SCM_FRACTIONP (x
))
2170 return scm_i_inexact_truncate_quotient
2171 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2172 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2173 return scm_i_exact_rational_truncate_quotient (x
, y
);
2175 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2176 s_scm_truncate_quotient
);
2179 SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2180 s_scm_truncate_quotient
);
2185 scm_i_inexact_truncate_quotient (double x
, double y
)
2187 if (SCM_UNLIKELY (y
== 0))
2188 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2190 return scm_from_double (trunc (x
/ y
));
2194 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2196 return scm_truncate_quotient
2197 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2198 scm_product (scm_numerator (y
), scm_denominator (x
)));
2201 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2202 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2204 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2206 "Return the real number @var{r} such that\n"
2207 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2208 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\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 -10) @result{} -3\n"
2214 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2215 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2217 #define FUNC_NAME s_scm_truncate_remainder
2219 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2221 scm_t_inum xx
= SCM_I_INUM (x
);
2222 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2224 scm_t_inum yy
= SCM_I_INUM (y
);
2225 if (SCM_UNLIKELY (yy
== 0))
2226 scm_num_overflow (s_scm_truncate_remainder
);
2228 return SCM_I_MAKINUM (xx
% yy
);
2230 else if (SCM_BIGP (y
))
2232 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2233 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2234 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2236 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2237 scm_remember_upto_here_1 (y
);
2243 else if (SCM_REALP (y
))
2244 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2245 else if (SCM_FRACTIONP (y
))
2246 return scm_i_exact_rational_truncate_remainder (x
, y
);
2248 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2249 s_scm_truncate_remainder
);
2251 else if (SCM_BIGP (x
))
2253 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2255 scm_t_inum yy
= SCM_I_INUM (y
);
2256 if (SCM_UNLIKELY (yy
== 0))
2257 scm_num_overflow (s_scm_truncate_remainder
);
2260 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2261 (yy
> 0) ? yy
: -yy
)
2262 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2263 scm_remember_upto_here_1 (x
);
2264 return SCM_I_MAKINUM (rr
);
2267 else if (SCM_BIGP (y
))
2269 SCM r
= scm_i_mkbig ();
2270 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2273 scm_remember_upto_here_2 (x
, y
);
2274 return scm_i_normbig (r
);
2276 else if (SCM_REALP (y
))
2277 return scm_i_inexact_truncate_remainder
2278 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2279 else if (SCM_FRACTIONP (y
))
2280 return scm_i_exact_rational_truncate_remainder (x
, y
);
2282 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2283 s_scm_truncate_remainder
);
2285 else if (SCM_REALP (x
))
2287 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2288 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2289 return scm_i_inexact_truncate_remainder
2290 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2292 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2293 s_scm_truncate_remainder
);
2295 else if (SCM_FRACTIONP (x
))
2298 return scm_i_inexact_truncate_remainder
2299 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2300 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2301 return scm_i_exact_rational_truncate_remainder (x
, y
);
2303 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2304 s_scm_truncate_remainder
);
2307 SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2308 s_scm_truncate_remainder
);
2313 scm_i_inexact_truncate_remainder (double x
, double y
)
2315 /* Although it would be more efficient to use fmod here, we can't
2316 because it would in some cases produce results inconsistent with
2317 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2318 close). In particular, when x is very close to a multiple of y,
2319 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2320 correspond to different choices of q. If quotient chooses one and
2321 remainder chooses the other, it would be bad. */
2322 if (SCM_UNLIKELY (y
== 0))
2323 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2325 return scm_from_double (x
- y
* trunc (x
/ y
));
2329 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2331 SCM xd
= scm_denominator (x
);
2332 SCM yd
= scm_denominator (y
);
2333 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2334 scm_product (scm_numerator (y
), xd
));
2335 return scm_divide (r1
, scm_product (xd
, yd
));
2339 static void scm_i_inexact_truncate_divide (double x
, double y
,
2341 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2344 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2346 "Return the integer @var{q} and the real number @var{r}\n"
2347 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2348 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\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 -10) @result{} 12 and -3\n"
2354 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2355 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2357 #define FUNC_NAME s_scm_i_truncate_divide
2361 scm_truncate_divide(x
, y
, &q
, &r
);
2362 return scm_values (scm_list_2 (q
, r
));
2366 #define s_scm_truncate_divide s_scm_i_truncate_divide
2367 #define g_scm_truncate_divide g_scm_i_truncate_divide
2370 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2372 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2374 scm_t_inum xx
= SCM_I_INUM (x
);
2375 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2377 scm_t_inum yy
= SCM_I_INUM (y
);
2378 if (SCM_UNLIKELY (yy
== 0))
2379 scm_num_overflow (s_scm_truncate_divide
);
2382 scm_t_inum qq
= xx
/ yy
;
2383 scm_t_inum rr
= xx
% yy
;
2384 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2385 *qp
= SCM_I_MAKINUM (qq
);
2387 *qp
= scm_i_inum2big (qq
);
2388 *rp
= SCM_I_MAKINUM (rr
);
2392 else if (SCM_BIGP (y
))
2394 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2395 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2396 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2398 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2399 scm_remember_upto_here_1 (y
);
2400 *qp
= SCM_I_MAKINUM (-1);
2410 else if (SCM_REALP (y
))
2411 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2412 else if (SCM_FRACTIONP (y
))
2413 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2415 return two_valued_wta_dispatch_2
2416 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2417 s_scm_truncate_divide
, qp
, rp
);
2419 else if (SCM_BIGP (x
))
2421 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2423 scm_t_inum yy
= SCM_I_INUM (y
);
2424 if (SCM_UNLIKELY (yy
== 0))
2425 scm_num_overflow (s_scm_truncate_divide
);
2428 SCM q
= scm_i_mkbig ();
2431 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2432 SCM_I_BIG_MPZ (x
), yy
);
2435 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2436 SCM_I_BIG_MPZ (x
), -yy
);
2437 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2439 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2440 scm_remember_upto_here_1 (x
);
2441 *qp
= scm_i_normbig (q
);
2442 *rp
= SCM_I_MAKINUM (rr
);
2446 else if (SCM_BIGP (y
))
2448 SCM q
= scm_i_mkbig ();
2449 SCM r
= scm_i_mkbig ();
2450 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2451 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2452 scm_remember_upto_here_2 (x
, y
);
2453 *qp
= scm_i_normbig (q
);
2454 *rp
= scm_i_normbig (r
);
2456 else if (SCM_REALP (y
))
2457 return scm_i_inexact_truncate_divide
2458 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2459 else if (SCM_FRACTIONP (y
))
2460 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2462 return two_valued_wta_dispatch_2
2463 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2464 s_scm_truncate_divide
, qp
, rp
);
2466 else if (SCM_REALP (x
))
2468 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2469 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2470 return scm_i_inexact_truncate_divide
2471 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2473 return two_valued_wta_dispatch_2
2474 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2475 s_scm_truncate_divide
, qp
, rp
);
2477 else if (SCM_FRACTIONP (x
))
2480 return scm_i_inexact_truncate_divide
2481 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2482 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2483 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2485 return two_valued_wta_dispatch_2
2486 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2487 s_scm_truncate_divide
, qp
, rp
);
2490 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2491 s_scm_truncate_divide
, qp
, rp
);
2495 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2497 if (SCM_UNLIKELY (y
== 0))
2498 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2501 double q
= trunc (x
/ y
);
2502 double r
= x
- q
* y
;
2503 *qp
= scm_from_double (q
);
2504 *rp
= scm_from_double (r
);
2509 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2512 SCM xd
= scm_denominator (x
);
2513 SCM yd
= scm_denominator (y
);
2515 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2516 scm_product (scm_numerator (y
), xd
),
2518 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2521 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2522 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2523 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2525 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2527 "Return the integer @var{q} such that\n"
2528 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2529 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\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 -10) @result{} 12\n"
2535 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2536 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2538 #define FUNC_NAME s_scm_centered_quotient
2540 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2542 scm_t_inum xx
= SCM_I_INUM (x
);
2543 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2545 scm_t_inum yy
= SCM_I_INUM (y
);
2546 if (SCM_UNLIKELY (yy
== 0))
2547 scm_num_overflow (s_scm_centered_quotient
);
2550 scm_t_inum qq
= xx
/ yy
;
2551 scm_t_inum rr
= xx
% yy
;
2552 if (SCM_LIKELY (xx
> 0))
2554 if (SCM_LIKELY (yy
> 0))
2556 if (rr
>= (yy
+ 1) / 2)
2561 if (rr
>= (1 - yy
) / 2)
2567 if (SCM_LIKELY (yy
> 0))
2578 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2579 return SCM_I_MAKINUM (qq
);
2581 return scm_i_inum2big (qq
);
2584 else if (SCM_BIGP (y
))
2586 /* Pass a denormalized bignum version of x (even though it
2587 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2588 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2590 else if (SCM_REALP (y
))
2591 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2592 else if (SCM_FRACTIONP (y
))
2593 return scm_i_exact_rational_centered_quotient (x
, y
);
2595 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2596 s_scm_centered_quotient
);
2598 else if (SCM_BIGP (x
))
2600 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2602 scm_t_inum yy
= SCM_I_INUM (y
);
2603 if (SCM_UNLIKELY (yy
== 0))
2604 scm_num_overflow (s_scm_centered_quotient
);
2605 else if (SCM_UNLIKELY (yy
== 1))
2609 SCM q
= scm_i_mkbig ();
2611 /* Arrange for rr to initially be non-positive,
2612 because that simplifies the test to see
2613 if it is within the needed bounds. */
2616 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2617 SCM_I_BIG_MPZ (x
), yy
);
2618 scm_remember_upto_here_1 (x
);
2620 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2621 SCM_I_BIG_MPZ (q
), 1);
2625 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2626 SCM_I_BIG_MPZ (x
), -yy
);
2627 scm_remember_upto_here_1 (x
);
2628 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2630 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2631 SCM_I_BIG_MPZ (q
), 1);
2633 return scm_i_normbig (q
);
2636 else if (SCM_BIGP (y
))
2637 return scm_i_bigint_centered_quotient (x
, y
);
2638 else if (SCM_REALP (y
))
2639 return scm_i_inexact_centered_quotient
2640 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2641 else if (SCM_FRACTIONP (y
))
2642 return scm_i_exact_rational_centered_quotient (x
, y
);
2644 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2645 s_scm_centered_quotient
);
2647 else if (SCM_REALP (x
))
2649 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2650 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2651 return scm_i_inexact_centered_quotient
2652 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2654 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2655 s_scm_centered_quotient
);
2657 else if (SCM_FRACTIONP (x
))
2660 return scm_i_inexact_centered_quotient
2661 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2662 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2663 return scm_i_exact_rational_centered_quotient (x
, y
);
2665 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2666 s_scm_centered_quotient
);
2669 SCM_WTA_DISPATCH_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2670 s_scm_centered_quotient
);
2675 scm_i_inexact_centered_quotient (double x
, double y
)
2677 if (SCM_LIKELY (y
> 0))
2678 return scm_from_double (floor (x
/y
+ 0.5));
2679 else if (SCM_LIKELY (y
< 0))
2680 return scm_from_double (ceil (x
/y
- 0.5));
2682 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2687 /* Assumes that both x and y are bigints, though
2688 x might be able to fit into a fixnum. */
2690 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2694 /* Note that x might be small enough to fit into a
2695 fixnum, so we must not let it escape into the wild */
2699 /* min_r will eventually become -abs(y)/2 */
2700 min_r
= scm_i_mkbig ();
2701 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2702 SCM_I_BIG_MPZ (y
), 1);
2704 /* Arrange for rr to initially be non-positive,
2705 because that simplifies the test to see
2706 if it is within the needed bounds. */
2707 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2709 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2710 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2711 scm_remember_upto_here_2 (x
, y
);
2712 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2713 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2714 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2715 SCM_I_BIG_MPZ (q
), 1);
2719 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2720 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2721 scm_remember_upto_here_2 (x
, y
);
2722 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2723 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2724 SCM_I_BIG_MPZ (q
), 1);
2726 scm_remember_upto_here_2 (r
, min_r
);
2727 return scm_i_normbig (q
);
2731 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2733 return scm_centered_quotient
2734 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2735 scm_product (scm_numerator (y
), scm_denominator (x
)));
2738 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2739 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2740 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2742 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2744 "Return the real number @var{r} such that\n"
2745 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2746 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2747 "for some integer @var{q}.\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 -10) @result{} -3\n"
2753 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2754 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2756 #define FUNC_NAME s_scm_centered_remainder
2758 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2760 scm_t_inum xx
= SCM_I_INUM (x
);
2761 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2763 scm_t_inum yy
= SCM_I_INUM (y
);
2764 if (SCM_UNLIKELY (yy
== 0))
2765 scm_num_overflow (s_scm_centered_remainder
);
2768 scm_t_inum rr
= xx
% yy
;
2769 if (SCM_LIKELY (xx
> 0))
2771 if (SCM_LIKELY (yy
> 0))
2773 if (rr
>= (yy
+ 1) / 2)
2778 if (rr
>= (1 - yy
) / 2)
2784 if (SCM_LIKELY (yy
> 0))
2795 return SCM_I_MAKINUM (rr
);
2798 else if (SCM_BIGP (y
))
2800 /* Pass a denormalized bignum version of x (even though it
2801 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2802 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2804 else if (SCM_REALP (y
))
2805 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2806 else if (SCM_FRACTIONP (y
))
2807 return scm_i_exact_rational_centered_remainder (x
, y
);
2809 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2810 s_scm_centered_remainder
);
2812 else if (SCM_BIGP (x
))
2814 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2816 scm_t_inum yy
= SCM_I_INUM (y
);
2817 if (SCM_UNLIKELY (yy
== 0))
2818 scm_num_overflow (s_scm_centered_remainder
);
2822 /* Arrange for rr to initially be non-positive,
2823 because that simplifies the test to see
2824 if it is within the needed bounds. */
2827 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2828 scm_remember_upto_here_1 (x
);
2834 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2835 scm_remember_upto_here_1 (x
);
2839 return SCM_I_MAKINUM (rr
);
2842 else if (SCM_BIGP (y
))
2843 return scm_i_bigint_centered_remainder (x
, y
);
2844 else if (SCM_REALP (y
))
2845 return scm_i_inexact_centered_remainder
2846 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2847 else if (SCM_FRACTIONP (y
))
2848 return scm_i_exact_rational_centered_remainder (x
, y
);
2850 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2851 s_scm_centered_remainder
);
2853 else if (SCM_REALP (x
))
2855 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2856 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2857 return scm_i_inexact_centered_remainder
2858 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2860 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2861 s_scm_centered_remainder
);
2863 else if (SCM_FRACTIONP (x
))
2866 return scm_i_inexact_centered_remainder
2867 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2868 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2869 return scm_i_exact_rational_centered_remainder (x
, y
);
2871 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2872 s_scm_centered_remainder
);
2875 SCM_WTA_DISPATCH_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2876 s_scm_centered_remainder
);
2881 scm_i_inexact_centered_remainder (double x
, double y
)
2885 /* Although it would be more efficient to use fmod here, we can't
2886 because it would in some cases produce results inconsistent with
2887 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2888 close). In particular, when x-y/2 is very close to a multiple of
2889 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2890 two cases must correspond to different choices of q. If quotient
2891 chooses one and remainder chooses the other, it would be bad. */
2892 if (SCM_LIKELY (y
> 0))
2893 q
= floor (x
/y
+ 0.5);
2894 else if (SCM_LIKELY (y
< 0))
2895 q
= ceil (x
/y
- 0.5);
2897 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2900 return scm_from_double (x
- q
* y
);
2903 /* Assumes that both x and y are bigints, though
2904 x might be able to fit into a fixnum. */
2906 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2910 /* Note that x might be small enough to fit into a
2911 fixnum, so we must not let it escape into the wild */
2914 /* min_r will eventually become -abs(y)/2 */
2915 min_r
= scm_i_mkbig ();
2916 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2917 SCM_I_BIG_MPZ (y
), 1);
2919 /* Arrange for rr to initially be non-positive,
2920 because that simplifies the test to see
2921 if it is within the needed bounds. */
2922 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2924 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2925 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2926 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2927 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2928 mpz_add (SCM_I_BIG_MPZ (r
),
2934 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2935 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2936 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2937 mpz_sub (SCM_I_BIG_MPZ (r
),
2941 scm_remember_upto_here_2 (x
, y
);
2942 return scm_i_normbig (r
);
2946 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2948 SCM xd
= scm_denominator (x
);
2949 SCM yd
= scm_denominator (y
);
2950 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2951 scm_product (scm_numerator (y
), xd
));
2952 return scm_divide (r1
, scm_product (xd
, yd
));
2956 static void scm_i_inexact_centered_divide (double x
, double y
,
2958 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2959 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2962 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2964 "Return the integer @var{q} and the real number @var{r}\n"
2965 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2966 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\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 -10) @result{} 12 and -3\n"
2972 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2973 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2975 #define FUNC_NAME s_scm_i_centered_divide
2979 scm_centered_divide(x
, y
, &q
, &r
);
2980 return scm_values (scm_list_2 (q
, r
));
2984 #define s_scm_centered_divide s_scm_i_centered_divide
2985 #define g_scm_centered_divide g_scm_i_centered_divide
2988 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2990 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2992 scm_t_inum xx
= SCM_I_INUM (x
);
2993 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2995 scm_t_inum yy
= SCM_I_INUM (y
);
2996 if (SCM_UNLIKELY (yy
== 0))
2997 scm_num_overflow (s_scm_centered_divide
);
3000 scm_t_inum qq
= xx
/ yy
;
3001 scm_t_inum rr
= xx
% yy
;
3002 if (SCM_LIKELY (xx
> 0))
3004 if (SCM_LIKELY (yy
> 0))
3006 if (rr
>= (yy
+ 1) / 2)
3011 if (rr
>= (1 - yy
) / 2)
3017 if (SCM_LIKELY (yy
> 0))
3028 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3029 *qp
= SCM_I_MAKINUM (qq
);
3031 *qp
= scm_i_inum2big (qq
);
3032 *rp
= SCM_I_MAKINUM (rr
);
3036 else if (SCM_BIGP (y
))
3038 /* Pass a denormalized bignum version of x (even though it
3039 can fit in a fixnum) to scm_i_bigint_centered_divide */
3040 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3042 else if (SCM_REALP (y
))
3043 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3044 else if (SCM_FRACTIONP (y
))
3045 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3047 return two_valued_wta_dispatch_2
3048 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3049 s_scm_centered_divide
, qp
, rp
);
3051 else if (SCM_BIGP (x
))
3053 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3055 scm_t_inum yy
= SCM_I_INUM (y
);
3056 if (SCM_UNLIKELY (yy
== 0))
3057 scm_num_overflow (s_scm_centered_divide
);
3060 SCM q
= scm_i_mkbig ();
3062 /* Arrange for rr to initially be non-positive,
3063 because that simplifies the test to see
3064 if it is within the needed bounds. */
3067 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3068 SCM_I_BIG_MPZ (x
), yy
);
3069 scm_remember_upto_here_1 (x
);
3072 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3073 SCM_I_BIG_MPZ (q
), 1);
3079 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3080 SCM_I_BIG_MPZ (x
), -yy
);
3081 scm_remember_upto_here_1 (x
);
3082 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3085 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3086 SCM_I_BIG_MPZ (q
), 1);
3090 *qp
= scm_i_normbig (q
);
3091 *rp
= SCM_I_MAKINUM (rr
);
3095 else if (SCM_BIGP (y
))
3096 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3097 else if (SCM_REALP (y
))
3098 return scm_i_inexact_centered_divide
3099 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3100 else if (SCM_FRACTIONP (y
))
3101 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3103 return two_valued_wta_dispatch_2
3104 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3105 s_scm_centered_divide
, qp
, rp
);
3107 else if (SCM_REALP (x
))
3109 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3110 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3111 return scm_i_inexact_centered_divide
3112 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3114 return two_valued_wta_dispatch_2
3115 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3116 s_scm_centered_divide
, qp
, rp
);
3118 else if (SCM_FRACTIONP (x
))
3121 return scm_i_inexact_centered_divide
3122 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3123 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3124 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3126 return two_valued_wta_dispatch_2
3127 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3128 s_scm_centered_divide
, qp
, rp
);
3131 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3132 s_scm_centered_divide
, qp
, rp
);
3136 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3140 if (SCM_LIKELY (y
> 0))
3141 q
= floor (x
/y
+ 0.5);
3142 else if (SCM_LIKELY (y
< 0))
3143 q
= ceil (x
/y
- 0.5);
3145 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3149 *qp
= scm_from_double (q
);
3150 *rp
= scm_from_double (r
);
3153 /* Assumes that both x and y are bigints, though
3154 x might be able to fit into a fixnum. */
3156 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3160 /* Note that x might be small enough to fit into a
3161 fixnum, so we must not let it escape into the wild */
3165 /* min_r will eventually become -abs(y/2) */
3166 min_r
= scm_i_mkbig ();
3167 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3168 SCM_I_BIG_MPZ (y
), 1);
3170 /* Arrange for rr to initially be non-positive,
3171 because that simplifies the test to see
3172 if it is within the needed bounds. */
3173 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3175 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3176 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3177 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3178 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3180 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3181 SCM_I_BIG_MPZ (q
), 1);
3182 mpz_add (SCM_I_BIG_MPZ (r
),
3189 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3190 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3191 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3193 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3194 SCM_I_BIG_MPZ (q
), 1);
3195 mpz_sub (SCM_I_BIG_MPZ (r
),
3200 scm_remember_upto_here_2 (x
, y
);
3201 *qp
= scm_i_normbig (q
);
3202 *rp
= scm_i_normbig (r
);
3206 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3209 SCM xd
= scm_denominator (x
);
3210 SCM yd
= scm_denominator (y
);
3212 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3213 scm_product (scm_numerator (y
), xd
),
3215 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3218 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3219 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3220 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3222 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3224 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3225 "with ties going to the nearest even integer.\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 -123 -10) @result{} 12\n"
3231 "(round-quotient 125 10) @result{} 12\n"
3232 "(round-quotient 127 10) @result{} 13\n"
3233 "(round-quotient 135 10) @result{} 14\n"
3234 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3235 "(round-quotient 16/3 -10/7) @result{} -4\n"
3237 #define FUNC_NAME s_scm_round_quotient
3239 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3241 scm_t_inum xx
= SCM_I_INUM (x
);
3242 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3244 scm_t_inum yy
= SCM_I_INUM (y
);
3245 if (SCM_UNLIKELY (yy
== 0))
3246 scm_num_overflow (s_scm_round_quotient
);
3249 scm_t_inum qq
= xx
/ yy
;
3250 scm_t_inum rr
= xx
% yy
;
3252 scm_t_inum r2
= 2 * rr
;
3254 if (SCM_LIKELY (yy
< 0))
3274 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3275 return SCM_I_MAKINUM (qq
);
3277 return scm_i_inum2big (qq
);
3280 else if (SCM_BIGP (y
))
3282 /* Pass a denormalized bignum version of x (even though it
3283 can fit in a fixnum) to scm_i_bigint_round_quotient */
3284 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3286 else if (SCM_REALP (y
))
3287 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3288 else if (SCM_FRACTIONP (y
))
3289 return scm_i_exact_rational_round_quotient (x
, y
);
3291 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3292 s_scm_round_quotient
);
3294 else if (SCM_BIGP (x
))
3296 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3298 scm_t_inum yy
= SCM_I_INUM (y
);
3299 if (SCM_UNLIKELY (yy
== 0))
3300 scm_num_overflow (s_scm_round_quotient
);
3301 else if (SCM_UNLIKELY (yy
== 1))
3305 SCM q
= scm_i_mkbig ();
3307 int needs_adjustment
;
3311 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3312 SCM_I_BIG_MPZ (x
), yy
);
3313 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3314 needs_adjustment
= (2*rr
>= yy
);
3316 needs_adjustment
= (2*rr
> yy
);
3320 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3321 SCM_I_BIG_MPZ (x
), -yy
);
3322 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3323 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3324 needs_adjustment
= (2*rr
<= yy
);
3326 needs_adjustment
= (2*rr
< yy
);
3328 scm_remember_upto_here_1 (x
);
3329 if (needs_adjustment
)
3330 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3331 return scm_i_normbig (q
);
3334 else if (SCM_BIGP (y
))
3335 return scm_i_bigint_round_quotient (x
, y
);
3336 else if (SCM_REALP (y
))
3337 return scm_i_inexact_round_quotient
3338 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3339 else if (SCM_FRACTIONP (y
))
3340 return scm_i_exact_rational_round_quotient (x
, y
);
3342 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3343 s_scm_round_quotient
);
3345 else if (SCM_REALP (x
))
3347 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3348 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3349 return scm_i_inexact_round_quotient
3350 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3352 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3353 s_scm_round_quotient
);
3355 else if (SCM_FRACTIONP (x
))
3358 return scm_i_inexact_round_quotient
3359 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3360 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3361 return scm_i_exact_rational_round_quotient (x
, y
);
3363 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3364 s_scm_round_quotient
);
3367 SCM_WTA_DISPATCH_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3368 s_scm_round_quotient
);
3373 scm_i_inexact_round_quotient (double x
, double y
)
3375 if (SCM_UNLIKELY (y
== 0))
3376 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3378 return scm_from_double (scm_c_round (x
/ y
));
3381 /* Assumes that both x and y are bigints, though
3382 x might be able to fit into a fixnum. */
3384 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3387 int cmp
, needs_adjustment
;
3389 /* Note that x might be small enough to fit into a
3390 fixnum, so we must not let it escape into the wild */
3393 r2
= scm_i_mkbig ();
3395 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3396 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3397 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3398 scm_remember_upto_here_2 (x
, r
);
3400 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3401 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3402 needs_adjustment
= (cmp
>= 0);
3404 needs_adjustment
= (cmp
> 0);
3405 scm_remember_upto_here_2 (r2
, y
);
3407 if (needs_adjustment
)
3408 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3410 return scm_i_normbig (q
);
3414 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3416 return scm_round_quotient
3417 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3418 scm_product (scm_numerator (y
), scm_denominator (x
)));
3421 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3422 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3423 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3425 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3427 "Return the real number @var{r} such that\n"
3428 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3429 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3430 "nearest integer, with ties going to the nearest\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 -123 -10) @result{} -3\n"
3437 "(round-remainder 125 10) @result{} 5\n"
3438 "(round-remainder 127 10) @result{} -3\n"
3439 "(round-remainder 135 10) @result{} -5\n"
3440 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3441 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3443 #define FUNC_NAME s_scm_round_remainder
3445 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3447 scm_t_inum xx
= SCM_I_INUM (x
);
3448 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3450 scm_t_inum yy
= SCM_I_INUM (y
);
3451 if (SCM_UNLIKELY (yy
== 0))
3452 scm_num_overflow (s_scm_round_remainder
);
3455 scm_t_inum qq
= xx
/ yy
;
3456 scm_t_inum rr
= xx
% yy
;
3458 scm_t_inum r2
= 2 * rr
;
3460 if (SCM_LIKELY (yy
< 0))
3480 return SCM_I_MAKINUM (rr
);
3483 else if (SCM_BIGP (y
))
3485 /* Pass a denormalized bignum version of x (even though it
3486 can fit in a fixnum) to scm_i_bigint_round_remainder */
3487 return scm_i_bigint_round_remainder
3488 (scm_i_long2big (xx
), y
);
3490 else if (SCM_REALP (y
))
3491 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3492 else if (SCM_FRACTIONP (y
))
3493 return scm_i_exact_rational_round_remainder (x
, y
);
3495 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3496 s_scm_round_remainder
);
3498 else if (SCM_BIGP (x
))
3500 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3502 scm_t_inum yy
= SCM_I_INUM (y
);
3503 if (SCM_UNLIKELY (yy
== 0))
3504 scm_num_overflow (s_scm_round_remainder
);
3507 SCM q
= scm_i_mkbig ();
3509 int needs_adjustment
;
3513 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3514 SCM_I_BIG_MPZ (x
), yy
);
3515 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3516 needs_adjustment
= (2*rr
>= yy
);
3518 needs_adjustment
= (2*rr
> yy
);
3522 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3523 SCM_I_BIG_MPZ (x
), -yy
);
3524 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3525 needs_adjustment
= (2*rr
<= yy
);
3527 needs_adjustment
= (2*rr
< yy
);
3529 scm_remember_upto_here_2 (x
, q
);
3530 if (needs_adjustment
)
3532 return SCM_I_MAKINUM (rr
);
3535 else if (SCM_BIGP (y
))
3536 return scm_i_bigint_round_remainder (x
, y
);
3537 else if (SCM_REALP (y
))
3538 return scm_i_inexact_round_remainder
3539 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3540 else if (SCM_FRACTIONP (y
))
3541 return scm_i_exact_rational_round_remainder (x
, y
);
3543 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3544 s_scm_round_remainder
);
3546 else if (SCM_REALP (x
))
3548 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3549 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3550 return scm_i_inexact_round_remainder
3551 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3553 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3554 s_scm_round_remainder
);
3556 else if (SCM_FRACTIONP (x
))
3559 return scm_i_inexact_round_remainder
3560 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3561 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3562 return scm_i_exact_rational_round_remainder (x
, y
);
3564 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3565 s_scm_round_remainder
);
3568 SCM_WTA_DISPATCH_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3569 s_scm_round_remainder
);
3574 scm_i_inexact_round_remainder (double x
, double y
)
3576 /* Although it would be more efficient to use fmod here, we can't
3577 because it would in some cases produce results inconsistent with
3578 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3579 close). In particular, when x-y/2 is very close to a multiple of
3580 y, then r might be either -abs(y/2) or abs(y/2), but those two
3581 cases must correspond to different choices of q. If quotient
3582 chooses one and remainder chooses the other, it would be bad. */
3584 if (SCM_UNLIKELY (y
== 0))
3585 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3588 double q
= scm_c_round (x
/ y
);
3589 return scm_from_double (x
- q
* y
);
3593 /* Assumes that both x and y are bigints, though
3594 x might be able to fit into a fixnum. */
3596 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3599 int cmp
, needs_adjustment
;
3601 /* Note that x might be small enough to fit into a
3602 fixnum, so we must not let it escape into the wild */
3605 r2
= scm_i_mkbig ();
3607 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3608 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3609 scm_remember_upto_here_1 (x
);
3610 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3612 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3613 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3614 needs_adjustment
= (cmp
>= 0);
3616 needs_adjustment
= (cmp
> 0);
3617 scm_remember_upto_here_2 (q
, r2
);
3619 if (needs_adjustment
)
3620 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3622 scm_remember_upto_here_1 (y
);
3623 return scm_i_normbig (r
);
3627 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3629 SCM xd
= scm_denominator (x
);
3630 SCM yd
= scm_denominator (y
);
3631 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3632 scm_product (scm_numerator (y
), xd
));
3633 return scm_divide (r1
, scm_product (xd
, yd
));
3637 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3638 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3639 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3641 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3643 "Return the integer @var{q} and the real number @var{r}\n"
3644 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3645 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3646 "nearest integer, with ties going to the nearest even integer.\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/ -123 -10) @result{} 12 and -3\n"
3652 "(round/ 125 10) @result{} 12 and 5\n"
3653 "(round/ 127 10) @result{} 13 and -3\n"
3654 "(round/ 135 10) @result{} 14 and -5\n"
3655 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3656 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3658 #define FUNC_NAME s_scm_i_round_divide
3662 scm_round_divide(x
, y
, &q
, &r
);
3663 return scm_values (scm_list_2 (q
, r
));
3667 #define s_scm_round_divide s_scm_i_round_divide
3668 #define g_scm_round_divide g_scm_i_round_divide
3671 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3673 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3675 scm_t_inum xx
= SCM_I_INUM (x
);
3676 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3678 scm_t_inum yy
= SCM_I_INUM (y
);
3679 if (SCM_UNLIKELY (yy
== 0))
3680 scm_num_overflow (s_scm_round_divide
);
3683 scm_t_inum qq
= xx
/ yy
;
3684 scm_t_inum rr
= xx
% yy
;
3686 scm_t_inum r2
= 2 * rr
;
3688 if (SCM_LIKELY (yy
< 0))
3708 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3709 *qp
= SCM_I_MAKINUM (qq
);
3711 *qp
= scm_i_inum2big (qq
);
3712 *rp
= SCM_I_MAKINUM (rr
);
3716 else if (SCM_BIGP (y
))
3718 /* Pass a denormalized bignum version of x (even though it
3719 can fit in a fixnum) to scm_i_bigint_round_divide */
3720 return scm_i_bigint_round_divide
3721 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3723 else if (SCM_REALP (y
))
3724 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3725 else if (SCM_FRACTIONP (y
))
3726 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3728 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3729 s_scm_round_divide
, qp
, rp
);
3731 else if (SCM_BIGP (x
))
3733 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3735 scm_t_inum yy
= SCM_I_INUM (y
);
3736 if (SCM_UNLIKELY (yy
== 0))
3737 scm_num_overflow (s_scm_round_divide
);
3740 SCM q
= scm_i_mkbig ();
3742 int needs_adjustment
;
3746 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3747 SCM_I_BIG_MPZ (x
), yy
);
3748 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3749 needs_adjustment
= (2*rr
>= yy
);
3751 needs_adjustment
= (2*rr
> yy
);
3755 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3756 SCM_I_BIG_MPZ (x
), -yy
);
3757 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3758 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3759 needs_adjustment
= (2*rr
<= yy
);
3761 needs_adjustment
= (2*rr
< yy
);
3763 scm_remember_upto_here_1 (x
);
3764 if (needs_adjustment
)
3766 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3769 *qp
= scm_i_normbig (q
);
3770 *rp
= SCM_I_MAKINUM (rr
);
3774 else if (SCM_BIGP (y
))
3775 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3776 else if (SCM_REALP (y
))
3777 return scm_i_inexact_round_divide
3778 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3779 else if (SCM_FRACTIONP (y
))
3780 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3782 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3783 s_scm_round_divide
, qp
, rp
);
3785 else if (SCM_REALP (x
))
3787 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3788 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3789 return scm_i_inexact_round_divide
3790 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3792 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3793 s_scm_round_divide
, qp
, rp
);
3795 else if (SCM_FRACTIONP (x
))
3798 return scm_i_inexact_round_divide
3799 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3800 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3801 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3803 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3804 s_scm_round_divide
, qp
, rp
);
3807 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3808 s_scm_round_divide
, qp
, rp
);
3812 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3814 if (SCM_UNLIKELY (y
== 0))
3815 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3818 double q
= scm_c_round (x
/ y
);
3819 double r
= x
- q
* y
;
3820 *qp
= scm_from_double (q
);
3821 *rp
= scm_from_double (r
);
3825 /* Assumes that both x and y are bigints, though
3826 x might be able to fit into a fixnum. */
3828 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3831 int cmp
, needs_adjustment
;
3833 /* Note that x might be small enough to fit into a
3834 fixnum, so we must not let it escape into the wild */
3837 r2
= scm_i_mkbig ();
3839 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3840 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3841 scm_remember_upto_here_1 (x
);
3842 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3844 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3845 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3846 needs_adjustment
= (cmp
>= 0);
3848 needs_adjustment
= (cmp
> 0);
3850 if (needs_adjustment
)
3852 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3853 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3856 scm_remember_upto_here_2 (r2
, y
);
3857 *qp
= scm_i_normbig (q
);
3858 *rp
= scm_i_normbig (r
);
3862 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3865 SCM xd
= scm_denominator (x
);
3866 SCM yd
= scm_denominator (y
);
3868 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3869 scm_product (scm_numerator (y
), xd
),
3871 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3875 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3876 (SCM x
, SCM y
, SCM rest
),
3877 "Return the greatest common divisor of all parameter values.\n"
3878 "If called without arguments, 0 is returned.")
3879 #define FUNC_NAME s_scm_i_gcd
3881 while (!scm_is_null (rest
))
3882 { x
= scm_gcd (x
, y
);
3884 rest
= scm_cdr (rest
);
3886 return scm_gcd (x
, y
);
3890 #define s_gcd s_scm_i_gcd
3891 #define g_gcd g_scm_i_gcd
3894 scm_gcd (SCM x
, SCM y
)
3897 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3899 if (SCM_I_INUMP (x
))
3901 if (SCM_I_INUMP (y
))
3903 scm_t_inum xx
= SCM_I_INUM (x
);
3904 scm_t_inum yy
= SCM_I_INUM (y
);
3905 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3906 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3916 /* Determine a common factor 2^k */
3917 while (!(1 & (u
| v
)))
3923 /* Now, any factor 2^n can be eliminated */
3943 return (SCM_POSFIXABLE (result
)
3944 ? SCM_I_MAKINUM (result
)
3945 : scm_i_inum2big (result
));
3947 else if (SCM_BIGP (y
))
3953 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3955 else if (SCM_BIGP (x
))
3957 if (SCM_I_INUMP (y
))
3962 yy
= SCM_I_INUM (y
);
3967 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3968 scm_remember_upto_here_1 (x
);
3969 return (SCM_POSFIXABLE (result
)
3970 ? SCM_I_MAKINUM (result
)
3971 : scm_from_unsigned_integer (result
));
3973 else if (SCM_BIGP (y
))
3975 SCM result
= scm_i_mkbig ();
3976 mpz_gcd (SCM_I_BIG_MPZ (result
),
3979 scm_remember_upto_here_2 (x
, y
);
3980 return scm_i_normbig (result
);
3983 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3986 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3989 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3990 (SCM x
, SCM y
, SCM rest
),
3991 "Return the least common multiple of the arguments.\n"
3992 "If called without arguments, 1 is returned.")
3993 #define FUNC_NAME s_scm_i_lcm
3995 while (!scm_is_null (rest
))
3996 { x
= scm_lcm (x
, y
);
3998 rest
= scm_cdr (rest
);
4000 return scm_lcm (x
, y
);
4004 #define s_lcm s_scm_i_lcm
4005 #define g_lcm g_scm_i_lcm
4008 scm_lcm (SCM n1
, SCM n2
)
4010 if (SCM_UNBNDP (n2
))
4012 if (SCM_UNBNDP (n1
))
4013 return SCM_I_MAKINUM (1L);
4014 n2
= SCM_I_MAKINUM (1L);
4017 SCM_GASSERT2 (SCM_I_INUMP (n1
) || SCM_BIGP (n1
),
4018 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4019 SCM_GASSERT2 (SCM_I_INUMP (n2
) || SCM_BIGP (n2
),
4020 g_lcm
, n1
, n2
, SCM_ARGn
, 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
)
5151 /* adding 9999 makes this equivalent to abs(x) % 3 */
5152 dpt
= (exp
+ 9999) % 3;
5156 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5178 a
[ch
++] = number_chars
[d
];
5181 if (f
+ fx
[wp
] >= 1.0)
5183 a
[ch
- 1] = number_chars
[d
+1];
5195 if ((dpt
> 4) && (exp
> 6))
5197 d
= (a
[0] == '-' ? 2 : 1);
5198 for (i
= ch
++; i
> d
; i
--)
5211 if (a
[ch
- 1] == '.')
5212 a
[ch
++] = '0'; /* trailing zero */
5221 for (i
= radix
; i
<= exp
; i
*= radix
);
5222 for (i
/= radix
; i
; i
/= radix
)
5224 a
[ch
++] = number_chars
[exp
/ i
];
5233 icmplx2str (double real
, double imag
, char *str
, int radix
)
5238 i
= idbl2str (real
, str
, radix
);
5239 #ifdef HAVE_COPYSIGN
5240 sgn
= copysign (1.0, imag
);
5244 /* Don't output a '+' for negative numbers or for Inf and
5245 NaN. They will provide their own sign. */
5246 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5248 i
+= idbl2str (imag
, &str
[i
], radix
);
5254 iflo2str (SCM flt
, char *str
, int radix
)
5257 if (SCM_REALP (flt
))
5258 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5260 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5265 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5266 characters in the result.
5268 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5270 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5275 return scm_iuint2str (-num
, rad
, p
) + 1;
5278 return scm_iuint2str (num
, rad
, p
);
5281 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5282 characters in the result.
5284 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5286 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5290 scm_t_uintmax n
= num
;
5292 if (rad
< 2 || rad
> 36)
5293 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5295 for (n
/= rad
; n
> 0; n
/= rad
)
5305 p
[i
] = number_chars
[d
];
5310 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5312 "Return a string holding the external representation of the\n"
5313 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5314 "inexact, a radix of 10 will be used.")
5315 #define FUNC_NAME s_scm_number_to_string
5319 if (SCM_UNBNDP (radix
))
5322 base
= scm_to_signed_integer (radix
, 2, 36);
5324 if (SCM_I_INUMP (n
))
5326 char num_buf
[SCM_INTBUFLEN
];
5327 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5328 return scm_from_locale_stringn (num_buf
, length
);
5330 else if (SCM_BIGP (n
))
5332 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5333 scm_remember_upto_here_1 (n
);
5334 return scm_take_locale_string (str
);
5336 else if (SCM_FRACTIONP (n
))
5338 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5339 scm_from_locale_string ("/"),
5340 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5342 else if (SCM_INEXACTP (n
))
5344 char num_buf
[FLOBUFLEN
];
5345 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5348 SCM_WRONG_TYPE_ARG (1, n
);
5353 /* These print routines used to be stubbed here so that scm_repl.c
5354 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5357 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5359 char num_buf
[FLOBUFLEN
];
5360 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5365 scm_i_print_double (double val
, SCM port
)
5367 char num_buf
[FLOBUFLEN
];
5368 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5372 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5375 char num_buf
[FLOBUFLEN
];
5376 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5381 scm_i_print_complex (double real
, double imag
, SCM port
)
5383 char num_buf
[FLOBUFLEN
];
5384 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5388 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5391 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5392 scm_display (str
, port
);
5393 scm_remember_upto_here_1 (str
);
5398 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5400 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5401 size_t len
= strlen (str
);
5402 void (*freefunc
) (void *, size_t);
5403 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5404 scm_remember_upto_here_1 (exp
);
5405 scm_lfwrite (str
, len
, port
);
5406 freefunc (str
, len
+ 1);
5409 /*** END nums->strs ***/
5412 /*** STRINGS -> NUMBERS ***/
5414 /* The following functions implement the conversion from strings to numbers.
5415 * The implementation somehow follows the grammar for numbers as it is given
5416 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5417 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5418 * points should be noted about the implementation:
5420 * * Each function keeps a local index variable 'idx' that points at the
5421 * current position within the parsed string. The global index is only
5422 * updated if the function could parse the corresponding syntactic unit
5425 * * Similarly, the functions keep track of indicators of inexactness ('#',
5426 * '.' or exponents) using local variables ('hash_seen', 'x').
5428 * * Sequences of digits are parsed into temporary variables holding fixnums.
5429 * Only if these fixnums would overflow, the result variables are updated
5430 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5431 * the temporary variables holding the fixnums are cleared, and the process
5432 * starts over again. If for example fixnums were able to store five decimal
5433 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5434 * and the result was computed as 12345 * 100000 + 67890. In other words,
5435 * only every five digits two bignum operations were performed.
5437 * Notes on the handling of exactness specifiers:
5439 * When parsing non-real complex numbers, we apply exactness specifiers on
5440 * per-component basis, as is done in PLT Scheme. For complex numbers
5441 * written in rectangular form, exactness specifiers are applied to the
5442 * real and imaginary parts before calling scm_make_rectangular. For
5443 * complex numbers written in polar form, exactness specifiers are applied
5444 * to the magnitude and angle before calling scm_make_polar.
5446 * There are two kinds of exactness specifiers: forced and implicit. A
5447 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5448 * the entire number, and applies to both components of a complex number.
5449 * "#e" causes each component to be made exact, and "#i" causes each
5450 * component to be made inexact. If no forced exactness specifier is
5451 * present, then the exactness of each component is determined
5452 * independently by the presence or absence of a decimal point or hash mark
5453 * within that component. If a decimal point or hash mark is present, the
5454 * component is made inexact, otherwise it is made exact.
5456 * After the exactness specifiers have been applied to each component, they
5457 * are passed to either scm_make_rectangular or scm_make_polar to produce
5458 * the final result. Note that this will result in a real number if the
5459 * imaginary part, magnitude, or angle is an exact 0.
5461 * For example, (string->number "#i5.0+0i") does the equivalent of:
5463 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5466 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5468 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5470 /* Caller is responsible for checking that the return value is in range
5471 for the given radix, which should be <= 36. */
5473 char_decimal_value (scm_t_uint32 c
)
5475 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5476 that's certainly above any valid decimal, so we take advantage of
5477 that to elide some tests. */
5478 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5480 /* If that failed, try extended hexadecimals, then. Only accept ascii
5485 if (c
>= (scm_t_uint32
) 'a')
5486 d
= c
- (scm_t_uint32
)'a' + 10U;
5491 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5492 in base RADIX. Upon success, return the unsigned integer and update
5493 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5495 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5496 unsigned int radix
, enum t_exactness
*p_exactness
)
5498 unsigned int idx
= *p_idx
;
5499 unsigned int hash_seen
= 0;
5500 scm_t_bits shift
= 1;
5502 unsigned int digit_value
;
5505 size_t len
= scm_i_string_length (mem
);
5510 c
= scm_i_string_ref (mem
, idx
);
5511 digit_value
= char_decimal_value (c
);
5512 if (digit_value
>= radix
)
5516 result
= SCM_I_MAKINUM (digit_value
);
5519 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5529 digit_value
= char_decimal_value (c
);
5530 /* This check catches non-decimals in addition to out-of-range
5532 if (digit_value
>= radix
)
5537 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5539 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5541 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5548 shift
= shift
* radix
;
5549 add
= add
* radix
+ digit_value
;
5554 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5556 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5560 *p_exactness
= INEXACT
;
5566 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5567 * covers the parts of the rules that start at a potential point. The value
5568 * of the digits up to the point have been parsed by the caller and are given
5569 * in variable result. The content of *p_exactness indicates, whether a hash
5570 * has already been seen in the digits before the point.
5573 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5576 mem2decimal_from_point (SCM result
, SCM mem
,
5577 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5579 unsigned int idx
= *p_idx
;
5580 enum t_exactness x
= *p_exactness
;
5581 size_t len
= scm_i_string_length (mem
);
5586 if (scm_i_string_ref (mem
, idx
) == '.')
5588 scm_t_bits shift
= 1;
5590 unsigned int digit_value
;
5591 SCM big_shift
= SCM_INUM1
;
5596 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5597 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5602 digit_value
= DIGIT2UINT (c
);
5613 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5615 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5616 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5618 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5626 add
= add
* 10 + digit_value
;
5632 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5633 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5634 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5637 result
= scm_divide (result
, big_shift
);
5639 /* We've seen a decimal point, thus the value is implicitly inexact. */
5651 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5653 switch (scm_i_string_ref (mem
, idx
))
5665 c
= scm_i_string_ref (mem
, idx
);
5673 c
= scm_i_string_ref (mem
, idx
);
5682 c
= scm_i_string_ref (mem
, idx
);
5687 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5691 exponent
= DIGIT2UINT (c
);
5694 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5695 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5698 if (exponent
<= SCM_MAXEXP
)
5699 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5705 if (exponent
> SCM_MAXEXP
)
5707 size_t exp_len
= idx
- start
;
5708 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5709 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5710 scm_out_of_range ("string->number", exp_num
);
5713 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5715 result
= scm_product (result
, e
);
5717 result
= scm_divide (result
, e
);
5719 /* We've seen an exponent, thus the value is implicitly inexact. */
5737 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5740 mem2ureal (SCM mem
, unsigned int *p_idx
,
5741 unsigned int radix
, enum t_exactness forced_x
)
5743 unsigned int idx
= *p_idx
;
5745 size_t len
= scm_i_string_length (mem
);
5747 /* Start off believing that the number will be exact. This changes
5748 to INEXACT if we see a decimal point or a hash. */
5749 enum t_exactness implicit_x
= EXACT
;
5754 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5760 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5762 /* Cobble up the fractional part. We might want to set the
5763 NaN's mantissa from it. */
5765 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
), SCM_INUM0
))
5767 #if SCM_ENABLE_DEPRECATED == 1
5768 scm_c_issue_deprecation_warning
5769 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5779 if (scm_i_string_ref (mem
, idx
) == '.')
5783 else if (idx
+ 1 == len
)
5785 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5788 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5789 p_idx
, &implicit_x
);
5795 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5796 if (scm_is_false (uinteger
))
5801 else if (scm_i_string_ref (mem
, idx
) == '/')
5809 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5810 if (scm_is_false (divisor
))
5813 /* both are int/big here, I assume */
5814 result
= scm_i_make_ratio (uinteger
, divisor
);
5816 else if (radix
== 10)
5818 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5819 if (scm_is_false (result
))
5831 if (SCM_INEXACTP (result
))
5832 return scm_inexact_to_exact (result
);
5836 if (SCM_INEXACTP (result
))
5839 return scm_exact_to_inexact (result
);
5841 if (implicit_x
== INEXACT
)
5843 if (SCM_INEXACTP (result
))
5846 return scm_exact_to_inexact (result
);
5852 /* We should never get here */
5853 scm_syserror ("mem2ureal");
5857 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5860 mem2complex (SCM mem
, unsigned int idx
,
5861 unsigned int radix
, enum t_exactness forced_x
)
5866 size_t len
= scm_i_string_length (mem
);
5871 c
= scm_i_string_ref (mem
, idx
);
5886 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5887 if (scm_is_false (ureal
))
5889 /* input must be either +i or -i */
5894 if (scm_i_string_ref (mem
, idx
) == 'i'
5895 || scm_i_string_ref (mem
, idx
) == 'I')
5901 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5908 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5909 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5914 c
= scm_i_string_ref (mem
, idx
);
5918 /* either +<ureal>i or -<ureal>i */
5925 return scm_make_rectangular (SCM_INUM0
, ureal
);
5928 /* polar input: <real>@<real>. */
5939 c
= scm_i_string_ref (mem
, idx
);
5957 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5958 if (scm_is_false (angle
))
5963 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5964 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5966 result
= scm_make_polar (ureal
, angle
);
5971 /* expecting input matching <real>[+-]<ureal>?i */
5978 int sign
= (c
== '+') ? 1 : -1;
5979 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5981 if (scm_is_false (imag
))
5982 imag
= SCM_I_MAKINUM (sign
);
5983 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5984 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5988 if (scm_i_string_ref (mem
, idx
) != 'i'
5989 && scm_i_string_ref (mem
, idx
) != 'I')
5996 return scm_make_rectangular (ureal
, imag
);
6005 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6007 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6010 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6012 unsigned int idx
= 0;
6013 unsigned int radix
= NO_RADIX
;
6014 enum t_exactness forced_x
= NO_EXACTNESS
;
6015 size_t len
= scm_i_string_length (mem
);
6017 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6018 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6020 switch (scm_i_string_ref (mem
, idx
+ 1))
6023 if (radix
!= NO_RADIX
)
6028 if (radix
!= NO_RADIX
)
6033 if (forced_x
!= NO_EXACTNESS
)
6038 if (forced_x
!= NO_EXACTNESS
)
6043 if (radix
!= NO_RADIX
)
6048 if (radix
!= NO_RADIX
)
6058 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6059 if (radix
== NO_RADIX
)
6060 radix
= default_radix
;
6062 return mem2complex (mem
, idx
, radix
, forced_x
);
6066 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6067 unsigned int default_radix
)
6069 SCM str
= scm_from_locale_stringn (mem
, len
);
6071 return scm_i_string_to_number (str
, default_radix
);
6075 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6076 (SCM string
, SCM radix
),
6077 "Return a number of the maximally precise representation\n"
6078 "expressed by the given @var{string}. @var{radix} must be an\n"
6079 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6080 "is a default radix that may be overridden by an explicit radix\n"
6081 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6082 "supplied, then the default radix is 10. If string is not a\n"
6083 "syntactically valid notation for a number, then\n"
6084 "@code{string->number} returns @code{#f}.")
6085 #define FUNC_NAME s_scm_string_to_number
6089 SCM_VALIDATE_STRING (1, string
);
6091 if (SCM_UNBNDP (radix
))
6094 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6096 answer
= scm_i_string_to_number (string
, base
);
6097 scm_remember_upto_here_1 (string
);
6103 /*** END strs->nums ***/
6106 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6108 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6110 #define FUNC_NAME s_scm_number_p
6112 return scm_from_bool (SCM_NUMBERP (x
));
6116 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6118 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6119 "otherwise. Note that the sets of real, rational and integer\n"
6120 "values form subsets of the set of complex numbers, i. e. the\n"
6121 "predicate will also be fulfilled if @var{x} is a real,\n"
6122 "rational or integer number.")
6123 #define FUNC_NAME s_scm_complex_p
6125 /* all numbers are complex. */
6126 return scm_number_p (x
);
6130 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6132 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6133 "otherwise. Note that the set of integer values forms a subset of\n"
6134 "the set of real numbers, i. e. the predicate will also be\n"
6135 "fulfilled if @var{x} is an integer number.")
6136 #define FUNC_NAME s_scm_real_p
6138 return scm_from_bool
6139 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6143 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6145 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6146 "otherwise. Note that the set of integer values forms a subset of\n"
6147 "the set of rational numbers, i. e. the predicate will also be\n"
6148 "fulfilled if @var{x} is an integer number.")
6149 #define FUNC_NAME s_scm_rational_p
6151 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6153 else if (SCM_REALP (x
))
6154 /* due to their limited precision, finite floating point numbers are
6155 rational as well. (finite means neither infinity nor a NaN) */
6156 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6162 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6164 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6166 #define FUNC_NAME s_scm_integer_p
6168 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6170 else if (SCM_REALP (x
))
6172 double val
= SCM_REAL_VALUE (x
);
6173 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6181 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6182 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6183 (SCM x
, SCM y
, SCM rest
),
6184 "Return @code{#t} if all parameters are numerically equal.")
6185 #define FUNC_NAME s_scm_i_num_eq_p
6187 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6189 while (!scm_is_null (rest
))
6191 if (scm_is_false (scm_num_eq_p (x
, y
)))
6195 rest
= scm_cdr (rest
);
6197 return scm_num_eq_p (x
, y
);
6201 scm_num_eq_p (SCM x
, SCM y
)
6204 if (SCM_I_INUMP (x
))
6206 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6207 if (SCM_I_INUMP (y
))
6209 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6210 return scm_from_bool (xx
== yy
);
6212 else if (SCM_BIGP (y
))
6214 else if (SCM_REALP (y
))
6216 /* On a 32-bit system an inum fits a double, we can cast the inum
6217 to a double and compare.
6219 But on a 64-bit system an inum is bigger than a double and
6220 casting it to a double (call that dxx) will round. dxx is at
6221 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6222 an integer and fits a long. So we cast yy to a long and
6223 compare with plain xx.
6225 An alternative (for any size system actually) would be to check
6226 yy is an integer (with floor) and is in range of an inum
6227 (compare against appropriate powers of 2) then test
6228 xx==(scm_t_signed_bits)yy. It's just a matter of which
6229 casts/comparisons might be fastest or easiest for the cpu. */
6231 double yy
= SCM_REAL_VALUE (y
);
6232 return scm_from_bool ((double) xx
== yy
6233 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6234 || xx
== (scm_t_signed_bits
) yy
));
6236 else if (SCM_COMPLEXP (y
))
6237 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6238 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6239 else if (SCM_FRACTIONP (y
))
6242 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6244 else if (SCM_BIGP (x
))
6246 if (SCM_I_INUMP (y
))
6248 else if (SCM_BIGP (y
))
6250 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6251 scm_remember_upto_here_2 (x
, y
);
6252 return scm_from_bool (0 == cmp
);
6254 else if (SCM_REALP (y
))
6257 if (isnan (SCM_REAL_VALUE (y
)))
6259 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6260 scm_remember_upto_here_1 (x
);
6261 return scm_from_bool (0 == cmp
);
6263 else if (SCM_COMPLEXP (y
))
6266 if (0.0 != SCM_COMPLEX_IMAG (y
))
6268 if (isnan (SCM_COMPLEX_REAL (y
)))
6270 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6271 scm_remember_upto_here_1 (x
);
6272 return scm_from_bool (0 == cmp
);
6274 else if (SCM_FRACTIONP (y
))
6277 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6279 else if (SCM_REALP (x
))
6281 double xx
= SCM_REAL_VALUE (x
);
6282 if (SCM_I_INUMP (y
))
6284 /* see comments with inum/real above */
6285 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6286 return scm_from_bool (xx
== (double) yy
6287 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6288 || (scm_t_signed_bits
) xx
== yy
));
6290 else if (SCM_BIGP (y
))
6293 if (isnan (SCM_REAL_VALUE (x
)))
6295 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6296 scm_remember_upto_here_1 (y
);
6297 return scm_from_bool (0 == cmp
);
6299 else if (SCM_REALP (y
))
6300 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6301 else if (SCM_COMPLEXP (y
))
6302 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6303 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6304 else if (SCM_FRACTIONP (y
))
6306 double xx
= SCM_REAL_VALUE (x
);
6310 return scm_from_bool (xx
< 0.0);
6311 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6315 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
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 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6355 else if (SCM_FRACTIONP (x
))
6357 if (SCM_I_INUMP (y
))
6359 else if (SCM_BIGP (y
))
6361 else if (SCM_REALP (y
))
6363 double yy
= SCM_REAL_VALUE (y
);
6367 return scm_from_bool (0.0 < yy
);
6368 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6371 else if (SCM_COMPLEXP (y
))
6374 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6376 yy
= SCM_COMPLEX_REAL (y
);
6380 return scm_from_bool (0.0 < yy
);
6381 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6384 else if (SCM_FRACTIONP (y
))
6385 return scm_i_fraction_equalp (x
, y
);
6387 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6390 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6394 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6395 done are good for inums, but for bignums an answer can almost always be
6396 had by just examining a few high bits of the operands, as done by GMP in
6397 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6398 of the float exponent to take into account. */
6400 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6401 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6402 (SCM x
, SCM y
, SCM rest
),
6403 "Return @code{#t} if the list of parameters is monotonically\n"
6405 #define FUNC_NAME s_scm_i_num_less_p
6407 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6409 while (!scm_is_null (rest
))
6411 if (scm_is_false (scm_less_p (x
, y
)))
6415 rest
= scm_cdr (rest
);
6417 return scm_less_p (x
, y
);
6421 scm_less_p (SCM x
, SCM y
)
6424 if (SCM_I_INUMP (x
))
6426 scm_t_inum xx
= SCM_I_INUM (x
);
6427 if (SCM_I_INUMP (y
))
6429 scm_t_inum yy
= SCM_I_INUM (y
);
6430 return scm_from_bool (xx
< yy
);
6432 else if (SCM_BIGP (y
))
6434 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6435 scm_remember_upto_here_1 (y
);
6436 return scm_from_bool (sgn
> 0);
6438 else if (SCM_REALP (y
))
6439 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6440 else if (SCM_FRACTIONP (y
))
6442 /* "x < a/b" becomes "x*b < a" */
6444 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6445 y
= SCM_FRACTION_NUMERATOR (y
);
6449 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6451 else if (SCM_BIGP (x
))
6453 if (SCM_I_INUMP (y
))
6455 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6456 scm_remember_upto_here_1 (x
);
6457 return scm_from_bool (sgn
< 0);
6459 else if (SCM_BIGP (y
))
6461 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6462 scm_remember_upto_here_2 (x
, y
);
6463 return scm_from_bool (cmp
< 0);
6465 else if (SCM_REALP (y
))
6468 if (isnan (SCM_REAL_VALUE (y
)))
6470 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6471 scm_remember_upto_here_1 (x
);
6472 return scm_from_bool (cmp
< 0);
6474 else if (SCM_FRACTIONP (y
))
6477 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6479 else if (SCM_REALP (x
))
6481 if (SCM_I_INUMP (y
))
6482 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6483 else if (SCM_BIGP (y
))
6486 if (isnan (SCM_REAL_VALUE (x
)))
6488 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6489 scm_remember_upto_here_1 (y
);
6490 return scm_from_bool (cmp
> 0);
6492 else if (SCM_REALP (y
))
6493 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6494 else if (SCM_FRACTIONP (y
))
6496 double xx
= SCM_REAL_VALUE (x
);
6500 return scm_from_bool (xx
< 0.0);
6501 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6505 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6507 else if (SCM_FRACTIONP (x
))
6509 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6511 /* "a/b < y" becomes "a < y*b" */
6512 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6513 x
= SCM_FRACTION_NUMERATOR (x
);
6516 else if (SCM_REALP (y
))
6518 double yy
= SCM_REAL_VALUE (y
);
6522 return scm_from_bool (0.0 < yy
);
6523 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6526 else if (SCM_FRACTIONP (y
))
6528 /* "a/b < c/d" becomes "a*d < c*b" */
6529 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6530 SCM_FRACTION_DENOMINATOR (y
));
6531 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6532 SCM_FRACTION_DENOMINATOR (x
));
6538 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6541 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6545 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6546 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6547 (SCM x
, SCM y
, SCM rest
),
6548 "Return @code{#t} if the list of parameters is monotonically\n"
6550 #define FUNC_NAME s_scm_i_num_gr_p
6552 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6554 while (!scm_is_null (rest
))
6556 if (scm_is_false (scm_gr_p (x
, y
)))
6560 rest
= scm_cdr (rest
);
6562 return scm_gr_p (x
, y
);
6565 #define FUNC_NAME s_scm_i_num_gr_p
6567 scm_gr_p (SCM x
, SCM y
)
6569 if (!SCM_NUMBERP (x
))
6570 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6571 else if (!SCM_NUMBERP (y
))
6572 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6574 return scm_less_p (y
, x
);
6579 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6580 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6581 (SCM x
, SCM y
, SCM rest
),
6582 "Return @code{#t} if the list of parameters is monotonically\n"
6584 #define FUNC_NAME s_scm_i_num_leq_p
6586 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6588 while (!scm_is_null (rest
))
6590 if (scm_is_false (scm_leq_p (x
, y
)))
6594 rest
= scm_cdr (rest
);
6596 return scm_leq_p (x
, y
);
6599 #define FUNC_NAME s_scm_i_num_leq_p
6601 scm_leq_p (SCM x
, SCM y
)
6603 if (!SCM_NUMBERP (x
))
6604 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6605 else if (!SCM_NUMBERP (y
))
6606 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6607 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6610 return scm_not (scm_less_p (y
, x
));
6615 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6616 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6617 (SCM x
, SCM y
, SCM rest
),
6618 "Return @code{#t} if the list of parameters is monotonically\n"
6620 #define FUNC_NAME s_scm_i_num_geq_p
6622 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6624 while (!scm_is_null (rest
))
6626 if (scm_is_false (scm_geq_p (x
, y
)))
6630 rest
= scm_cdr (rest
);
6632 return scm_geq_p (x
, y
);
6635 #define FUNC_NAME s_scm_i_num_geq_p
6637 scm_geq_p (SCM x
, SCM y
)
6639 if (!SCM_NUMBERP (x
))
6640 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6641 else if (!SCM_NUMBERP (y
))
6642 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6643 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6646 return scm_not (scm_less_p (x
, y
));
6651 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6653 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6655 #define FUNC_NAME s_scm_zero_p
6657 if (SCM_I_INUMP (z
))
6658 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6659 else if (SCM_BIGP (z
))
6661 else if (SCM_REALP (z
))
6662 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6663 else if (SCM_COMPLEXP (z
))
6664 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6665 && SCM_COMPLEX_IMAG (z
) == 0.0);
6666 else if (SCM_FRACTIONP (z
))
6669 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6674 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6676 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6678 #define FUNC_NAME s_scm_positive_p
6680 if (SCM_I_INUMP (x
))
6681 return scm_from_bool (SCM_I_INUM (x
) > 0);
6682 else if (SCM_BIGP (x
))
6684 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6685 scm_remember_upto_here_1 (x
);
6686 return scm_from_bool (sgn
> 0);
6688 else if (SCM_REALP (x
))
6689 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6690 else if (SCM_FRACTIONP (x
))
6691 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6693 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6698 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6700 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6702 #define FUNC_NAME s_scm_negative_p
6704 if (SCM_I_INUMP (x
))
6705 return scm_from_bool (SCM_I_INUM (x
) < 0);
6706 else if (SCM_BIGP (x
))
6708 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6709 scm_remember_upto_here_1 (x
);
6710 return scm_from_bool (sgn
< 0);
6712 else if (SCM_REALP (x
))
6713 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6714 else if (SCM_FRACTIONP (x
))
6715 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6717 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6722 /* scm_min and scm_max return an inexact when either argument is inexact, as
6723 required by r5rs. On that basis, for exact/inexact combinations the
6724 exact is converted to inexact to compare and possibly return. This is
6725 unlike scm_less_p above which takes some trouble to preserve all bits in
6726 its test, such trouble is not required for min and max. */
6728 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6729 (SCM x
, SCM y
, SCM rest
),
6730 "Return the maximum of all parameter values.")
6731 #define FUNC_NAME s_scm_i_max
6733 while (!scm_is_null (rest
))
6734 { x
= scm_max (x
, y
);
6736 rest
= scm_cdr (rest
);
6738 return scm_max (x
, y
);
6742 #define s_max s_scm_i_max
6743 #define g_max g_scm_i_max
6746 scm_max (SCM x
, SCM y
)
6751 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6752 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6755 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6758 if (SCM_I_INUMP (x
))
6760 scm_t_inum xx
= SCM_I_INUM (x
);
6761 if (SCM_I_INUMP (y
))
6763 scm_t_inum yy
= SCM_I_INUM (y
);
6764 return (xx
< yy
) ? y
: x
;
6766 else if (SCM_BIGP (y
))
6768 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6769 scm_remember_upto_here_1 (y
);
6770 return (sgn
< 0) ? x
: y
;
6772 else if (SCM_REALP (y
))
6775 double yyd
= SCM_REAL_VALUE (y
);
6778 return scm_from_double (xxd
);
6779 /* If y is a NaN, then "==" is false and we return the NaN */
6780 else if (SCM_LIKELY (!(xxd
== yyd
)))
6782 /* Handle signed zeroes properly */
6788 else if (SCM_FRACTIONP (y
))
6791 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6794 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6796 else if (SCM_BIGP (x
))
6798 if (SCM_I_INUMP (y
))
6800 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6801 scm_remember_upto_here_1 (x
);
6802 return (sgn
< 0) ? y
: x
;
6804 else if (SCM_BIGP (y
))
6806 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6807 scm_remember_upto_here_2 (x
, y
);
6808 return (cmp
> 0) ? x
: y
;
6810 else if (SCM_REALP (y
))
6812 /* if y==NaN then xx>yy is false, so we return the NaN y */
6815 xx
= scm_i_big2dbl (x
);
6816 yy
= SCM_REAL_VALUE (y
);
6817 return (xx
> yy
? scm_from_double (xx
) : y
);
6819 else if (SCM_FRACTIONP (y
))
6824 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6826 else if (SCM_REALP (x
))
6828 if (SCM_I_INUMP (y
))
6830 scm_t_inum yy
= SCM_I_INUM (y
);
6831 double xxd
= SCM_REAL_VALUE (x
);
6835 return scm_from_double (yyd
);
6836 /* If x is a NaN, then "==" is false and we return the NaN */
6837 else if (SCM_LIKELY (!(xxd
== yyd
)))
6839 /* Handle signed zeroes properly */
6845 else if (SCM_BIGP (y
))
6850 else if (SCM_REALP (y
))
6852 double xx
= SCM_REAL_VALUE (x
);
6853 double yy
= SCM_REAL_VALUE (y
);
6855 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6858 else if (SCM_LIKELY (xx
< yy
))
6860 /* If neither (xx > yy) nor (xx < yy), then
6861 either they're equal or one is a NaN */
6862 else if (SCM_UNLIKELY (isnan (xx
)))
6863 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6864 else if (SCM_UNLIKELY (isnan (yy
)))
6865 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6866 /* xx == yy, but handle signed zeroes properly */
6867 else if (double_is_non_negative_zero (yy
))
6872 else if (SCM_FRACTIONP (y
))
6874 double yy
= scm_i_fraction2double (y
);
6875 double xx
= SCM_REAL_VALUE (x
);
6876 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6879 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6881 else if (SCM_FRACTIONP (x
))
6883 if (SCM_I_INUMP (y
))
6887 else if (SCM_BIGP (y
))
6891 else if (SCM_REALP (y
))
6893 double xx
= scm_i_fraction2double (x
);
6894 /* if y==NaN then ">" is false, so we return the NaN y */
6895 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6897 else if (SCM_FRACTIONP (y
))
6902 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6905 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6909 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6910 (SCM x
, SCM y
, SCM rest
),
6911 "Return the minimum of all parameter values.")
6912 #define FUNC_NAME s_scm_i_min
6914 while (!scm_is_null (rest
))
6915 { x
= scm_min (x
, y
);
6917 rest
= scm_cdr (rest
);
6919 return scm_min (x
, y
);
6923 #define s_min s_scm_i_min
6924 #define g_min g_scm_i_min
6927 scm_min (SCM x
, SCM y
)
6932 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
6933 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6936 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
6939 if (SCM_I_INUMP (x
))
6941 scm_t_inum xx
= SCM_I_INUM (x
);
6942 if (SCM_I_INUMP (y
))
6944 scm_t_inum yy
= SCM_I_INUM (y
);
6945 return (xx
< yy
) ? x
: y
;
6947 else if (SCM_BIGP (y
))
6949 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6950 scm_remember_upto_here_1 (y
);
6951 return (sgn
< 0) ? y
: x
;
6953 else if (SCM_REALP (y
))
6956 /* if y==NaN then "<" is false and we return NaN */
6957 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6959 else if (SCM_FRACTIONP (y
))
6962 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6965 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6967 else if (SCM_BIGP (x
))
6969 if (SCM_I_INUMP (y
))
6971 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6972 scm_remember_upto_here_1 (x
);
6973 return (sgn
< 0) ? x
: y
;
6975 else if (SCM_BIGP (y
))
6977 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6978 scm_remember_upto_here_2 (x
, y
);
6979 return (cmp
> 0) ? y
: x
;
6981 else if (SCM_REALP (y
))
6983 /* if y==NaN then xx<yy is false, so we return the NaN y */
6986 xx
= scm_i_big2dbl (x
);
6987 yy
= SCM_REAL_VALUE (y
);
6988 return (xx
< yy
? scm_from_double (xx
) : y
);
6990 else if (SCM_FRACTIONP (y
))
6995 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6997 else if (SCM_REALP (x
))
6999 if (SCM_I_INUMP (y
))
7001 double z
= SCM_I_INUM (y
);
7002 /* if x==NaN then "<" is false and we return NaN */
7003 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7005 else if (SCM_BIGP (y
))
7010 else if (SCM_REALP (y
))
7012 double xx
= SCM_REAL_VALUE (x
);
7013 double yy
= SCM_REAL_VALUE (y
);
7015 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7018 else if (SCM_LIKELY (xx
> yy
))
7020 /* If neither (xx < yy) nor (xx > yy), then
7021 either they're equal or one is a NaN */
7022 else if (SCM_UNLIKELY (isnan (xx
)))
7023 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7024 else if (SCM_UNLIKELY (isnan (yy
)))
7025 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7026 /* xx == yy, but handle signed zeroes properly */
7027 else if (double_is_non_negative_zero (xx
))
7032 else if (SCM_FRACTIONP (y
))
7034 double yy
= scm_i_fraction2double (y
);
7035 double xx
= SCM_REAL_VALUE (x
);
7036 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7039 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7041 else if (SCM_FRACTIONP (x
))
7043 if (SCM_I_INUMP (y
))
7047 else if (SCM_BIGP (y
))
7051 else if (SCM_REALP (y
))
7053 double xx
= scm_i_fraction2double (x
);
7054 /* if y==NaN then "<" is false, so we return the NaN y */
7055 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7057 else if (SCM_FRACTIONP (y
))
7062 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7065 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7069 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7070 (SCM x
, SCM y
, SCM rest
),
7071 "Return the sum of all parameter values. Return 0 if called without\n"
7073 #define FUNC_NAME s_scm_i_sum
7075 while (!scm_is_null (rest
))
7076 { x
= scm_sum (x
, y
);
7078 rest
= scm_cdr (rest
);
7080 return scm_sum (x
, y
);
7084 #define s_sum s_scm_i_sum
7085 #define g_sum g_scm_i_sum
7088 scm_sum (SCM x
, SCM y
)
7090 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7092 if (SCM_NUMBERP (x
)) return x
;
7093 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7094 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7097 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7099 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7101 scm_t_inum xx
= SCM_I_INUM (x
);
7102 scm_t_inum yy
= SCM_I_INUM (y
);
7103 scm_t_inum z
= xx
+ yy
;
7104 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7106 else if (SCM_BIGP (y
))
7111 else if (SCM_REALP (y
))
7113 scm_t_inum xx
= SCM_I_INUM (x
);
7114 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7116 else if (SCM_COMPLEXP (y
))
7118 scm_t_inum xx
= SCM_I_INUM (x
);
7119 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7120 SCM_COMPLEX_IMAG (y
));
7122 else if (SCM_FRACTIONP (y
))
7123 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7124 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7125 SCM_FRACTION_DENOMINATOR (y
));
7127 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7128 } else if (SCM_BIGP (x
))
7130 if (SCM_I_INUMP (y
))
7135 inum
= SCM_I_INUM (y
);
7138 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7141 SCM result
= scm_i_mkbig ();
7142 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7143 scm_remember_upto_here_1 (x
);
7144 /* we know the result will have to be a bignum */
7147 return scm_i_normbig (result
);
7151 SCM result
= scm_i_mkbig ();
7152 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7153 scm_remember_upto_here_1 (x
);
7154 /* we know the result will have to be a bignum */
7157 return scm_i_normbig (result
);
7160 else if (SCM_BIGP (y
))
7162 SCM result
= scm_i_mkbig ();
7163 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7164 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7165 mpz_add (SCM_I_BIG_MPZ (result
),
7168 scm_remember_upto_here_2 (x
, y
);
7169 /* we know the result will have to be a bignum */
7172 return scm_i_normbig (result
);
7174 else if (SCM_REALP (y
))
7176 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7177 scm_remember_upto_here_1 (x
);
7178 return scm_from_double (result
);
7180 else if (SCM_COMPLEXP (y
))
7182 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7183 + SCM_COMPLEX_REAL (y
));
7184 scm_remember_upto_here_1 (x
);
7185 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7187 else if (SCM_FRACTIONP (y
))
7188 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7189 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7190 SCM_FRACTION_DENOMINATOR (y
));
7192 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7194 else if (SCM_REALP (x
))
7196 if (SCM_I_INUMP (y
))
7197 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7198 else if (SCM_BIGP (y
))
7200 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7201 scm_remember_upto_here_1 (y
);
7202 return scm_from_double (result
);
7204 else if (SCM_REALP (y
))
7205 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7206 else if (SCM_COMPLEXP (y
))
7207 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7208 SCM_COMPLEX_IMAG (y
));
7209 else if (SCM_FRACTIONP (y
))
7210 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7212 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7214 else if (SCM_COMPLEXP (x
))
7216 if (SCM_I_INUMP (y
))
7217 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7218 SCM_COMPLEX_IMAG (x
));
7219 else if (SCM_BIGP (y
))
7221 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7222 + SCM_COMPLEX_REAL (x
));
7223 scm_remember_upto_here_1 (y
);
7224 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7226 else if (SCM_REALP (y
))
7227 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7228 SCM_COMPLEX_IMAG (x
));
7229 else if (SCM_COMPLEXP (y
))
7230 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7231 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7232 else if (SCM_FRACTIONP (y
))
7233 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7234 SCM_COMPLEX_IMAG (x
));
7236 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7238 else if (SCM_FRACTIONP (x
))
7240 if (SCM_I_INUMP (y
))
7241 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7242 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7243 SCM_FRACTION_DENOMINATOR (x
));
7244 else if (SCM_BIGP (y
))
7245 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7246 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7247 SCM_FRACTION_DENOMINATOR (x
));
7248 else if (SCM_REALP (y
))
7249 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7250 else if (SCM_COMPLEXP (y
))
7251 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7252 SCM_COMPLEX_IMAG (y
));
7253 else if (SCM_FRACTIONP (y
))
7254 /* a/b + c/d = (ad + bc) / bd */
7255 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7256 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7257 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7259 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7262 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7266 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7268 "Return @math{@var{x}+1}.")
7269 #define FUNC_NAME s_scm_oneplus
7271 return scm_sum (x
, SCM_INUM1
);
7276 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7277 (SCM x
, SCM y
, SCM rest
),
7278 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7279 "the sum of all but the first argument are subtracted from the first\n"
7281 #define FUNC_NAME s_scm_i_difference
7283 while (!scm_is_null (rest
))
7284 { x
= scm_difference (x
, y
);
7286 rest
= scm_cdr (rest
);
7288 return scm_difference (x
, y
);
7292 #define s_difference s_scm_i_difference
7293 #define g_difference g_scm_i_difference
7296 scm_difference (SCM x
, SCM y
)
7297 #define FUNC_NAME s_difference
7299 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7302 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7304 if (SCM_I_INUMP (x
))
7306 scm_t_inum xx
= -SCM_I_INUM (x
);
7307 if (SCM_FIXABLE (xx
))
7308 return SCM_I_MAKINUM (xx
);
7310 return scm_i_inum2big (xx
);
7312 else if (SCM_BIGP (x
))
7313 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7314 bignum, but negating that gives a fixnum. */
7315 return scm_i_normbig (scm_i_clonebig (x
, 0));
7316 else if (SCM_REALP (x
))
7317 return scm_from_double (-SCM_REAL_VALUE (x
));
7318 else if (SCM_COMPLEXP (x
))
7319 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7320 -SCM_COMPLEX_IMAG (x
));
7321 else if (SCM_FRACTIONP (x
))
7322 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7323 SCM_FRACTION_DENOMINATOR (x
));
7325 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7328 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7330 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7332 scm_t_inum xx
= SCM_I_INUM (x
);
7333 scm_t_inum yy
= SCM_I_INUM (y
);
7334 scm_t_inum z
= xx
- yy
;
7335 if (SCM_FIXABLE (z
))
7336 return SCM_I_MAKINUM (z
);
7338 return scm_i_inum2big (z
);
7340 else if (SCM_BIGP (y
))
7342 /* inum-x - big-y */
7343 scm_t_inum xx
= SCM_I_INUM (x
);
7347 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7348 bignum, but negating that gives a fixnum. */
7349 return scm_i_normbig (scm_i_clonebig (y
, 0));
7353 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7354 SCM result
= scm_i_mkbig ();
7357 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7360 /* x - y == -(y + -x) */
7361 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7362 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7364 scm_remember_upto_here_1 (y
);
7366 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7367 /* we know the result will have to be a bignum */
7370 return scm_i_normbig (result
);
7373 else if (SCM_REALP (y
))
7375 scm_t_inum xx
= SCM_I_INUM (x
);
7378 * We need to handle x == exact 0
7379 * specially because R6RS states that:
7380 * (- 0.0) ==> -0.0 and
7381 * (- 0.0 0.0) ==> 0.0
7382 * and the scheme compiler changes
7383 * (- 0.0) into (- 0 0.0)
7384 * So we need to treat (- 0 0.0) like (- 0.0).
7385 * At the C level, (-x) is different than (0.0 - x).
7386 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7389 return scm_from_double (- SCM_REAL_VALUE (y
));
7391 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7393 else if (SCM_COMPLEXP (y
))
7395 scm_t_inum xx
= SCM_I_INUM (x
);
7397 /* We need to handle x == exact 0 specially.
7398 See the comment above (for SCM_REALP (y)) */
7400 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7401 - SCM_COMPLEX_IMAG (y
));
7403 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7404 - SCM_COMPLEX_IMAG (y
));
7406 else if (SCM_FRACTIONP (y
))
7407 /* a - b/c = (ac - b) / c */
7408 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7409 SCM_FRACTION_NUMERATOR (y
)),
7410 SCM_FRACTION_DENOMINATOR (y
));
7412 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7414 else if (SCM_BIGP (x
))
7416 if (SCM_I_INUMP (y
))
7418 /* big-x - inum-y */
7419 scm_t_inum yy
= SCM_I_INUM (y
);
7420 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7422 scm_remember_upto_here_1 (x
);
7424 return (SCM_FIXABLE (-yy
) ?
7425 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7428 SCM result
= scm_i_mkbig ();
7431 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7433 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7434 scm_remember_upto_here_1 (x
);
7436 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7437 /* we know the result will have to be a bignum */
7440 return scm_i_normbig (result
);
7443 else if (SCM_BIGP (y
))
7445 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7446 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7447 SCM result
= scm_i_mkbig ();
7448 mpz_sub (SCM_I_BIG_MPZ (result
),
7451 scm_remember_upto_here_2 (x
, y
);
7452 /* we know the result will have to be a bignum */
7453 if ((sgn_x
== 1) && (sgn_y
== -1))
7455 if ((sgn_x
== -1) && (sgn_y
== 1))
7457 return scm_i_normbig (result
);
7459 else if (SCM_REALP (y
))
7461 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7462 scm_remember_upto_here_1 (x
);
7463 return scm_from_double (result
);
7465 else if (SCM_COMPLEXP (y
))
7467 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7468 - SCM_COMPLEX_REAL (y
));
7469 scm_remember_upto_here_1 (x
);
7470 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7472 else if (SCM_FRACTIONP (y
))
7473 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7474 SCM_FRACTION_NUMERATOR (y
)),
7475 SCM_FRACTION_DENOMINATOR (y
));
7476 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7478 else if (SCM_REALP (x
))
7480 if (SCM_I_INUMP (y
))
7481 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7482 else if (SCM_BIGP (y
))
7484 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7485 scm_remember_upto_here_1 (x
);
7486 return scm_from_double (result
);
7488 else if (SCM_REALP (y
))
7489 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7490 else if (SCM_COMPLEXP (y
))
7491 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7492 -SCM_COMPLEX_IMAG (y
));
7493 else if (SCM_FRACTIONP (y
))
7494 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7496 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7498 else if (SCM_COMPLEXP (x
))
7500 if (SCM_I_INUMP (y
))
7501 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7502 SCM_COMPLEX_IMAG (x
));
7503 else if (SCM_BIGP (y
))
7505 double real_part
= (SCM_COMPLEX_REAL (x
)
7506 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7507 scm_remember_upto_here_1 (x
);
7508 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7510 else if (SCM_REALP (y
))
7511 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7512 SCM_COMPLEX_IMAG (x
));
7513 else if (SCM_COMPLEXP (y
))
7514 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7515 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7516 else if (SCM_FRACTIONP (y
))
7517 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7518 SCM_COMPLEX_IMAG (x
));
7520 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7522 else if (SCM_FRACTIONP (x
))
7524 if (SCM_I_INUMP (y
))
7525 /* a/b - c = (a - cb) / b */
7526 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7527 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7528 SCM_FRACTION_DENOMINATOR (x
));
7529 else if (SCM_BIGP (y
))
7530 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7531 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7532 SCM_FRACTION_DENOMINATOR (x
));
7533 else if (SCM_REALP (y
))
7534 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7535 else if (SCM_COMPLEXP (y
))
7536 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7537 -SCM_COMPLEX_IMAG (y
));
7538 else if (SCM_FRACTIONP (y
))
7539 /* a/b - c/d = (ad - bc) / bd */
7540 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7541 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7542 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7544 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7547 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7552 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7554 "Return @math{@var{x}-1}.")
7555 #define FUNC_NAME s_scm_oneminus
7557 return scm_difference (x
, SCM_INUM1
);
7562 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7563 (SCM x
, SCM y
, SCM rest
),
7564 "Return the product of all arguments. If called without arguments,\n"
7566 #define FUNC_NAME s_scm_i_product
7568 while (!scm_is_null (rest
))
7569 { x
= scm_product (x
, y
);
7571 rest
= scm_cdr (rest
);
7573 return scm_product (x
, y
);
7577 #define s_product s_scm_i_product
7578 #define g_product g_scm_i_product
7581 scm_product (SCM x
, SCM y
)
7583 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7586 return SCM_I_MAKINUM (1L);
7587 else if (SCM_NUMBERP (x
))
7590 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7593 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7598 xx
= SCM_I_INUM (x
);
7603 /* exact1 is the universal multiplicative identity */
7607 /* exact0 times a fixnum is exact0: optimize this case */
7608 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7610 /* if the other argument is inexact, the result is inexact,
7611 and we must do the multiplication in order to handle
7612 infinities and NaNs properly. */
7613 else if (SCM_REALP (y
))
7614 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7615 else if (SCM_COMPLEXP (y
))
7616 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7617 0.0 * SCM_COMPLEX_IMAG (y
));
7618 /* we've already handled inexact numbers,
7619 so y must be exact, and we return exact0 */
7620 else if (SCM_NUMP (y
))
7623 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7627 * This case is important for more than just optimization.
7628 * It handles the case of negating
7629 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7630 * which is a bignum that must be changed back into a fixnum.
7631 * Failure to do so will cause the following to return #f:
7632 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7634 return scm_difference(y
, SCM_UNDEFINED
);
7638 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7640 scm_t_inum yy
= SCM_I_INUM (y
);
7641 scm_t_inum kk
= xx
* yy
;
7642 SCM k
= SCM_I_MAKINUM (kk
);
7643 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7647 SCM result
= scm_i_inum2big (xx
);
7648 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7649 return scm_i_normbig (result
);
7652 else if (SCM_BIGP (y
))
7654 SCM result
= scm_i_mkbig ();
7655 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7656 scm_remember_upto_here_1 (y
);
7659 else if (SCM_REALP (y
))
7660 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7661 else if (SCM_COMPLEXP (y
))
7662 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7663 xx
* SCM_COMPLEX_IMAG (y
));
7664 else if (SCM_FRACTIONP (y
))
7665 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7666 SCM_FRACTION_DENOMINATOR (y
));
7668 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7670 else if (SCM_BIGP (x
))
7672 if (SCM_I_INUMP (y
))
7677 else if (SCM_BIGP (y
))
7679 SCM result
= scm_i_mkbig ();
7680 mpz_mul (SCM_I_BIG_MPZ (result
),
7683 scm_remember_upto_here_2 (x
, y
);
7686 else if (SCM_REALP (y
))
7688 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7689 scm_remember_upto_here_1 (x
);
7690 return scm_from_double (result
);
7692 else if (SCM_COMPLEXP (y
))
7694 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7695 scm_remember_upto_here_1 (x
);
7696 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7697 z
* SCM_COMPLEX_IMAG (y
));
7699 else if (SCM_FRACTIONP (y
))
7700 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7701 SCM_FRACTION_DENOMINATOR (y
));
7703 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7705 else if (SCM_REALP (x
))
7707 if (SCM_I_INUMP (y
))
7712 else if (SCM_BIGP (y
))
7714 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7715 scm_remember_upto_here_1 (y
);
7716 return scm_from_double (result
);
7718 else if (SCM_REALP (y
))
7719 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7720 else if (SCM_COMPLEXP (y
))
7721 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7722 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7723 else if (SCM_FRACTIONP (y
))
7724 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7726 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7728 else if (SCM_COMPLEXP (x
))
7730 if (SCM_I_INUMP (y
))
7735 else if (SCM_BIGP (y
))
7737 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7738 scm_remember_upto_here_1 (y
);
7739 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7740 z
* SCM_COMPLEX_IMAG (x
));
7742 else if (SCM_REALP (y
))
7743 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7744 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7745 else if (SCM_COMPLEXP (y
))
7747 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7748 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7749 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7750 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7752 else if (SCM_FRACTIONP (y
))
7754 double yy
= scm_i_fraction2double (y
);
7755 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7756 yy
* SCM_COMPLEX_IMAG (x
));
7759 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7761 else if (SCM_FRACTIONP (x
))
7763 if (SCM_I_INUMP (y
))
7764 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7765 SCM_FRACTION_DENOMINATOR (x
));
7766 else if (SCM_BIGP (y
))
7767 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7768 SCM_FRACTION_DENOMINATOR (x
));
7769 else if (SCM_REALP (y
))
7770 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7771 else if (SCM_COMPLEXP (y
))
7773 double xx
= scm_i_fraction2double (x
);
7774 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7775 xx
* SCM_COMPLEX_IMAG (y
));
7777 else if (SCM_FRACTIONP (y
))
7778 /* a/b * c/d = ac / bd */
7779 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7780 SCM_FRACTION_NUMERATOR (y
)),
7781 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7782 SCM_FRACTION_DENOMINATOR (y
)));
7784 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7787 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7790 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7791 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7792 #define ALLOW_DIVIDE_BY_ZERO
7793 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7796 /* The code below for complex division is adapted from the GNU
7797 libstdc++, which adapted it from f2c's libF77, and is subject to
7800 /****************************************************************
7801 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7803 Permission to use, copy, modify, and distribute this software
7804 and its documentation for any purpose and without fee is hereby
7805 granted, provided that the above copyright notice appear in all
7806 copies and that both that the copyright notice and this
7807 permission notice and warranty disclaimer appear in supporting
7808 documentation, and that the names of AT&T Bell Laboratories or
7809 Bellcore or any of their entities not be used in advertising or
7810 publicity pertaining to distribution of the software without
7811 specific, written prior permission.
7813 AT&T and Bellcore disclaim all warranties with regard to this
7814 software, including all implied warranties of merchantability
7815 and fitness. In no event shall AT&T or Bellcore be liable for
7816 any special, indirect or consequential damages or any damages
7817 whatsoever resulting from loss of use, data or profits, whether
7818 in an action of contract, negligence or other tortious action,
7819 arising out of or in connection with the use or performance of
7821 ****************************************************************/
7823 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7824 (SCM x
, SCM y
, SCM rest
),
7825 "Divide the first argument by the product of the remaining\n"
7826 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7828 #define FUNC_NAME s_scm_i_divide
7830 while (!scm_is_null (rest
))
7831 { x
= scm_divide (x
, y
);
7833 rest
= scm_cdr (rest
);
7835 return scm_divide (x
, y
);
7839 #define s_divide s_scm_i_divide
7840 #define g_divide g_scm_i_divide
7843 do_divide (SCM x
, SCM y
, int inexact
)
7844 #define FUNC_NAME s_divide
7848 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7851 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7852 else if (SCM_I_INUMP (x
))
7854 scm_t_inum xx
= SCM_I_INUM (x
);
7855 if (xx
== 1 || xx
== -1)
7857 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7859 scm_num_overflow (s_divide
);
7864 return scm_from_double (1.0 / (double) xx
);
7865 else return scm_i_make_ratio (SCM_INUM1
, x
);
7868 else if (SCM_BIGP (x
))
7871 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7872 else return scm_i_make_ratio (SCM_INUM1
, x
);
7874 else if (SCM_REALP (x
))
7876 double xx
= SCM_REAL_VALUE (x
);
7877 #ifndef ALLOW_DIVIDE_BY_ZERO
7879 scm_num_overflow (s_divide
);
7882 return scm_from_double (1.0 / xx
);
7884 else if (SCM_COMPLEXP (x
))
7886 double r
= SCM_COMPLEX_REAL (x
);
7887 double i
= SCM_COMPLEX_IMAG (x
);
7888 if (fabs(r
) <= fabs(i
))
7891 double d
= i
* (1.0 + t
* t
);
7892 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7897 double d
= r
* (1.0 + t
* t
);
7898 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7901 else if (SCM_FRACTIONP (x
))
7902 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7903 SCM_FRACTION_NUMERATOR (x
));
7905 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7908 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7910 scm_t_inum xx
= SCM_I_INUM (x
);
7911 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7913 scm_t_inum yy
= SCM_I_INUM (y
);
7916 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7917 scm_num_overflow (s_divide
);
7919 return scm_from_double ((double) xx
/ (double) yy
);
7922 else if (xx
% yy
!= 0)
7925 return scm_from_double ((double) xx
/ (double) yy
);
7926 else return scm_i_make_ratio (x
, y
);
7930 scm_t_inum z
= xx
/ yy
;
7931 if (SCM_FIXABLE (z
))
7932 return SCM_I_MAKINUM (z
);
7934 return scm_i_inum2big (z
);
7937 else if (SCM_BIGP (y
))
7940 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7941 else return scm_i_make_ratio (x
, y
);
7943 else if (SCM_REALP (y
))
7945 double yy
= SCM_REAL_VALUE (y
);
7946 #ifndef ALLOW_DIVIDE_BY_ZERO
7948 scm_num_overflow (s_divide
);
7951 return scm_from_double ((double) xx
/ yy
);
7953 else if (SCM_COMPLEXP (y
))
7956 complex_div
: /* y _must_ be a complex number */
7958 double r
= SCM_COMPLEX_REAL (y
);
7959 double i
= SCM_COMPLEX_IMAG (y
);
7960 if (fabs(r
) <= fabs(i
))
7963 double d
= i
* (1.0 + t
* t
);
7964 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7969 double d
= r
* (1.0 + t
* t
);
7970 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7974 else if (SCM_FRACTIONP (y
))
7975 /* a / b/c = ac / b */
7976 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7977 SCM_FRACTION_NUMERATOR (y
));
7979 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7981 else if (SCM_BIGP (x
))
7983 if (SCM_I_INUMP (y
))
7985 scm_t_inum yy
= SCM_I_INUM (y
);
7988 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7989 scm_num_overflow (s_divide
);
7991 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7992 scm_remember_upto_here_1 (x
);
7993 return (sgn
== 0) ? scm_nan () : scm_inf ();
8000 /* FIXME: HMM, what are the relative performance issues here?
8001 We need to test. Is it faster on average to test
8002 divisible_p, then perform whichever operation, or is it
8003 faster to perform the integer div opportunistically and
8004 switch to real if there's a remainder? For now we take the
8005 middle ground: test, then if divisible, use the faster div
8008 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8009 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8013 SCM result
= scm_i_mkbig ();
8014 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8015 scm_remember_upto_here_1 (x
);
8017 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8018 return scm_i_normbig (result
);
8023 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
8024 else return scm_i_make_ratio (x
, y
);
8028 else if (SCM_BIGP (y
))
8033 /* It's easily possible for the ratio x/y to fit a double
8034 but one or both x and y be too big to fit a double,
8035 hence the use of mpq_get_d rather than converting and
8038 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8039 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8040 return scm_from_double (mpq_get_d (q
));
8044 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8048 SCM result
= scm_i_mkbig ();
8049 mpz_divexact (SCM_I_BIG_MPZ (result
),
8052 scm_remember_upto_here_2 (x
, y
);
8053 return scm_i_normbig (result
);
8056 return scm_i_make_ratio (x
, y
);
8059 else if (SCM_REALP (y
))
8061 double yy
= SCM_REAL_VALUE (y
);
8062 #ifndef ALLOW_DIVIDE_BY_ZERO
8064 scm_num_overflow (s_divide
);
8067 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8069 else if (SCM_COMPLEXP (y
))
8071 a
= scm_i_big2dbl (x
);
8074 else if (SCM_FRACTIONP (y
))
8075 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8076 SCM_FRACTION_NUMERATOR (y
));
8078 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8080 else if (SCM_REALP (x
))
8082 double rx
= SCM_REAL_VALUE (x
);
8083 if (SCM_I_INUMP (y
))
8085 scm_t_inum yy
= SCM_I_INUM (y
);
8086 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8088 scm_num_overflow (s_divide
);
8091 return scm_from_double (rx
/ (double) yy
);
8093 else if (SCM_BIGP (y
))
8095 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8096 scm_remember_upto_here_1 (y
);
8097 return scm_from_double (rx
/ dby
);
8099 else if (SCM_REALP (y
))
8101 double yy
= SCM_REAL_VALUE (y
);
8102 #ifndef ALLOW_DIVIDE_BY_ZERO
8104 scm_num_overflow (s_divide
);
8107 return scm_from_double (rx
/ yy
);
8109 else if (SCM_COMPLEXP (y
))
8114 else if (SCM_FRACTIONP (y
))
8115 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8117 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8119 else if (SCM_COMPLEXP (x
))
8121 double rx
= SCM_COMPLEX_REAL (x
);
8122 double ix
= SCM_COMPLEX_IMAG (x
);
8123 if (SCM_I_INUMP (y
))
8125 scm_t_inum yy
= SCM_I_INUM (y
);
8126 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8128 scm_num_overflow (s_divide
);
8133 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8136 else if (SCM_BIGP (y
))
8138 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8139 scm_remember_upto_here_1 (y
);
8140 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8142 else if (SCM_REALP (y
))
8144 double yy
= SCM_REAL_VALUE (y
);
8145 #ifndef ALLOW_DIVIDE_BY_ZERO
8147 scm_num_overflow (s_divide
);
8150 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8152 else if (SCM_COMPLEXP (y
))
8154 double ry
= SCM_COMPLEX_REAL (y
);
8155 double iy
= SCM_COMPLEX_IMAG (y
);
8156 if (fabs(ry
) <= fabs(iy
))
8159 double d
= iy
* (1.0 + t
* t
);
8160 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8165 double d
= ry
* (1.0 + t
* t
);
8166 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8169 else if (SCM_FRACTIONP (y
))
8171 double yy
= scm_i_fraction2double (y
);
8172 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8175 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8177 else if (SCM_FRACTIONP (x
))
8179 if (SCM_I_INUMP (y
))
8181 scm_t_inum yy
= SCM_I_INUM (y
);
8182 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8184 scm_num_overflow (s_divide
);
8187 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8188 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8190 else if (SCM_BIGP (y
))
8192 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8193 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8195 else if (SCM_REALP (y
))
8197 double yy
= SCM_REAL_VALUE (y
);
8198 #ifndef ALLOW_DIVIDE_BY_ZERO
8200 scm_num_overflow (s_divide
);
8203 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8205 else if (SCM_COMPLEXP (y
))
8207 a
= scm_i_fraction2double (x
);
8210 else if (SCM_FRACTIONP (y
))
8211 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8212 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8214 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8217 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8221 scm_divide (SCM x
, SCM y
)
8223 return do_divide (x
, y
, 0);
8226 static SCM
scm_divide2real (SCM x
, SCM y
)
8228 return do_divide (x
, y
, 1);
8234 scm_c_truncate (double x
)
8239 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8240 half-way case (ie. when x is an integer plus 0.5) going upwards.
8241 Then half-way cases are identified and adjusted down if the
8242 round-upwards didn't give the desired even integer.
8244 "plus_half == result" identifies a half-way case. If plus_half, which is
8245 x + 0.5, is an integer then x must be an integer plus 0.5.
8247 An odd "result" value is identified with result/2 != floor(result/2).
8248 This is done with plus_half, since that value is ready for use sooner in
8249 a pipelined cpu, and we're already requiring plus_half == result.
8251 Note however that we need to be careful when x is big and already an
8252 integer. In that case "x+0.5" may round to an adjacent integer, causing
8253 us to return such a value, incorrectly. For instance if the hardware is
8254 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8255 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8256 returned. Or if the hardware is in round-upwards mode, then other bigger
8257 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8258 representable value, 2^128+2^76 (or whatever), again incorrect.
8260 These bad roundings of x+0.5 are avoided by testing at the start whether
8261 x is already an integer. If it is then clearly that's the desired result
8262 already. And if it's not then the exponent must be small enough to allow
8263 an 0.5 to be represented, and hence added without a bad rounding. */
8266 scm_c_round (double x
)
8268 double plus_half
, result
;
8273 plus_half
= x
+ 0.5;
8274 result
= floor (plus_half
);
8275 /* Adjust so that the rounding is towards even. */
8276 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8281 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8283 "Round the number @var{x} towards zero.")
8284 #define FUNC_NAME s_scm_truncate_number
8286 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8288 else if (SCM_REALP (x
))
8289 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8290 else if (SCM_FRACTIONP (x
))
8291 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8292 SCM_FRACTION_DENOMINATOR (x
));
8294 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8295 s_scm_truncate_number
);
8299 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8301 "Round the number @var{x} towards the nearest integer. "
8302 "When it is exactly halfway between two integers, "
8303 "round towards the even one.")
8304 #define FUNC_NAME s_scm_round_number
8306 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8308 else if (SCM_REALP (x
))
8309 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8310 else if (SCM_FRACTIONP (x
))
8311 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8312 SCM_FRACTION_DENOMINATOR (x
));
8314 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8315 s_scm_round_number
);
8319 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8321 "Round the number @var{x} towards minus infinity.")
8322 #define FUNC_NAME s_scm_floor
8324 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8326 else if (SCM_REALP (x
))
8327 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8328 else if (SCM_FRACTIONP (x
))
8329 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8330 SCM_FRACTION_DENOMINATOR (x
));
8332 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8336 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8338 "Round the number @var{x} towards infinity.")
8339 #define FUNC_NAME s_scm_ceiling
8341 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8343 else if (SCM_REALP (x
))
8344 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8345 else if (SCM_FRACTIONP (x
))
8346 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8347 SCM_FRACTION_DENOMINATOR (x
));
8349 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8353 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8355 "Return @var{x} raised to the power of @var{y}.")
8356 #define FUNC_NAME s_scm_expt
8358 if (scm_is_integer (y
))
8360 if (scm_is_true (scm_exact_p (y
)))
8361 return scm_integer_expt (x
, y
);
8364 /* Here we handle the case where the exponent is an inexact
8365 integer. We make the exponent exact in order to use
8366 scm_integer_expt, and thus avoid the spurious imaginary
8367 parts that may result from round-off errors in the general
8368 e^(y log x) method below (for example when squaring a large
8369 negative number). In this case, we must return an inexact
8370 result for correctness. We also make the base inexact so
8371 that scm_integer_expt will use fast inexact arithmetic
8372 internally. Note that making the base inexact is not
8373 sufficient to guarantee an inexact result, because
8374 scm_integer_expt will return an exact 1 when the exponent
8375 is 0, even if the base is inexact. */
8376 return scm_exact_to_inexact
8377 (scm_integer_expt (scm_exact_to_inexact (x
),
8378 scm_inexact_to_exact (y
)));
8381 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8383 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8385 else if (scm_is_complex (x
) && scm_is_complex (y
))
8386 return scm_exp (scm_product (scm_log (x
), y
));
8387 else if (scm_is_complex (x
))
8388 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8390 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8394 /* sin/cos/tan/asin/acos/atan
8395 sinh/cosh/tanh/asinh/acosh/atanh
8396 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8397 Written by Jerry D. Hedden, (C) FSF.
8398 See the file `COPYING' for terms applying to this program. */
8400 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8402 "Compute the sine of @var{z}.")
8403 #define FUNC_NAME s_scm_sin
8405 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8406 return z
; /* sin(exact0) = exact0 */
8407 else if (scm_is_real (z
))
8408 return scm_from_double (sin (scm_to_double (z
)));
8409 else if (SCM_COMPLEXP (z
))
8411 x
= SCM_COMPLEX_REAL (z
);
8412 y
= SCM_COMPLEX_IMAG (z
);
8413 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8414 cos (x
) * sinh (y
));
8417 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8421 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8423 "Compute the cosine of @var{z}.")
8424 #define FUNC_NAME s_scm_cos
8426 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8427 return SCM_INUM1
; /* cos(exact0) = exact1 */
8428 else if (scm_is_real (z
))
8429 return scm_from_double (cos (scm_to_double (z
)));
8430 else if (SCM_COMPLEXP (z
))
8432 x
= SCM_COMPLEX_REAL (z
);
8433 y
= SCM_COMPLEX_IMAG (z
);
8434 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8435 -sin (x
) * sinh (y
));
8438 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8442 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8444 "Compute the tangent of @var{z}.")
8445 #define FUNC_NAME s_scm_tan
8447 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8448 return z
; /* tan(exact0) = exact0 */
8449 else if (scm_is_real (z
))
8450 return scm_from_double (tan (scm_to_double (z
)));
8451 else if (SCM_COMPLEXP (z
))
8453 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8454 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8455 w
= cos (x
) + cosh (y
);
8456 #ifndef ALLOW_DIVIDE_BY_ZERO
8458 scm_num_overflow (s_scm_tan
);
8460 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8463 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8467 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8469 "Compute the hyperbolic sine of @var{z}.")
8470 #define FUNC_NAME s_scm_sinh
8472 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8473 return z
; /* sinh(exact0) = exact0 */
8474 else if (scm_is_real (z
))
8475 return scm_from_double (sinh (scm_to_double (z
)));
8476 else if (SCM_COMPLEXP (z
))
8478 x
= SCM_COMPLEX_REAL (z
);
8479 y
= SCM_COMPLEX_IMAG (z
);
8480 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8481 cosh (x
) * sin (y
));
8484 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8488 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8490 "Compute the hyperbolic cosine of @var{z}.")
8491 #define FUNC_NAME s_scm_cosh
8493 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8494 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8495 else if (scm_is_real (z
))
8496 return scm_from_double (cosh (scm_to_double (z
)));
8497 else if (SCM_COMPLEXP (z
))
8499 x
= SCM_COMPLEX_REAL (z
);
8500 y
= SCM_COMPLEX_IMAG (z
);
8501 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8502 sinh (x
) * sin (y
));
8505 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8509 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8511 "Compute the hyperbolic tangent of @var{z}.")
8512 #define FUNC_NAME s_scm_tanh
8514 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8515 return z
; /* tanh(exact0) = exact0 */
8516 else if (scm_is_real (z
))
8517 return scm_from_double (tanh (scm_to_double (z
)));
8518 else if (SCM_COMPLEXP (z
))
8520 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8521 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8522 w
= cosh (x
) + cos (y
);
8523 #ifndef ALLOW_DIVIDE_BY_ZERO
8525 scm_num_overflow (s_scm_tanh
);
8527 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8530 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8534 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8536 "Compute the arc sine of @var{z}.")
8537 #define FUNC_NAME s_scm_asin
8539 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8540 return z
; /* asin(exact0) = exact0 */
8541 else if (scm_is_real (z
))
8543 double w
= scm_to_double (z
);
8544 if (w
>= -1.0 && w
<= 1.0)
8545 return scm_from_double (asin (w
));
8547 return scm_product (scm_c_make_rectangular (0, -1),
8548 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8550 else if (SCM_COMPLEXP (z
))
8552 x
= SCM_COMPLEX_REAL (z
);
8553 y
= SCM_COMPLEX_IMAG (z
);
8554 return scm_product (scm_c_make_rectangular (0, -1),
8555 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8558 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8562 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8564 "Compute the arc cosine of @var{z}.")
8565 #define FUNC_NAME s_scm_acos
8567 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8568 return SCM_INUM0
; /* acos(exact1) = exact0 */
8569 else if (scm_is_real (z
))
8571 double w
= scm_to_double (z
);
8572 if (w
>= -1.0 && w
<= 1.0)
8573 return scm_from_double (acos (w
));
8575 return scm_sum (scm_from_double (acos (0.0)),
8576 scm_product (scm_c_make_rectangular (0, 1),
8577 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8579 else if (SCM_COMPLEXP (z
))
8581 x
= SCM_COMPLEX_REAL (z
);
8582 y
= SCM_COMPLEX_IMAG (z
);
8583 return scm_sum (scm_from_double (acos (0.0)),
8584 scm_product (scm_c_make_rectangular (0, 1),
8585 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8588 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8592 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8594 "With one argument, compute the arc tangent of @var{z}.\n"
8595 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8596 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8597 #define FUNC_NAME s_scm_atan
8601 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8602 return z
; /* atan(exact0) = exact0 */
8603 else if (scm_is_real (z
))
8604 return scm_from_double (atan (scm_to_double (z
)));
8605 else if (SCM_COMPLEXP (z
))
8608 v
= SCM_COMPLEX_REAL (z
);
8609 w
= SCM_COMPLEX_IMAG (z
);
8610 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8611 scm_c_make_rectangular (v
, w
+ 1.0))),
8612 scm_c_make_rectangular (0, 2));
8615 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8617 else if (scm_is_real (z
))
8619 if (scm_is_real (y
))
8620 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8622 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8625 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8629 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8631 "Compute the inverse hyperbolic sine of @var{z}.")
8632 #define FUNC_NAME s_scm_sys_asinh
8634 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8635 return z
; /* asinh(exact0) = exact0 */
8636 else if (scm_is_real (z
))
8637 return scm_from_double (asinh (scm_to_double (z
)));
8638 else if (scm_is_number (z
))
8639 return scm_log (scm_sum (z
,
8640 scm_sqrt (scm_sum (scm_product (z
, z
),
8643 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8647 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8649 "Compute the inverse hyperbolic cosine of @var{z}.")
8650 #define FUNC_NAME s_scm_sys_acosh
8652 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8653 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8654 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8655 return scm_from_double (acosh (scm_to_double (z
)));
8656 else if (scm_is_number (z
))
8657 return scm_log (scm_sum (z
,
8658 scm_sqrt (scm_difference (scm_product (z
, z
),
8661 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8665 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8667 "Compute the inverse hyperbolic tangent of @var{z}.")
8668 #define FUNC_NAME s_scm_sys_atanh
8670 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8671 return z
; /* atanh(exact0) = exact0 */
8672 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8673 return scm_from_double (atanh (scm_to_double (z
)));
8674 else if (scm_is_number (z
))
8675 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8676 scm_difference (SCM_INUM1
, z
))),
8679 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8684 scm_c_make_rectangular (double re
, double im
)
8688 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8690 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8691 SCM_COMPLEX_REAL (z
) = re
;
8692 SCM_COMPLEX_IMAG (z
) = im
;
8696 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8697 (SCM real_part
, SCM imaginary_part
),
8698 "Return a complex number constructed of the given @var{real-part} "
8699 "and @var{imaginary-part} parts.")
8700 #define FUNC_NAME s_scm_make_rectangular
8702 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8703 SCM_ARG1
, FUNC_NAME
, "real");
8704 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8705 SCM_ARG2
, FUNC_NAME
, "real");
8707 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8708 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8711 return scm_c_make_rectangular (scm_to_double (real_part
),
8712 scm_to_double (imaginary_part
));
8717 scm_c_make_polar (double mag
, double ang
)
8721 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8722 use it on Glibc-based systems that have it (it's a GNU extension). See
8723 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8725 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8726 sincos (ang
, &s
, &c
);
8732 /* If s and c are NaNs, this indicates that the angle is a NaN,
8733 infinite, or perhaps simply too large to determine its value
8734 mod 2*pi. However, we know something that the floating-point
8735 implementation doesn't know: We know that s and c are finite.
8736 Therefore, if the magnitude is zero, return a complex zero.
8738 The reason we check for the NaNs instead of using this case
8739 whenever mag == 0.0 is because when the angle is known, we'd
8740 like to return the correct kind of non-real complex zero:
8741 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8742 on which quadrant the angle is in.
8744 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8745 return scm_c_make_rectangular (0.0, 0.0);
8747 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8750 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8752 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8753 #define FUNC_NAME s_scm_make_polar
8755 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8756 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8758 /* If mag is exact0, return exact0 */
8759 if (scm_is_eq (mag
, SCM_INUM0
))
8761 /* Return a real if ang is exact0 */
8762 else if (scm_is_eq (ang
, SCM_INUM0
))
8765 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8770 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8772 "Return the real part of the number @var{z}.")
8773 #define FUNC_NAME s_scm_real_part
8775 if (SCM_COMPLEXP (z
))
8776 return scm_from_double (SCM_COMPLEX_REAL (z
));
8777 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8780 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8785 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8787 "Return the imaginary part of the number @var{z}.")
8788 #define FUNC_NAME s_scm_imag_part
8790 if (SCM_COMPLEXP (z
))
8791 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8792 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8795 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8799 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8801 "Return the numerator of the number @var{z}.")
8802 #define FUNC_NAME s_scm_numerator
8804 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8806 else if (SCM_FRACTIONP (z
))
8807 return SCM_FRACTION_NUMERATOR (z
);
8808 else if (SCM_REALP (z
))
8809 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8811 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8816 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8818 "Return the denominator of the number @var{z}.")
8819 #define FUNC_NAME s_scm_denominator
8821 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8823 else if (SCM_FRACTIONP (z
))
8824 return SCM_FRACTION_DENOMINATOR (z
);
8825 else if (SCM_REALP (z
))
8826 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8828 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8833 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8835 "Return the magnitude of the number @var{z}. This is the same as\n"
8836 "@code{abs} for real arguments, but also allows complex numbers.")
8837 #define FUNC_NAME s_scm_magnitude
8839 if (SCM_I_INUMP (z
))
8841 scm_t_inum zz
= SCM_I_INUM (z
);
8844 else if (SCM_POSFIXABLE (-zz
))
8845 return SCM_I_MAKINUM (-zz
);
8847 return scm_i_inum2big (-zz
);
8849 else if (SCM_BIGP (z
))
8851 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8852 scm_remember_upto_here_1 (z
);
8854 return scm_i_clonebig (z
, 0);
8858 else if (SCM_REALP (z
))
8859 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8860 else if (SCM_COMPLEXP (z
))
8861 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8862 else if (SCM_FRACTIONP (z
))
8864 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8866 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8867 SCM_FRACTION_DENOMINATOR (z
));
8870 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8875 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8877 "Return the angle of the complex number @var{z}.")
8878 #define FUNC_NAME s_scm_angle
8880 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8881 flo0 to save allocating a new flonum with scm_from_double each time.
8882 But if atan2 follows the floating point rounding mode, then the value
8883 is not a constant. Maybe it'd be close enough though. */
8884 if (SCM_I_INUMP (z
))
8886 if (SCM_I_INUM (z
) >= 0)
8889 return scm_from_double (atan2 (0.0, -1.0));
8891 else if (SCM_BIGP (z
))
8893 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8894 scm_remember_upto_here_1 (z
);
8896 return scm_from_double (atan2 (0.0, -1.0));
8900 else if (SCM_REALP (z
))
8902 if (SCM_REAL_VALUE (z
) >= 0)
8905 return scm_from_double (atan2 (0.0, -1.0));
8907 else if (SCM_COMPLEXP (z
))
8908 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8909 else if (SCM_FRACTIONP (z
))
8911 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8913 else return scm_from_double (atan2 (0.0, -1.0));
8916 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8921 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8923 "Convert the number @var{z} to its inexact representation.\n")
8924 #define FUNC_NAME s_scm_exact_to_inexact
8926 if (SCM_I_INUMP (z
))
8927 return scm_from_double ((double) SCM_I_INUM (z
));
8928 else if (SCM_BIGP (z
))
8929 return scm_from_double (scm_i_big2dbl (z
));
8930 else if (SCM_FRACTIONP (z
))
8931 return scm_from_double (scm_i_fraction2double (z
));
8932 else if (SCM_INEXACTP (z
))
8935 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
8940 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8942 "Return an exact number that is numerically closest to @var{z}.")
8943 #define FUNC_NAME s_scm_inexact_to_exact
8945 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8952 val
= SCM_REAL_VALUE (z
);
8953 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8954 val
= SCM_COMPLEX_REAL (z
);
8956 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
8958 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8959 SCM_OUT_OF_RANGE (1, z
);
8966 mpq_set_d (frac
, val
);
8967 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8968 scm_i_mpz2num (mpq_denref (frac
)));
8970 /* When scm_i_make_ratio throws, we leak the memory allocated
8980 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8982 "Returns the @emph{simplest} rational number differing\n"
8983 "from @var{x} by no more than @var{eps}.\n"
8985 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8986 "exact result when both its arguments are exact. Thus, you might need\n"
8987 "to use @code{inexact->exact} on the arguments.\n"
8990 "(rationalize (inexact->exact 1.2) 1/100)\n"
8993 #define FUNC_NAME s_scm_rationalize
8995 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
8996 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
8997 eps
= scm_abs (eps
);
8998 if (scm_is_false (scm_positive_p (eps
)))
9000 /* eps is either zero or a NaN */
9001 if (scm_is_true (scm_nan_p (eps
)))
9003 else if (SCM_INEXACTP (eps
))
9004 return scm_exact_to_inexact (x
);
9008 else if (scm_is_false (scm_finite_p (eps
)))
9010 if (scm_is_true (scm_finite_p (x
)))
9015 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9017 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9018 scm_ceiling (scm_difference (x
, eps
)))))
9020 /* There's an integer within range; we want the one closest to zero */
9021 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9023 /* zero is within range */
9024 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9029 else if (scm_is_true (scm_positive_p (x
)))
9030 return scm_ceiling (scm_difference (x
, eps
));
9032 return scm_floor (scm_sum (x
, eps
));
9036 /* Use continued fractions to find closest ratio. All
9037 arithmetic is done with exact numbers.
9040 SCM ex
= scm_inexact_to_exact (x
);
9041 SCM int_part
= scm_floor (ex
);
9043 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9044 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9048 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9049 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9051 /* We stop after a million iterations just to be absolutely sure
9052 that we don't go into an infinite loop. The process normally
9053 converges after less than a dozen iterations.
9056 while (++i
< 1000000)
9058 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9059 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9060 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9062 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9063 eps
))) /* abs(x-a/b) <= eps */
9065 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9066 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9067 return scm_exact_to_inexact (res
);
9071 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9073 tt
= scm_floor (rx
); /* tt = floor (rx) */
9079 scm_num_overflow (s_scm_rationalize
);
9084 /* conversion functions */
9087 scm_is_integer (SCM val
)
9089 return scm_is_true (scm_integer_p (val
));
9093 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9095 if (SCM_I_INUMP (val
))
9097 scm_t_signed_bits n
= SCM_I_INUM (val
);
9098 return n
>= min
&& n
<= max
;
9100 else if (SCM_BIGP (val
))
9102 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9104 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9106 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9108 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9109 return n
>= min
&& n
<= max
;
9119 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9120 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9123 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9124 SCM_I_BIG_MPZ (val
));
9126 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9138 return n
>= min
&& n
<= max
;
9146 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9148 if (SCM_I_INUMP (val
))
9150 scm_t_signed_bits n
= SCM_I_INUM (val
);
9151 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9153 else if (SCM_BIGP (val
))
9155 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9157 else if (max
<= ULONG_MAX
)
9159 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9161 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9162 return n
>= min
&& n
<= max
;
9172 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9175 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9176 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9179 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9180 SCM_I_BIG_MPZ (val
));
9182 return n
>= min
&& n
<= max
;
9190 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9192 scm_error (scm_out_of_range_key
,
9194 "Value out of range ~S to ~S: ~S",
9195 scm_list_3 (min
, max
, bad_val
),
9196 scm_list_1 (bad_val
));
9199 #define TYPE scm_t_intmax
9200 #define TYPE_MIN min
9201 #define TYPE_MAX max
9202 #define SIZEOF_TYPE 0
9203 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9204 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9205 #include "libguile/conv-integer.i.c"
9207 #define TYPE scm_t_uintmax
9208 #define TYPE_MIN min
9209 #define TYPE_MAX max
9210 #define SIZEOF_TYPE 0
9211 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9212 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9213 #include "libguile/conv-uinteger.i.c"
9215 #define TYPE scm_t_int8
9216 #define TYPE_MIN SCM_T_INT8_MIN
9217 #define TYPE_MAX SCM_T_INT8_MAX
9218 #define SIZEOF_TYPE 1
9219 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9220 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9221 #include "libguile/conv-integer.i.c"
9223 #define TYPE scm_t_uint8
9225 #define TYPE_MAX SCM_T_UINT8_MAX
9226 #define SIZEOF_TYPE 1
9227 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9228 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9229 #include "libguile/conv-uinteger.i.c"
9231 #define TYPE scm_t_int16
9232 #define TYPE_MIN SCM_T_INT16_MIN
9233 #define TYPE_MAX SCM_T_INT16_MAX
9234 #define SIZEOF_TYPE 2
9235 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9236 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9237 #include "libguile/conv-integer.i.c"
9239 #define TYPE scm_t_uint16
9241 #define TYPE_MAX SCM_T_UINT16_MAX
9242 #define SIZEOF_TYPE 2
9243 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9244 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9245 #include "libguile/conv-uinteger.i.c"
9247 #define TYPE scm_t_int32
9248 #define TYPE_MIN SCM_T_INT32_MIN
9249 #define TYPE_MAX SCM_T_INT32_MAX
9250 #define SIZEOF_TYPE 4
9251 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9252 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9253 #include "libguile/conv-integer.i.c"
9255 #define TYPE scm_t_uint32
9257 #define TYPE_MAX SCM_T_UINT32_MAX
9258 #define SIZEOF_TYPE 4
9259 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9260 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9261 #include "libguile/conv-uinteger.i.c"
9263 #define TYPE scm_t_wchar
9264 #define TYPE_MIN (scm_t_int32)-1
9265 #define TYPE_MAX (scm_t_int32)0x10ffff
9266 #define SIZEOF_TYPE 4
9267 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9268 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9269 #include "libguile/conv-integer.i.c"
9271 #define TYPE scm_t_int64
9272 #define TYPE_MIN SCM_T_INT64_MIN
9273 #define TYPE_MAX SCM_T_INT64_MAX
9274 #define SIZEOF_TYPE 8
9275 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9276 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9277 #include "libguile/conv-integer.i.c"
9279 #define TYPE scm_t_uint64
9281 #define TYPE_MAX SCM_T_UINT64_MAX
9282 #define SIZEOF_TYPE 8
9283 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9284 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9285 #include "libguile/conv-uinteger.i.c"
9288 scm_to_mpz (SCM val
, mpz_t rop
)
9290 if (SCM_I_INUMP (val
))
9291 mpz_set_si (rop
, SCM_I_INUM (val
));
9292 else if (SCM_BIGP (val
))
9293 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9295 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9299 scm_from_mpz (mpz_t val
)
9301 return scm_i_mpz2num (val
);
9305 scm_is_real (SCM val
)
9307 return scm_is_true (scm_real_p (val
));
9311 scm_is_rational (SCM val
)
9313 return scm_is_true (scm_rational_p (val
));
9317 scm_to_double (SCM val
)
9319 if (SCM_I_INUMP (val
))
9320 return SCM_I_INUM (val
);
9321 else if (SCM_BIGP (val
))
9322 return scm_i_big2dbl (val
);
9323 else if (SCM_FRACTIONP (val
))
9324 return scm_i_fraction2double (val
);
9325 else if (SCM_REALP (val
))
9326 return SCM_REAL_VALUE (val
);
9328 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9332 scm_from_double (double val
)
9336 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9338 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9339 SCM_REAL_VALUE (z
) = val
;
9344 #if SCM_ENABLE_DEPRECATED == 1
9347 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9349 scm_c_issue_deprecation_warning
9350 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9354 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9358 scm_out_of_range (NULL
, num
);
9361 return scm_to_double (num
);
9365 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9367 scm_c_issue_deprecation_warning
9368 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9372 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9376 scm_out_of_range (NULL
, num
);
9379 return scm_to_double (num
);
9385 scm_is_complex (SCM val
)
9387 return scm_is_true (scm_complex_p (val
));
9391 scm_c_real_part (SCM z
)
9393 if (SCM_COMPLEXP (z
))
9394 return SCM_COMPLEX_REAL (z
);
9397 /* Use the scm_real_part to get proper error checking and
9400 return scm_to_double (scm_real_part (z
));
9405 scm_c_imag_part (SCM z
)
9407 if (SCM_COMPLEXP (z
))
9408 return SCM_COMPLEX_IMAG (z
);
9411 /* Use the scm_imag_part to get proper error checking and
9412 dispatching. The result will almost always be 0.0, but not
9415 return scm_to_double (scm_imag_part (z
));
9420 scm_c_magnitude (SCM z
)
9422 return scm_to_double (scm_magnitude (z
));
9428 return scm_to_double (scm_angle (z
));
9432 scm_is_number (SCM z
)
9434 return scm_is_true (scm_number_p (z
));
9438 /* Returns log(x * 2^shift) */
9440 log_of_shifted_double (double x
, long shift
)
9442 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9444 if (x
> 0.0 || double_is_non_negative_zero (x
))
9445 return scm_from_double (ans
);
9447 return scm_c_make_rectangular (ans
, M_PI
);
9450 /* Returns log(n), for exact integer n of integer-length size */
9452 log_of_exact_integer_with_size (SCM n
, long size
)
9454 long shift
= size
- 2 * scm_dblprec
[0];
9457 return log_of_shifted_double
9458 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9461 return log_of_shifted_double (scm_to_double (n
), 0);
9464 /* Returns log(n), for exact integer n */
9466 log_of_exact_integer (SCM n
)
9468 return log_of_exact_integer_with_size
9469 (n
, scm_to_long (scm_integer_length (n
)));
9472 /* Returns log(n/d), for exact non-zero integers n and d */
9474 log_of_fraction (SCM n
, SCM d
)
9476 long n_size
= scm_to_long (scm_integer_length (n
));
9477 long d_size
= scm_to_long (scm_integer_length (d
));
9479 if (abs (n_size
- d_size
) > 1)
9480 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9481 log_of_exact_integer_with_size (d
, d_size
)));
9482 else if (scm_is_false (scm_negative_p (n
)))
9483 return scm_from_double
9484 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9486 return scm_c_make_rectangular
9487 (log1p (scm_to_double (scm_divide2real
9488 (scm_difference (scm_abs (n
), d
),
9494 /* In the following functions we dispatch to the real-arg funcs like log()
9495 when we know the arg is real, instead of just handing everything to
9496 clog() for instance. This is in case clog() doesn't optimize for a
9497 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9498 well use it to go straight to the applicable C func. */
9500 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9502 "Return the natural logarithm of @var{z}.")
9503 #define FUNC_NAME s_scm_log
9505 if (SCM_COMPLEXP (z
))
9507 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9508 && defined (SCM_COMPLEX_VALUE)
9509 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9511 double re
= SCM_COMPLEX_REAL (z
);
9512 double im
= SCM_COMPLEX_IMAG (z
);
9513 return scm_c_make_rectangular (log (hypot (re
, im
)),
9517 else if (SCM_REALP (z
))
9518 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9519 else if (SCM_I_INUMP (z
))
9521 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9522 if (scm_is_eq (z
, SCM_INUM0
))
9523 scm_num_overflow (s_scm_log
);
9525 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9527 else if (SCM_BIGP (z
))
9528 return log_of_exact_integer (z
);
9529 else if (SCM_FRACTIONP (z
))
9530 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9531 SCM_FRACTION_DENOMINATOR (z
));
9533 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9538 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9540 "Return the base 10 logarithm of @var{z}.")
9541 #define FUNC_NAME s_scm_log10
9543 if (SCM_COMPLEXP (z
))
9545 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9546 clog() and a multiply by M_LOG10E, rather than the fallback
9547 log10+hypot+atan2.) */
9548 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9549 && defined SCM_COMPLEX_VALUE
9550 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9552 double re
= SCM_COMPLEX_REAL (z
);
9553 double im
= SCM_COMPLEX_IMAG (z
);
9554 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9555 M_LOG10E
* atan2 (im
, re
));
9558 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9560 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9561 if (scm_is_eq (z
, SCM_INUM0
))
9562 scm_num_overflow (s_scm_log10
);
9565 double re
= scm_to_double (z
);
9566 double l
= log10 (fabs (re
));
9567 if (re
> 0.0 || double_is_non_negative_zero (re
))
9568 return scm_from_double (l
);
9570 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9573 else if (SCM_BIGP (z
))
9574 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9575 else if (SCM_FRACTIONP (z
))
9576 return scm_product (flo_log10e
,
9577 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9578 SCM_FRACTION_DENOMINATOR (z
)));
9580 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9585 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9587 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9588 "base of natural logarithms (2.71828@dots{}).")
9589 #define FUNC_NAME s_scm_exp
9591 if (SCM_COMPLEXP (z
))
9593 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9594 && defined (SCM_COMPLEX_VALUE)
9595 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9597 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9598 SCM_COMPLEX_IMAG (z
));
9601 else if (SCM_NUMBERP (z
))
9603 /* When z is a negative bignum the conversion to double overflows,
9604 giving -infinity, but that's ok, the exp is still 0.0. */
9605 return scm_from_double (exp (scm_to_double (z
)));
9608 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9613 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9615 "Return two exact non-negative integers @var{s} and @var{r}\n"
9616 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9617 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9618 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9621 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9623 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9627 scm_exact_integer_sqrt (k
, &s
, &r
);
9628 return scm_values (scm_list_2 (s
, r
));
9633 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9635 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9637 scm_t_inum kk
= SCM_I_INUM (k
);
9641 if (SCM_LIKELY (kk
> 0))
9646 uu
= (ss
+ kk
/ss
) / 2;
9648 *sp
= SCM_I_MAKINUM (ss
);
9649 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9651 else if (SCM_LIKELY (kk
== 0))
9652 *sp
= *rp
= SCM_INUM0
;
9654 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9655 "exact non-negative integer");
9657 else if (SCM_LIKELY (SCM_BIGP (k
)))
9661 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9662 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9663 "exact non-negative integer");
9666 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9667 scm_remember_upto_here_1 (k
);
9668 *sp
= scm_i_normbig (s
);
9669 *rp
= scm_i_normbig (r
);
9672 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9673 "exact non-negative integer");
9677 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9679 "Return the square root of @var{z}. Of the two possible roots\n"
9680 "(positive and negative), the one with positive real part\n"
9681 "is returned, or if that's zero then a positive imaginary part.\n"
9685 "(sqrt 9.0) @result{} 3.0\n"
9686 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9687 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9688 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9690 #define FUNC_NAME s_scm_sqrt
9692 if (SCM_COMPLEXP (z
))
9694 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9695 && defined SCM_COMPLEX_VALUE
9696 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9698 double re
= SCM_COMPLEX_REAL (z
);
9699 double im
= SCM_COMPLEX_IMAG (z
);
9700 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9701 0.5 * atan2 (im
, re
));
9704 else if (SCM_NUMBERP (z
))
9706 double xx
= scm_to_double (z
);
9708 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9710 return scm_from_double (sqrt (xx
));
9713 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9724 if (scm_install_gmp_memory_functions
)
9725 mp_set_memory_functions (custom_gmp_malloc
,
9729 mpz_init_set_si (z_negative_one
, -1);
9731 /* It may be possible to tune the performance of some algorithms by using
9732 * the following constants to avoid the creation of bignums. Please, before
9733 * using these values, remember the two rules of program optimization:
9734 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9735 scm_c_define ("most-positive-fixnum",
9736 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9737 scm_c_define ("most-negative-fixnum",
9738 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9740 scm_add_feature ("complex");
9741 scm_add_feature ("inexact");
9742 flo0
= scm_from_double (0.0);
9743 flo_log10e
= scm_from_double (M_LOG10E
);
9745 /* determine floating point precision */
9746 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9748 init_dblprec(&scm_dblprec
[i
-2],i
);
9749 init_fx_radix(fx_per_radix
[i
-2],i
);
9752 /* hard code precision for base 10 if the preprocessor tells us to... */
9753 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9756 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9757 #include "libguile/numbers.x"