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 size_t len
= strlen (str
);
5334 void (*freefunc
) (void *, size_t);
5336 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5337 scm_remember_upto_here_1 (n
);
5338 ret
= scm_from_latin1_stringn (str
, len
);
5339 freefunc (str
, len
+ 1);
5342 else if (SCM_FRACTIONP (n
))
5344 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5345 scm_from_locale_string ("/"),
5346 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5348 else if (SCM_INEXACTP (n
))
5350 char num_buf
[FLOBUFLEN
];
5351 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5354 SCM_WRONG_TYPE_ARG (1, n
);
5359 /* These print routines used to be stubbed here so that scm_repl.c
5360 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5363 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5365 char num_buf
[FLOBUFLEN
];
5366 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5371 scm_i_print_double (double val
, SCM port
)
5373 char num_buf
[FLOBUFLEN
];
5374 scm_lfwrite (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5378 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5381 char num_buf
[FLOBUFLEN
];
5382 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5387 scm_i_print_complex (double real
, double imag
, SCM port
)
5389 char num_buf
[FLOBUFLEN
];
5390 scm_lfwrite (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5394 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5397 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5398 scm_display (str
, port
);
5399 scm_remember_upto_here_1 (str
);
5404 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5406 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5407 size_t len
= strlen (str
);
5408 void (*freefunc
) (void *, size_t);
5409 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5410 scm_remember_upto_here_1 (exp
);
5411 scm_lfwrite (str
, len
, port
);
5412 freefunc (str
, len
+ 1);
5415 /*** END nums->strs ***/
5418 /*** STRINGS -> NUMBERS ***/
5420 /* The following functions implement the conversion from strings to numbers.
5421 * The implementation somehow follows the grammar for numbers as it is given
5422 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5423 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5424 * points should be noted about the implementation:
5426 * * Each function keeps a local index variable 'idx' that points at the
5427 * current position within the parsed string. The global index is only
5428 * updated if the function could parse the corresponding syntactic unit
5431 * * Similarly, the functions keep track of indicators of inexactness ('#',
5432 * '.' or exponents) using local variables ('hash_seen', 'x').
5434 * * Sequences of digits are parsed into temporary variables holding fixnums.
5435 * Only if these fixnums would overflow, the result variables are updated
5436 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5437 * the temporary variables holding the fixnums are cleared, and the process
5438 * starts over again. If for example fixnums were able to store five decimal
5439 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5440 * and the result was computed as 12345 * 100000 + 67890. In other words,
5441 * only every five digits two bignum operations were performed.
5443 * Notes on the handling of exactness specifiers:
5445 * When parsing non-real complex numbers, we apply exactness specifiers on
5446 * per-component basis, as is done in PLT Scheme. For complex numbers
5447 * written in rectangular form, exactness specifiers are applied to the
5448 * real and imaginary parts before calling scm_make_rectangular. For
5449 * complex numbers written in polar form, exactness specifiers are applied
5450 * to the magnitude and angle before calling scm_make_polar.
5452 * There are two kinds of exactness specifiers: forced and implicit. A
5453 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5454 * the entire number, and applies to both components of a complex number.
5455 * "#e" causes each component to be made exact, and "#i" causes each
5456 * component to be made inexact. If no forced exactness specifier is
5457 * present, then the exactness of each component is determined
5458 * independently by the presence or absence of a decimal point or hash mark
5459 * within that component. If a decimal point or hash mark is present, the
5460 * component is made inexact, otherwise it is made exact.
5462 * After the exactness specifiers have been applied to each component, they
5463 * are passed to either scm_make_rectangular or scm_make_polar to produce
5464 * the final result. Note that this will result in a real number if the
5465 * imaginary part, magnitude, or angle is an exact 0.
5467 * For example, (string->number "#i5.0+0i") does the equivalent of:
5469 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5472 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5474 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5476 /* Caller is responsible for checking that the return value is in range
5477 for the given radix, which should be <= 36. */
5479 char_decimal_value (scm_t_uint32 c
)
5481 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5482 that's certainly above any valid decimal, so we take advantage of
5483 that to elide some tests. */
5484 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5486 /* If that failed, try extended hexadecimals, then. Only accept ascii
5491 if (c
>= (scm_t_uint32
) 'a')
5492 d
= c
- (scm_t_uint32
)'a' + 10U;
5497 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5498 in base RADIX. Upon success, return the unsigned integer and update
5499 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5501 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5502 unsigned int radix
, enum t_exactness
*p_exactness
)
5504 unsigned int idx
= *p_idx
;
5505 unsigned int hash_seen
= 0;
5506 scm_t_bits shift
= 1;
5508 unsigned int digit_value
;
5511 size_t len
= scm_i_string_length (mem
);
5516 c
= scm_i_string_ref (mem
, idx
);
5517 digit_value
= char_decimal_value (c
);
5518 if (digit_value
>= radix
)
5522 result
= SCM_I_MAKINUM (digit_value
);
5525 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5535 digit_value
= char_decimal_value (c
);
5536 /* This check catches non-decimals in addition to out-of-range
5538 if (digit_value
>= radix
)
5543 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5545 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5547 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5554 shift
= shift
* radix
;
5555 add
= add
* radix
+ digit_value
;
5560 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5562 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5566 *p_exactness
= INEXACT
;
5572 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5573 * covers the parts of the rules that start at a potential point. The value
5574 * of the digits up to the point have been parsed by the caller and are given
5575 * in variable result. The content of *p_exactness indicates, whether a hash
5576 * has already been seen in the digits before the point.
5579 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5582 mem2decimal_from_point (SCM result
, SCM mem
,
5583 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5585 unsigned int idx
= *p_idx
;
5586 enum t_exactness x
= *p_exactness
;
5587 size_t len
= scm_i_string_length (mem
);
5592 if (scm_i_string_ref (mem
, idx
) == '.')
5594 scm_t_bits shift
= 1;
5596 unsigned int digit_value
;
5597 SCM big_shift
= SCM_INUM1
;
5602 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5603 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5608 digit_value
= DIGIT2UINT (c
);
5619 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5621 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5622 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5624 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5632 add
= add
* 10 + digit_value
;
5638 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5639 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5640 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5643 result
= scm_divide (result
, big_shift
);
5645 /* We've seen a decimal point, thus the value is implicitly inexact. */
5657 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5659 switch (scm_i_string_ref (mem
, idx
))
5671 c
= scm_i_string_ref (mem
, idx
);
5679 c
= scm_i_string_ref (mem
, idx
);
5688 c
= scm_i_string_ref (mem
, idx
);
5693 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5697 exponent
= DIGIT2UINT (c
);
5700 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5701 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5704 if (exponent
<= SCM_MAXEXP
)
5705 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5711 if (exponent
> SCM_MAXEXP
)
5713 size_t exp_len
= idx
- start
;
5714 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5715 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5716 scm_out_of_range ("string->number", exp_num
);
5719 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5721 result
= scm_product (result
, e
);
5723 result
= scm_divide (result
, e
);
5725 /* We've seen an exponent, thus the value is implicitly inexact. */
5743 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5746 mem2ureal (SCM mem
, unsigned int *p_idx
,
5747 unsigned int radix
, enum t_exactness forced_x
)
5749 unsigned int idx
= *p_idx
;
5751 size_t len
= scm_i_string_length (mem
);
5753 /* Start off believing that the number will be exact. This changes
5754 to INEXACT if we see a decimal point or a hash. */
5755 enum t_exactness implicit_x
= EXACT
;
5760 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5766 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5768 /* Cobble up the fractional part. We might want to set the
5769 NaN's mantissa from it. */
5771 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
), SCM_INUM0
))
5773 #if SCM_ENABLE_DEPRECATED == 1
5774 scm_c_issue_deprecation_warning
5775 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5785 if (scm_i_string_ref (mem
, idx
) == '.')
5789 else if (idx
+ 1 == len
)
5791 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5794 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5795 p_idx
, &implicit_x
);
5801 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5802 if (scm_is_false (uinteger
))
5807 else if (scm_i_string_ref (mem
, idx
) == '/')
5815 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5816 if (scm_is_false (divisor
))
5819 /* both are int/big here, I assume */
5820 result
= scm_i_make_ratio (uinteger
, divisor
);
5822 else if (radix
== 10)
5824 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5825 if (scm_is_false (result
))
5837 if (SCM_INEXACTP (result
))
5838 return scm_inexact_to_exact (result
);
5842 if (SCM_INEXACTP (result
))
5845 return scm_exact_to_inexact (result
);
5847 if (implicit_x
== INEXACT
)
5849 if (SCM_INEXACTP (result
))
5852 return scm_exact_to_inexact (result
);
5858 /* We should never get here */
5859 scm_syserror ("mem2ureal");
5863 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5866 mem2complex (SCM mem
, unsigned int idx
,
5867 unsigned int radix
, enum t_exactness forced_x
)
5872 size_t len
= scm_i_string_length (mem
);
5877 c
= scm_i_string_ref (mem
, idx
);
5892 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5893 if (scm_is_false (ureal
))
5895 /* input must be either +i or -i */
5900 if (scm_i_string_ref (mem
, idx
) == 'i'
5901 || scm_i_string_ref (mem
, idx
) == 'I')
5907 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5914 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5915 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5920 c
= scm_i_string_ref (mem
, idx
);
5924 /* either +<ureal>i or -<ureal>i */
5931 return scm_make_rectangular (SCM_INUM0
, ureal
);
5934 /* polar input: <real>@<real>. */
5945 c
= scm_i_string_ref (mem
, idx
);
5963 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5964 if (scm_is_false (angle
))
5969 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5970 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5972 result
= scm_make_polar (ureal
, angle
);
5977 /* expecting input matching <real>[+-]<ureal>?i */
5984 int sign
= (c
== '+') ? 1 : -1;
5985 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5987 if (scm_is_false (imag
))
5988 imag
= SCM_I_MAKINUM (sign
);
5989 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5990 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5994 if (scm_i_string_ref (mem
, idx
) != 'i'
5995 && scm_i_string_ref (mem
, idx
) != 'I')
6002 return scm_make_rectangular (ureal
, imag
);
6011 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6013 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6016 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6018 unsigned int idx
= 0;
6019 unsigned int radix
= NO_RADIX
;
6020 enum t_exactness forced_x
= NO_EXACTNESS
;
6021 size_t len
= scm_i_string_length (mem
);
6023 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6024 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6026 switch (scm_i_string_ref (mem
, idx
+ 1))
6029 if (radix
!= NO_RADIX
)
6034 if (radix
!= NO_RADIX
)
6039 if (forced_x
!= NO_EXACTNESS
)
6044 if (forced_x
!= NO_EXACTNESS
)
6049 if (radix
!= NO_RADIX
)
6054 if (radix
!= NO_RADIX
)
6064 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6065 if (radix
== NO_RADIX
)
6066 radix
= default_radix
;
6068 return mem2complex (mem
, idx
, radix
, forced_x
);
6072 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6073 unsigned int default_radix
)
6075 SCM str
= scm_from_locale_stringn (mem
, len
);
6077 return scm_i_string_to_number (str
, default_radix
);
6081 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6082 (SCM string
, SCM radix
),
6083 "Return a number of the maximally precise representation\n"
6084 "expressed by the given @var{string}. @var{radix} must be an\n"
6085 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6086 "is a default radix that may be overridden by an explicit radix\n"
6087 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6088 "supplied, then the default radix is 10. If string is not a\n"
6089 "syntactically valid notation for a number, then\n"
6090 "@code{string->number} returns @code{#f}.")
6091 #define FUNC_NAME s_scm_string_to_number
6095 SCM_VALIDATE_STRING (1, string
);
6097 if (SCM_UNBNDP (radix
))
6100 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6102 answer
= scm_i_string_to_number (string
, base
);
6103 scm_remember_upto_here_1 (string
);
6109 /*** END strs->nums ***/
6112 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6114 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6116 #define FUNC_NAME s_scm_number_p
6118 return scm_from_bool (SCM_NUMBERP (x
));
6122 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6124 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6125 "otherwise. Note that the sets of real, rational and integer\n"
6126 "values form subsets of the set of complex numbers, i. e. the\n"
6127 "predicate will also be fulfilled if @var{x} is a real,\n"
6128 "rational or integer number.")
6129 #define FUNC_NAME s_scm_complex_p
6131 /* all numbers are complex. */
6132 return scm_number_p (x
);
6136 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6138 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6139 "otherwise. Note that the set of integer values forms a subset of\n"
6140 "the set of real numbers, i. e. the predicate will also be\n"
6141 "fulfilled if @var{x} is an integer number.")
6142 #define FUNC_NAME s_scm_real_p
6144 return scm_from_bool
6145 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6149 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6151 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6152 "otherwise. Note that the set of integer values forms a subset of\n"
6153 "the set of rational numbers, i. e. the predicate will also be\n"
6154 "fulfilled if @var{x} is an integer number.")
6155 #define FUNC_NAME s_scm_rational_p
6157 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6159 else if (SCM_REALP (x
))
6160 /* due to their limited precision, finite floating point numbers are
6161 rational as well. (finite means neither infinity nor a NaN) */
6162 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6168 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6170 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6172 #define FUNC_NAME s_scm_integer_p
6174 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6176 else if (SCM_REALP (x
))
6178 double val
= SCM_REAL_VALUE (x
);
6179 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6187 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6188 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6189 (SCM x
, SCM y
, SCM rest
),
6190 "Return @code{#t} if all parameters are numerically equal.")
6191 #define FUNC_NAME s_scm_i_num_eq_p
6193 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6195 while (!scm_is_null (rest
))
6197 if (scm_is_false (scm_num_eq_p (x
, y
)))
6201 rest
= scm_cdr (rest
);
6203 return scm_num_eq_p (x
, y
);
6207 scm_num_eq_p (SCM x
, SCM y
)
6210 if (SCM_I_INUMP (x
))
6212 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6213 if (SCM_I_INUMP (y
))
6215 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6216 return scm_from_bool (xx
== yy
);
6218 else if (SCM_BIGP (y
))
6220 else if (SCM_REALP (y
))
6222 /* On a 32-bit system an inum fits a double, we can cast the inum
6223 to a double and compare.
6225 But on a 64-bit system an inum is bigger than a double and
6226 casting it to a double (call that dxx) will round. dxx is at
6227 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6228 an integer and fits a long. So we cast yy to a long and
6229 compare with plain xx.
6231 An alternative (for any size system actually) would be to check
6232 yy is an integer (with floor) and is in range of an inum
6233 (compare against appropriate powers of 2) then test
6234 xx==(scm_t_signed_bits)yy. It's just a matter of which
6235 casts/comparisons might be fastest or easiest for the cpu. */
6237 double yy
= SCM_REAL_VALUE (y
);
6238 return scm_from_bool ((double) xx
== yy
6239 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6240 || xx
== (scm_t_signed_bits
) yy
));
6242 else if (SCM_COMPLEXP (y
))
6243 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6244 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6245 else if (SCM_FRACTIONP (y
))
6248 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6250 else if (SCM_BIGP (x
))
6252 if (SCM_I_INUMP (y
))
6254 else if (SCM_BIGP (y
))
6256 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6257 scm_remember_upto_here_2 (x
, y
);
6258 return scm_from_bool (0 == cmp
);
6260 else if (SCM_REALP (y
))
6263 if (isnan (SCM_REAL_VALUE (y
)))
6265 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6266 scm_remember_upto_here_1 (x
);
6267 return scm_from_bool (0 == cmp
);
6269 else if (SCM_COMPLEXP (y
))
6272 if (0.0 != SCM_COMPLEX_IMAG (y
))
6274 if (isnan (SCM_COMPLEX_REAL (y
)))
6276 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6277 scm_remember_upto_here_1 (x
);
6278 return scm_from_bool (0 == cmp
);
6280 else if (SCM_FRACTIONP (y
))
6283 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6285 else if (SCM_REALP (x
))
6287 double xx
= SCM_REAL_VALUE (x
);
6288 if (SCM_I_INUMP (y
))
6290 /* see comments with inum/real above */
6291 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6292 return scm_from_bool (xx
== (double) yy
6293 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6294 || (scm_t_signed_bits
) xx
== yy
));
6296 else if (SCM_BIGP (y
))
6299 if (isnan (SCM_REAL_VALUE (x
)))
6301 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6302 scm_remember_upto_here_1 (y
);
6303 return scm_from_bool (0 == cmp
);
6305 else if (SCM_REALP (y
))
6306 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6307 else if (SCM_COMPLEXP (y
))
6308 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6309 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6310 else if (SCM_FRACTIONP (y
))
6312 double xx
= SCM_REAL_VALUE (x
);
6316 return scm_from_bool (xx
< 0.0);
6317 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6321 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6323 else if (SCM_COMPLEXP (x
))
6325 if (SCM_I_INUMP (y
))
6326 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6327 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6328 else if (SCM_BIGP (y
))
6331 if (0.0 != SCM_COMPLEX_IMAG (x
))
6333 if (isnan (SCM_COMPLEX_REAL (x
)))
6335 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6336 scm_remember_upto_here_1 (y
);
6337 return scm_from_bool (0 == cmp
);
6339 else if (SCM_REALP (y
))
6340 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6341 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6342 else if (SCM_COMPLEXP (y
))
6343 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6344 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6345 else if (SCM_FRACTIONP (y
))
6348 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6350 xx
= SCM_COMPLEX_REAL (x
);
6354 return scm_from_bool (xx
< 0.0);
6355 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6359 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6361 else if (SCM_FRACTIONP (x
))
6363 if (SCM_I_INUMP (y
))
6365 else if (SCM_BIGP (y
))
6367 else if (SCM_REALP (y
))
6369 double yy
= SCM_REAL_VALUE (y
);
6373 return scm_from_bool (0.0 < yy
);
6374 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6377 else if (SCM_COMPLEXP (y
))
6380 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6382 yy
= SCM_COMPLEX_REAL (y
);
6386 return scm_from_bool (0.0 < yy
);
6387 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6390 else if (SCM_FRACTIONP (y
))
6391 return scm_i_fraction_equalp (x
, y
);
6393 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
, s_scm_i_num_eq_p
);
6396 SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
, s_scm_i_num_eq_p
);
6400 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6401 done are good for inums, but for bignums an answer can almost always be
6402 had by just examining a few high bits of the operands, as done by GMP in
6403 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6404 of the float exponent to take into account. */
6406 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6407 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6408 (SCM x
, SCM y
, SCM rest
),
6409 "Return @code{#t} if the list of parameters is monotonically\n"
6411 #define FUNC_NAME s_scm_i_num_less_p
6413 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6415 while (!scm_is_null (rest
))
6417 if (scm_is_false (scm_less_p (x
, y
)))
6421 rest
= scm_cdr (rest
);
6423 return scm_less_p (x
, y
);
6427 scm_less_p (SCM x
, SCM y
)
6430 if (SCM_I_INUMP (x
))
6432 scm_t_inum xx
= SCM_I_INUM (x
);
6433 if (SCM_I_INUMP (y
))
6435 scm_t_inum yy
= SCM_I_INUM (y
);
6436 return scm_from_bool (xx
< yy
);
6438 else if (SCM_BIGP (y
))
6440 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6441 scm_remember_upto_here_1 (y
);
6442 return scm_from_bool (sgn
> 0);
6444 else if (SCM_REALP (y
))
6445 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6446 else if (SCM_FRACTIONP (y
))
6448 /* "x < a/b" becomes "x*b < a" */
6450 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6451 y
= SCM_FRACTION_NUMERATOR (y
);
6455 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6457 else if (SCM_BIGP (x
))
6459 if (SCM_I_INUMP (y
))
6461 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6462 scm_remember_upto_here_1 (x
);
6463 return scm_from_bool (sgn
< 0);
6465 else if (SCM_BIGP (y
))
6467 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6468 scm_remember_upto_here_2 (x
, y
);
6469 return scm_from_bool (cmp
< 0);
6471 else if (SCM_REALP (y
))
6474 if (isnan (SCM_REAL_VALUE (y
)))
6476 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6477 scm_remember_upto_here_1 (x
);
6478 return scm_from_bool (cmp
< 0);
6480 else if (SCM_FRACTIONP (y
))
6483 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6485 else if (SCM_REALP (x
))
6487 if (SCM_I_INUMP (y
))
6488 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6489 else if (SCM_BIGP (y
))
6492 if (isnan (SCM_REAL_VALUE (x
)))
6494 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6495 scm_remember_upto_here_1 (y
);
6496 return scm_from_bool (cmp
> 0);
6498 else if (SCM_REALP (y
))
6499 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6500 else if (SCM_FRACTIONP (y
))
6502 double xx
= SCM_REAL_VALUE (x
);
6506 return scm_from_bool (xx
< 0.0);
6507 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6511 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6513 else if (SCM_FRACTIONP (x
))
6515 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6517 /* "a/b < y" becomes "a < y*b" */
6518 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6519 x
= SCM_FRACTION_NUMERATOR (x
);
6522 else if (SCM_REALP (y
))
6524 double yy
= SCM_REAL_VALUE (y
);
6528 return scm_from_bool (0.0 < yy
);
6529 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6532 else if (SCM_FRACTIONP (y
))
6534 /* "a/b < c/d" becomes "a*d < c*b" */
6535 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6536 SCM_FRACTION_DENOMINATOR (y
));
6537 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6538 SCM_FRACTION_DENOMINATOR (x
));
6544 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
, s_scm_i_num_less_p
);
6547 SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
, s_scm_i_num_less_p
);
6551 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6552 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6553 (SCM x
, SCM y
, SCM rest
),
6554 "Return @code{#t} if the list of parameters is monotonically\n"
6556 #define FUNC_NAME s_scm_i_num_gr_p
6558 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6560 while (!scm_is_null (rest
))
6562 if (scm_is_false (scm_gr_p (x
, y
)))
6566 rest
= scm_cdr (rest
);
6568 return scm_gr_p (x
, y
);
6571 #define FUNC_NAME s_scm_i_num_gr_p
6573 scm_gr_p (SCM x
, SCM y
)
6575 if (!SCM_NUMBERP (x
))
6576 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6577 else if (!SCM_NUMBERP (y
))
6578 SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6580 return scm_less_p (y
, x
);
6585 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6586 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6587 (SCM x
, SCM y
, SCM rest
),
6588 "Return @code{#t} if the list of parameters is monotonically\n"
6590 #define FUNC_NAME s_scm_i_num_leq_p
6592 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6594 while (!scm_is_null (rest
))
6596 if (scm_is_false (scm_leq_p (x
, y
)))
6600 rest
= scm_cdr (rest
);
6602 return scm_leq_p (x
, y
);
6605 #define FUNC_NAME s_scm_i_num_leq_p
6607 scm_leq_p (SCM x
, SCM y
)
6609 if (!SCM_NUMBERP (x
))
6610 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6611 else if (!SCM_NUMBERP (y
))
6612 SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6613 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6616 return scm_not (scm_less_p (y
, x
));
6621 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6622 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6623 (SCM x
, SCM y
, SCM rest
),
6624 "Return @code{#t} if the list of parameters is monotonically\n"
6626 #define FUNC_NAME s_scm_i_num_geq_p
6628 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6630 while (!scm_is_null (rest
))
6632 if (scm_is_false (scm_geq_p (x
, y
)))
6636 rest
= scm_cdr (rest
);
6638 return scm_geq_p (x
, y
);
6641 #define FUNC_NAME s_scm_i_num_geq_p
6643 scm_geq_p (SCM x
, SCM y
)
6645 if (!SCM_NUMBERP (x
))
6646 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6647 else if (!SCM_NUMBERP (y
))
6648 SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6649 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6652 return scm_not (scm_less_p (x
, y
));
6657 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6659 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6661 #define FUNC_NAME s_scm_zero_p
6663 if (SCM_I_INUMP (z
))
6664 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6665 else if (SCM_BIGP (z
))
6667 else if (SCM_REALP (z
))
6668 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6669 else if (SCM_COMPLEXP (z
))
6670 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6671 && SCM_COMPLEX_IMAG (z
) == 0.0);
6672 else if (SCM_FRACTIONP (z
))
6675 SCM_WTA_DISPATCH_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6680 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6682 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6684 #define FUNC_NAME s_scm_positive_p
6686 if (SCM_I_INUMP (x
))
6687 return scm_from_bool (SCM_I_INUM (x
) > 0);
6688 else if (SCM_BIGP (x
))
6690 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6691 scm_remember_upto_here_1 (x
);
6692 return scm_from_bool (sgn
> 0);
6694 else if (SCM_REALP (x
))
6695 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6696 else if (SCM_FRACTIONP (x
))
6697 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6699 SCM_WTA_DISPATCH_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6704 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6706 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6708 #define FUNC_NAME s_scm_negative_p
6710 if (SCM_I_INUMP (x
))
6711 return scm_from_bool (SCM_I_INUM (x
) < 0);
6712 else if (SCM_BIGP (x
))
6714 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6715 scm_remember_upto_here_1 (x
);
6716 return scm_from_bool (sgn
< 0);
6718 else if (SCM_REALP (x
))
6719 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6720 else if (SCM_FRACTIONP (x
))
6721 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6723 SCM_WTA_DISPATCH_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6728 /* scm_min and scm_max return an inexact when either argument is inexact, as
6729 required by r5rs. On that basis, for exact/inexact combinations the
6730 exact is converted to inexact to compare and possibly return. This is
6731 unlike scm_less_p above which takes some trouble to preserve all bits in
6732 its test, such trouble is not required for min and max. */
6734 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6735 (SCM x
, SCM y
, SCM rest
),
6736 "Return the maximum of all parameter values.")
6737 #define FUNC_NAME s_scm_i_max
6739 while (!scm_is_null (rest
))
6740 { x
= scm_max (x
, y
);
6742 rest
= scm_cdr (rest
);
6744 return scm_max (x
, y
);
6748 #define s_max s_scm_i_max
6749 #define g_max g_scm_i_max
6752 scm_max (SCM x
, SCM y
)
6757 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
6758 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6761 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
6764 if (SCM_I_INUMP (x
))
6766 scm_t_inum xx
= SCM_I_INUM (x
);
6767 if (SCM_I_INUMP (y
))
6769 scm_t_inum yy
= SCM_I_INUM (y
);
6770 return (xx
< yy
) ? y
: x
;
6772 else if (SCM_BIGP (y
))
6774 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6775 scm_remember_upto_here_1 (y
);
6776 return (sgn
< 0) ? x
: y
;
6778 else if (SCM_REALP (y
))
6781 double yyd
= SCM_REAL_VALUE (y
);
6784 return scm_from_double (xxd
);
6785 /* If y is a NaN, then "==" is false and we return the NaN */
6786 else if (SCM_LIKELY (!(xxd
== yyd
)))
6788 /* Handle signed zeroes properly */
6794 else if (SCM_FRACTIONP (y
))
6797 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6800 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6802 else if (SCM_BIGP (x
))
6804 if (SCM_I_INUMP (y
))
6806 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6807 scm_remember_upto_here_1 (x
);
6808 return (sgn
< 0) ? y
: x
;
6810 else if (SCM_BIGP (y
))
6812 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6813 scm_remember_upto_here_2 (x
, y
);
6814 return (cmp
> 0) ? x
: y
;
6816 else if (SCM_REALP (y
))
6818 /* if y==NaN then xx>yy is false, so we return the NaN y */
6821 xx
= scm_i_big2dbl (x
);
6822 yy
= SCM_REAL_VALUE (y
);
6823 return (xx
> yy
? scm_from_double (xx
) : y
);
6825 else if (SCM_FRACTIONP (y
))
6830 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6832 else if (SCM_REALP (x
))
6834 if (SCM_I_INUMP (y
))
6836 scm_t_inum yy
= SCM_I_INUM (y
);
6837 double xxd
= SCM_REAL_VALUE (x
);
6841 return scm_from_double (yyd
);
6842 /* If x is a NaN, then "==" is false and we return the NaN */
6843 else if (SCM_LIKELY (!(xxd
== yyd
)))
6845 /* Handle signed zeroes properly */
6851 else if (SCM_BIGP (y
))
6856 else if (SCM_REALP (y
))
6858 double xx
= SCM_REAL_VALUE (x
);
6859 double yy
= SCM_REAL_VALUE (y
);
6861 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6864 else if (SCM_LIKELY (xx
< yy
))
6866 /* If neither (xx > yy) nor (xx < yy), then
6867 either they're equal or one is a NaN */
6868 else if (SCM_UNLIKELY (isnan (xx
)))
6869 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6870 else if (SCM_UNLIKELY (isnan (yy
)))
6871 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6872 /* xx == yy, but handle signed zeroes properly */
6873 else if (double_is_non_negative_zero (yy
))
6878 else if (SCM_FRACTIONP (y
))
6880 double yy
= scm_i_fraction2double (y
);
6881 double xx
= SCM_REAL_VALUE (x
);
6882 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6885 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6887 else if (SCM_FRACTIONP (x
))
6889 if (SCM_I_INUMP (y
))
6893 else if (SCM_BIGP (y
))
6897 else if (SCM_REALP (y
))
6899 double xx
= scm_i_fraction2double (x
);
6900 /* if y==NaN then ">" is false, so we return the NaN y */
6901 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6903 else if (SCM_FRACTIONP (y
))
6908 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6911 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6915 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6916 (SCM x
, SCM y
, SCM rest
),
6917 "Return the minimum of all parameter values.")
6918 #define FUNC_NAME s_scm_i_min
6920 while (!scm_is_null (rest
))
6921 { x
= scm_min (x
, y
);
6923 rest
= scm_cdr (rest
);
6925 return scm_min (x
, y
);
6929 #define s_min s_scm_i_min
6930 #define g_min g_scm_i_min
6933 scm_min (SCM x
, SCM y
)
6938 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
6939 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6942 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
6945 if (SCM_I_INUMP (x
))
6947 scm_t_inum xx
= SCM_I_INUM (x
);
6948 if (SCM_I_INUMP (y
))
6950 scm_t_inum yy
= SCM_I_INUM (y
);
6951 return (xx
< yy
) ? x
: y
;
6953 else if (SCM_BIGP (y
))
6955 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6956 scm_remember_upto_here_1 (y
);
6957 return (sgn
< 0) ? y
: x
;
6959 else if (SCM_REALP (y
))
6962 /* if y==NaN then "<" is false and we return NaN */
6963 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6965 else if (SCM_FRACTIONP (y
))
6968 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6971 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6973 else if (SCM_BIGP (x
))
6975 if (SCM_I_INUMP (y
))
6977 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6978 scm_remember_upto_here_1 (x
);
6979 return (sgn
< 0) ? x
: y
;
6981 else if (SCM_BIGP (y
))
6983 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6984 scm_remember_upto_here_2 (x
, y
);
6985 return (cmp
> 0) ? y
: x
;
6987 else if (SCM_REALP (y
))
6989 /* if y==NaN then xx<yy is false, so we return the NaN y */
6992 xx
= scm_i_big2dbl (x
);
6993 yy
= SCM_REAL_VALUE (y
);
6994 return (xx
< yy
? scm_from_double (xx
) : y
);
6996 else if (SCM_FRACTIONP (y
))
7001 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7003 else if (SCM_REALP (x
))
7005 if (SCM_I_INUMP (y
))
7007 double z
= SCM_I_INUM (y
);
7008 /* if x==NaN then "<" is false and we return NaN */
7009 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7011 else if (SCM_BIGP (y
))
7016 else if (SCM_REALP (y
))
7018 double xx
= SCM_REAL_VALUE (x
);
7019 double yy
= SCM_REAL_VALUE (y
);
7021 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7024 else if (SCM_LIKELY (xx
> yy
))
7026 /* If neither (xx < yy) nor (xx > yy), then
7027 either they're equal or one is a NaN */
7028 else if (SCM_UNLIKELY (isnan (xx
)))
7029 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7030 else if (SCM_UNLIKELY (isnan (yy
)))
7031 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7032 /* xx == yy, but handle signed zeroes properly */
7033 else if (double_is_non_negative_zero (xx
))
7038 else if (SCM_FRACTIONP (y
))
7040 double yy
= scm_i_fraction2double (y
);
7041 double xx
= SCM_REAL_VALUE (x
);
7042 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7045 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7047 else if (SCM_FRACTIONP (x
))
7049 if (SCM_I_INUMP (y
))
7053 else if (SCM_BIGP (y
))
7057 else if (SCM_REALP (y
))
7059 double xx
= scm_i_fraction2double (x
);
7060 /* if y==NaN then "<" is false, so we return the NaN y */
7061 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7063 else if (SCM_FRACTIONP (y
))
7068 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7071 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7075 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7076 (SCM x
, SCM y
, SCM rest
),
7077 "Return the sum of all parameter values. Return 0 if called without\n"
7079 #define FUNC_NAME s_scm_i_sum
7081 while (!scm_is_null (rest
))
7082 { x
= scm_sum (x
, y
);
7084 rest
= scm_cdr (rest
);
7086 return scm_sum (x
, y
);
7090 #define s_sum s_scm_i_sum
7091 #define g_sum g_scm_i_sum
7094 scm_sum (SCM x
, SCM y
)
7096 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7098 if (SCM_NUMBERP (x
)) return x
;
7099 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7100 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7103 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7105 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7107 scm_t_inum xx
= SCM_I_INUM (x
);
7108 scm_t_inum yy
= SCM_I_INUM (y
);
7109 scm_t_inum z
= xx
+ yy
;
7110 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7112 else if (SCM_BIGP (y
))
7117 else if (SCM_REALP (y
))
7119 scm_t_inum xx
= SCM_I_INUM (x
);
7120 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7122 else if (SCM_COMPLEXP (y
))
7124 scm_t_inum xx
= SCM_I_INUM (x
);
7125 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7126 SCM_COMPLEX_IMAG (y
));
7128 else if (SCM_FRACTIONP (y
))
7129 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7130 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7131 SCM_FRACTION_DENOMINATOR (y
));
7133 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7134 } else if (SCM_BIGP (x
))
7136 if (SCM_I_INUMP (y
))
7141 inum
= SCM_I_INUM (y
);
7144 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7147 SCM result
= scm_i_mkbig ();
7148 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7149 scm_remember_upto_here_1 (x
);
7150 /* we know the result will have to be a bignum */
7153 return scm_i_normbig (result
);
7157 SCM result
= scm_i_mkbig ();
7158 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7159 scm_remember_upto_here_1 (x
);
7160 /* we know the result will have to be a bignum */
7163 return scm_i_normbig (result
);
7166 else if (SCM_BIGP (y
))
7168 SCM result
= scm_i_mkbig ();
7169 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7170 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7171 mpz_add (SCM_I_BIG_MPZ (result
),
7174 scm_remember_upto_here_2 (x
, y
);
7175 /* we know the result will have to be a bignum */
7178 return scm_i_normbig (result
);
7180 else if (SCM_REALP (y
))
7182 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7183 scm_remember_upto_here_1 (x
);
7184 return scm_from_double (result
);
7186 else if (SCM_COMPLEXP (y
))
7188 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7189 + SCM_COMPLEX_REAL (y
));
7190 scm_remember_upto_here_1 (x
);
7191 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7193 else if (SCM_FRACTIONP (y
))
7194 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7195 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7196 SCM_FRACTION_DENOMINATOR (y
));
7198 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7200 else if (SCM_REALP (x
))
7202 if (SCM_I_INUMP (y
))
7203 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7204 else if (SCM_BIGP (y
))
7206 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7207 scm_remember_upto_here_1 (y
);
7208 return scm_from_double (result
);
7210 else if (SCM_REALP (y
))
7211 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7212 else if (SCM_COMPLEXP (y
))
7213 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7214 SCM_COMPLEX_IMAG (y
));
7215 else if (SCM_FRACTIONP (y
))
7216 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7218 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7220 else if (SCM_COMPLEXP (x
))
7222 if (SCM_I_INUMP (y
))
7223 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7224 SCM_COMPLEX_IMAG (x
));
7225 else if (SCM_BIGP (y
))
7227 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7228 + SCM_COMPLEX_REAL (x
));
7229 scm_remember_upto_here_1 (y
);
7230 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7232 else if (SCM_REALP (y
))
7233 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7234 SCM_COMPLEX_IMAG (x
));
7235 else if (SCM_COMPLEXP (y
))
7236 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7237 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7238 else if (SCM_FRACTIONP (y
))
7239 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7240 SCM_COMPLEX_IMAG (x
));
7242 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7244 else if (SCM_FRACTIONP (x
))
7246 if (SCM_I_INUMP (y
))
7247 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7248 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7249 SCM_FRACTION_DENOMINATOR (x
));
7250 else if (SCM_BIGP (y
))
7251 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7252 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7253 SCM_FRACTION_DENOMINATOR (x
));
7254 else if (SCM_REALP (y
))
7255 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7256 else if (SCM_COMPLEXP (y
))
7257 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7258 SCM_COMPLEX_IMAG (y
));
7259 else if (SCM_FRACTIONP (y
))
7260 /* a/b + c/d = (ad + bc) / bd */
7261 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7262 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7263 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7265 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7268 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7272 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7274 "Return @math{@var{x}+1}.")
7275 #define FUNC_NAME s_scm_oneplus
7277 return scm_sum (x
, SCM_INUM1
);
7282 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7283 (SCM x
, SCM y
, SCM rest
),
7284 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7285 "the sum of all but the first argument are subtracted from the first\n"
7287 #define FUNC_NAME s_scm_i_difference
7289 while (!scm_is_null (rest
))
7290 { x
= scm_difference (x
, y
);
7292 rest
= scm_cdr (rest
);
7294 return scm_difference (x
, y
);
7298 #define s_difference s_scm_i_difference
7299 #define g_difference g_scm_i_difference
7302 scm_difference (SCM x
, SCM y
)
7303 #define FUNC_NAME s_difference
7305 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7308 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
7310 if (SCM_I_INUMP (x
))
7312 scm_t_inum xx
= -SCM_I_INUM (x
);
7313 if (SCM_FIXABLE (xx
))
7314 return SCM_I_MAKINUM (xx
);
7316 return scm_i_inum2big (xx
);
7318 else if (SCM_BIGP (x
))
7319 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7320 bignum, but negating that gives a fixnum. */
7321 return scm_i_normbig (scm_i_clonebig (x
, 0));
7322 else if (SCM_REALP (x
))
7323 return scm_from_double (-SCM_REAL_VALUE (x
));
7324 else if (SCM_COMPLEXP (x
))
7325 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7326 -SCM_COMPLEX_IMAG (x
));
7327 else if (SCM_FRACTIONP (x
))
7328 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7329 SCM_FRACTION_DENOMINATOR (x
));
7331 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7334 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7336 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7338 scm_t_inum xx
= SCM_I_INUM (x
);
7339 scm_t_inum yy
= SCM_I_INUM (y
);
7340 scm_t_inum z
= xx
- yy
;
7341 if (SCM_FIXABLE (z
))
7342 return SCM_I_MAKINUM (z
);
7344 return scm_i_inum2big (z
);
7346 else if (SCM_BIGP (y
))
7348 /* inum-x - big-y */
7349 scm_t_inum xx
= SCM_I_INUM (x
);
7353 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7354 bignum, but negating that gives a fixnum. */
7355 return scm_i_normbig (scm_i_clonebig (y
, 0));
7359 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7360 SCM result
= scm_i_mkbig ();
7363 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7366 /* x - y == -(y + -x) */
7367 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7368 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7370 scm_remember_upto_here_1 (y
);
7372 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7373 /* we know the result will have to be a bignum */
7376 return scm_i_normbig (result
);
7379 else if (SCM_REALP (y
))
7381 scm_t_inum xx
= SCM_I_INUM (x
);
7384 * We need to handle x == exact 0
7385 * specially because R6RS states that:
7386 * (- 0.0) ==> -0.0 and
7387 * (- 0.0 0.0) ==> 0.0
7388 * and the scheme compiler changes
7389 * (- 0.0) into (- 0 0.0)
7390 * So we need to treat (- 0 0.0) like (- 0.0).
7391 * At the C level, (-x) is different than (0.0 - x).
7392 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7395 return scm_from_double (- SCM_REAL_VALUE (y
));
7397 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7399 else if (SCM_COMPLEXP (y
))
7401 scm_t_inum xx
= SCM_I_INUM (x
);
7403 /* We need to handle x == exact 0 specially.
7404 See the comment above (for SCM_REALP (y)) */
7406 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7407 - SCM_COMPLEX_IMAG (y
));
7409 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7410 - SCM_COMPLEX_IMAG (y
));
7412 else if (SCM_FRACTIONP (y
))
7413 /* a - b/c = (ac - b) / c */
7414 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7415 SCM_FRACTION_NUMERATOR (y
)),
7416 SCM_FRACTION_DENOMINATOR (y
));
7418 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7420 else if (SCM_BIGP (x
))
7422 if (SCM_I_INUMP (y
))
7424 /* big-x - inum-y */
7425 scm_t_inum yy
= SCM_I_INUM (y
);
7426 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7428 scm_remember_upto_here_1 (x
);
7430 return (SCM_FIXABLE (-yy
) ?
7431 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7434 SCM result
= scm_i_mkbig ();
7437 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7439 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7440 scm_remember_upto_here_1 (x
);
7442 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7443 /* we know the result will have to be a bignum */
7446 return scm_i_normbig (result
);
7449 else if (SCM_BIGP (y
))
7451 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7452 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7453 SCM result
= scm_i_mkbig ();
7454 mpz_sub (SCM_I_BIG_MPZ (result
),
7457 scm_remember_upto_here_2 (x
, y
);
7458 /* we know the result will have to be a bignum */
7459 if ((sgn_x
== 1) && (sgn_y
== -1))
7461 if ((sgn_x
== -1) && (sgn_y
== 1))
7463 return scm_i_normbig (result
);
7465 else if (SCM_REALP (y
))
7467 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7468 scm_remember_upto_here_1 (x
);
7469 return scm_from_double (result
);
7471 else if (SCM_COMPLEXP (y
))
7473 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7474 - SCM_COMPLEX_REAL (y
));
7475 scm_remember_upto_here_1 (x
);
7476 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7478 else if (SCM_FRACTIONP (y
))
7479 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7480 SCM_FRACTION_NUMERATOR (y
)),
7481 SCM_FRACTION_DENOMINATOR (y
));
7482 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7484 else if (SCM_REALP (x
))
7486 if (SCM_I_INUMP (y
))
7487 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7488 else if (SCM_BIGP (y
))
7490 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7491 scm_remember_upto_here_1 (x
);
7492 return scm_from_double (result
);
7494 else if (SCM_REALP (y
))
7495 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7496 else if (SCM_COMPLEXP (y
))
7497 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7498 -SCM_COMPLEX_IMAG (y
));
7499 else if (SCM_FRACTIONP (y
))
7500 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7502 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7504 else if (SCM_COMPLEXP (x
))
7506 if (SCM_I_INUMP (y
))
7507 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7508 SCM_COMPLEX_IMAG (x
));
7509 else if (SCM_BIGP (y
))
7511 double real_part
= (SCM_COMPLEX_REAL (x
)
7512 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7513 scm_remember_upto_here_1 (x
);
7514 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7516 else if (SCM_REALP (y
))
7517 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7518 SCM_COMPLEX_IMAG (x
));
7519 else if (SCM_COMPLEXP (y
))
7520 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7521 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7522 else if (SCM_FRACTIONP (y
))
7523 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7524 SCM_COMPLEX_IMAG (x
));
7526 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7528 else if (SCM_FRACTIONP (x
))
7530 if (SCM_I_INUMP (y
))
7531 /* a/b - c = (a - cb) / b */
7532 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7533 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7534 SCM_FRACTION_DENOMINATOR (x
));
7535 else if (SCM_BIGP (y
))
7536 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7537 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7538 SCM_FRACTION_DENOMINATOR (x
));
7539 else if (SCM_REALP (y
))
7540 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7541 else if (SCM_COMPLEXP (y
))
7542 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7543 -SCM_COMPLEX_IMAG (y
));
7544 else if (SCM_FRACTIONP (y
))
7545 /* a/b - c/d = (ad - bc) / bd */
7546 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7547 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7548 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7550 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7553 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7558 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7560 "Return @math{@var{x}-1}.")
7561 #define FUNC_NAME s_scm_oneminus
7563 return scm_difference (x
, SCM_INUM1
);
7568 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7569 (SCM x
, SCM y
, SCM rest
),
7570 "Return the product of all arguments. If called without arguments,\n"
7572 #define FUNC_NAME s_scm_i_product
7574 while (!scm_is_null (rest
))
7575 { x
= scm_product (x
, y
);
7577 rest
= scm_cdr (rest
);
7579 return scm_product (x
, y
);
7583 #define s_product s_scm_i_product
7584 #define g_product g_scm_i_product
7587 scm_product (SCM x
, SCM y
)
7589 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7592 return SCM_I_MAKINUM (1L);
7593 else if (SCM_NUMBERP (x
))
7596 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
7599 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7604 xx
= SCM_I_INUM (x
);
7609 /* exact1 is the universal multiplicative identity */
7613 /* exact0 times a fixnum is exact0: optimize this case */
7614 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7616 /* if the other argument is inexact, the result is inexact,
7617 and we must do the multiplication in order to handle
7618 infinities and NaNs properly. */
7619 else if (SCM_REALP (y
))
7620 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7621 else if (SCM_COMPLEXP (y
))
7622 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7623 0.0 * SCM_COMPLEX_IMAG (y
));
7624 /* we've already handled inexact numbers,
7625 so y must be exact, and we return exact0 */
7626 else if (SCM_NUMP (y
))
7629 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7633 * This case is important for more than just optimization.
7634 * It handles the case of negating
7635 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7636 * which is a bignum that must be changed back into a fixnum.
7637 * Failure to do so will cause the following to return #f:
7638 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7640 return scm_difference(y
, SCM_UNDEFINED
);
7644 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7646 scm_t_inum yy
= SCM_I_INUM (y
);
7647 scm_t_inum kk
= xx
* yy
;
7648 SCM k
= SCM_I_MAKINUM (kk
);
7649 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7653 SCM result
= scm_i_inum2big (xx
);
7654 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7655 return scm_i_normbig (result
);
7658 else if (SCM_BIGP (y
))
7660 SCM result
= scm_i_mkbig ();
7661 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7662 scm_remember_upto_here_1 (y
);
7665 else if (SCM_REALP (y
))
7666 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7667 else if (SCM_COMPLEXP (y
))
7668 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7669 xx
* SCM_COMPLEX_IMAG (y
));
7670 else if (SCM_FRACTIONP (y
))
7671 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7672 SCM_FRACTION_DENOMINATOR (y
));
7674 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7676 else if (SCM_BIGP (x
))
7678 if (SCM_I_INUMP (y
))
7683 else if (SCM_BIGP (y
))
7685 SCM result
= scm_i_mkbig ();
7686 mpz_mul (SCM_I_BIG_MPZ (result
),
7689 scm_remember_upto_here_2 (x
, y
);
7692 else if (SCM_REALP (y
))
7694 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7695 scm_remember_upto_here_1 (x
);
7696 return scm_from_double (result
);
7698 else if (SCM_COMPLEXP (y
))
7700 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7701 scm_remember_upto_here_1 (x
);
7702 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7703 z
* SCM_COMPLEX_IMAG (y
));
7705 else if (SCM_FRACTIONP (y
))
7706 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7707 SCM_FRACTION_DENOMINATOR (y
));
7709 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7711 else if (SCM_REALP (x
))
7713 if (SCM_I_INUMP (y
))
7718 else if (SCM_BIGP (y
))
7720 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7721 scm_remember_upto_here_1 (y
);
7722 return scm_from_double (result
);
7724 else if (SCM_REALP (y
))
7725 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7726 else if (SCM_COMPLEXP (y
))
7727 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7728 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7729 else if (SCM_FRACTIONP (y
))
7730 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7732 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7734 else if (SCM_COMPLEXP (x
))
7736 if (SCM_I_INUMP (y
))
7741 else if (SCM_BIGP (y
))
7743 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7744 scm_remember_upto_here_1 (y
);
7745 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7746 z
* SCM_COMPLEX_IMAG (x
));
7748 else if (SCM_REALP (y
))
7749 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7750 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7751 else if (SCM_COMPLEXP (y
))
7753 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7754 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7755 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7756 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7758 else if (SCM_FRACTIONP (y
))
7760 double yy
= scm_i_fraction2double (y
);
7761 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7762 yy
* SCM_COMPLEX_IMAG (x
));
7765 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7767 else if (SCM_FRACTIONP (x
))
7769 if (SCM_I_INUMP (y
))
7770 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7771 SCM_FRACTION_DENOMINATOR (x
));
7772 else if (SCM_BIGP (y
))
7773 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7774 SCM_FRACTION_DENOMINATOR (x
));
7775 else if (SCM_REALP (y
))
7776 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7777 else if (SCM_COMPLEXP (y
))
7779 double xx
= scm_i_fraction2double (x
);
7780 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7781 xx
* SCM_COMPLEX_IMAG (y
));
7783 else if (SCM_FRACTIONP (y
))
7784 /* a/b * c/d = ac / bd */
7785 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7786 SCM_FRACTION_NUMERATOR (y
)),
7787 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7788 SCM_FRACTION_DENOMINATOR (y
)));
7790 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7793 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7796 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7797 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7798 #define ALLOW_DIVIDE_BY_ZERO
7799 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7802 /* The code below for complex division is adapted from the GNU
7803 libstdc++, which adapted it from f2c's libF77, and is subject to
7806 /****************************************************************
7807 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7809 Permission to use, copy, modify, and distribute this software
7810 and its documentation for any purpose and without fee is hereby
7811 granted, provided that the above copyright notice appear in all
7812 copies and that both that the copyright notice and this
7813 permission notice and warranty disclaimer appear in supporting
7814 documentation, and that the names of AT&T Bell Laboratories or
7815 Bellcore or any of their entities not be used in advertising or
7816 publicity pertaining to distribution of the software without
7817 specific, written prior permission.
7819 AT&T and Bellcore disclaim all warranties with regard to this
7820 software, including all implied warranties of merchantability
7821 and fitness. In no event shall AT&T or Bellcore be liable for
7822 any special, indirect or consequential damages or any damages
7823 whatsoever resulting from loss of use, data or profits, whether
7824 in an action of contract, negligence or other tortious action,
7825 arising out of or in connection with the use or performance of
7827 ****************************************************************/
7829 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7830 (SCM x
, SCM y
, SCM rest
),
7831 "Divide the first argument by the product of the remaining\n"
7832 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7834 #define FUNC_NAME s_scm_i_divide
7836 while (!scm_is_null (rest
))
7837 { x
= scm_divide (x
, y
);
7839 rest
= scm_cdr (rest
);
7841 return scm_divide (x
, y
);
7845 #define s_divide s_scm_i_divide
7846 #define g_divide g_scm_i_divide
7849 do_divide (SCM x
, SCM y
, int inexact
)
7850 #define FUNC_NAME s_divide
7854 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7857 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
7858 else if (SCM_I_INUMP (x
))
7860 scm_t_inum xx
= SCM_I_INUM (x
);
7861 if (xx
== 1 || xx
== -1)
7863 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7865 scm_num_overflow (s_divide
);
7870 return scm_from_double (1.0 / (double) xx
);
7871 else return scm_i_make_ratio (SCM_INUM1
, x
);
7874 else if (SCM_BIGP (x
))
7877 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7878 else return scm_i_make_ratio (SCM_INUM1
, x
);
7880 else if (SCM_REALP (x
))
7882 double xx
= SCM_REAL_VALUE (x
);
7883 #ifndef ALLOW_DIVIDE_BY_ZERO
7885 scm_num_overflow (s_divide
);
7888 return scm_from_double (1.0 / xx
);
7890 else if (SCM_COMPLEXP (x
))
7892 double r
= SCM_COMPLEX_REAL (x
);
7893 double i
= SCM_COMPLEX_IMAG (x
);
7894 if (fabs(r
) <= fabs(i
))
7897 double d
= i
* (1.0 + t
* t
);
7898 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7903 double d
= r
* (1.0 + t
* t
);
7904 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7907 else if (SCM_FRACTIONP (x
))
7908 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7909 SCM_FRACTION_NUMERATOR (x
));
7911 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7914 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7916 scm_t_inum xx
= SCM_I_INUM (x
);
7917 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7919 scm_t_inum yy
= SCM_I_INUM (y
);
7922 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7923 scm_num_overflow (s_divide
);
7925 return scm_from_double ((double) xx
/ (double) yy
);
7928 else if (xx
% yy
!= 0)
7931 return scm_from_double ((double) xx
/ (double) yy
);
7932 else return scm_i_make_ratio (x
, y
);
7936 scm_t_inum z
= xx
/ yy
;
7937 if (SCM_FIXABLE (z
))
7938 return SCM_I_MAKINUM (z
);
7940 return scm_i_inum2big (z
);
7943 else if (SCM_BIGP (y
))
7946 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7947 else return scm_i_make_ratio (x
, y
);
7949 else if (SCM_REALP (y
))
7951 double yy
= SCM_REAL_VALUE (y
);
7952 #ifndef ALLOW_DIVIDE_BY_ZERO
7954 scm_num_overflow (s_divide
);
7957 return scm_from_double ((double) xx
/ yy
);
7959 else if (SCM_COMPLEXP (y
))
7962 complex_div
: /* y _must_ be a complex number */
7964 double r
= SCM_COMPLEX_REAL (y
);
7965 double i
= SCM_COMPLEX_IMAG (y
);
7966 if (fabs(r
) <= fabs(i
))
7969 double d
= i
* (1.0 + t
* t
);
7970 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7975 double d
= r
* (1.0 + t
* t
);
7976 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7980 else if (SCM_FRACTIONP (y
))
7981 /* a / b/c = ac / b */
7982 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7983 SCM_FRACTION_NUMERATOR (y
));
7985 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7987 else if (SCM_BIGP (x
))
7989 if (SCM_I_INUMP (y
))
7991 scm_t_inum yy
= SCM_I_INUM (y
);
7994 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7995 scm_num_overflow (s_divide
);
7997 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7998 scm_remember_upto_here_1 (x
);
7999 return (sgn
== 0) ? scm_nan () : scm_inf ();
8006 /* FIXME: HMM, what are the relative performance issues here?
8007 We need to test. Is it faster on average to test
8008 divisible_p, then perform whichever operation, or is it
8009 faster to perform the integer div opportunistically and
8010 switch to real if there's a remainder? For now we take the
8011 middle ground: test, then if divisible, use the faster div
8014 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8015 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8019 SCM result
= scm_i_mkbig ();
8020 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8021 scm_remember_upto_here_1 (x
);
8023 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8024 return scm_i_normbig (result
);
8029 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
8030 else return scm_i_make_ratio (x
, y
);
8034 else if (SCM_BIGP (y
))
8039 /* It's easily possible for the ratio x/y to fit a double
8040 but one or both x and y be too big to fit a double,
8041 hence the use of mpq_get_d rather than converting and
8044 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8045 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8046 return scm_from_double (mpq_get_d (q
));
8050 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8054 SCM result
= scm_i_mkbig ();
8055 mpz_divexact (SCM_I_BIG_MPZ (result
),
8058 scm_remember_upto_here_2 (x
, y
);
8059 return scm_i_normbig (result
);
8062 return scm_i_make_ratio (x
, y
);
8065 else if (SCM_REALP (y
))
8067 double yy
= SCM_REAL_VALUE (y
);
8068 #ifndef ALLOW_DIVIDE_BY_ZERO
8070 scm_num_overflow (s_divide
);
8073 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8075 else if (SCM_COMPLEXP (y
))
8077 a
= scm_i_big2dbl (x
);
8080 else if (SCM_FRACTIONP (y
))
8081 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8082 SCM_FRACTION_NUMERATOR (y
));
8084 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8086 else if (SCM_REALP (x
))
8088 double rx
= SCM_REAL_VALUE (x
);
8089 if (SCM_I_INUMP (y
))
8091 scm_t_inum yy
= SCM_I_INUM (y
);
8092 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8094 scm_num_overflow (s_divide
);
8097 return scm_from_double (rx
/ (double) yy
);
8099 else if (SCM_BIGP (y
))
8101 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8102 scm_remember_upto_here_1 (y
);
8103 return scm_from_double (rx
/ dby
);
8105 else if (SCM_REALP (y
))
8107 double yy
= SCM_REAL_VALUE (y
);
8108 #ifndef ALLOW_DIVIDE_BY_ZERO
8110 scm_num_overflow (s_divide
);
8113 return scm_from_double (rx
/ yy
);
8115 else if (SCM_COMPLEXP (y
))
8120 else if (SCM_FRACTIONP (y
))
8121 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8123 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8125 else if (SCM_COMPLEXP (x
))
8127 double rx
= SCM_COMPLEX_REAL (x
);
8128 double ix
= SCM_COMPLEX_IMAG (x
);
8129 if (SCM_I_INUMP (y
))
8131 scm_t_inum yy
= SCM_I_INUM (y
);
8132 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8134 scm_num_overflow (s_divide
);
8139 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8142 else if (SCM_BIGP (y
))
8144 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8145 scm_remember_upto_here_1 (y
);
8146 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8148 else if (SCM_REALP (y
))
8150 double yy
= SCM_REAL_VALUE (y
);
8151 #ifndef ALLOW_DIVIDE_BY_ZERO
8153 scm_num_overflow (s_divide
);
8156 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8158 else if (SCM_COMPLEXP (y
))
8160 double ry
= SCM_COMPLEX_REAL (y
);
8161 double iy
= SCM_COMPLEX_IMAG (y
);
8162 if (fabs(ry
) <= fabs(iy
))
8165 double d
= iy
* (1.0 + t
* t
);
8166 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8171 double d
= ry
* (1.0 + t
* t
);
8172 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8175 else if (SCM_FRACTIONP (y
))
8177 double yy
= scm_i_fraction2double (y
);
8178 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8181 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8183 else if (SCM_FRACTIONP (x
))
8185 if (SCM_I_INUMP (y
))
8187 scm_t_inum yy
= SCM_I_INUM (y
);
8188 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8190 scm_num_overflow (s_divide
);
8193 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8194 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8196 else if (SCM_BIGP (y
))
8198 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8199 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8201 else if (SCM_REALP (y
))
8203 double yy
= SCM_REAL_VALUE (y
);
8204 #ifndef ALLOW_DIVIDE_BY_ZERO
8206 scm_num_overflow (s_divide
);
8209 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8211 else if (SCM_COMPLEXP (y
))
8213 a
= scm_i_fraction2double (x
);
8216 else if (SCM_FRACTIONP (y
))
8217 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8218 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8220 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8223 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8227 scm_divide (SCM x
, SCM y
)
8229 return do_divide (x
, y
, 0);
8232 static SCM
scm_divide2real (SCM x
, SCM y
)
8234 return do_divide (x
, y
, 1);
8240 scm_c_truncate (double x
)
8245 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8246 half-way case (ie. when x is an integer plus 0.5) going upwards.
8247 Then half-way cases are identified and adjusted down if the
8248 round-upwards didn't give the desired even integer.
8250 "plus_half == result" identifies a half-way case. If plus_half, which is
8251 x + 0.5, is an integer then x must be an integer plus 0.5.
8253 An odd "result" value is identified with result/2 != floor(result/2).
8254 This is done with plus_half, since that value is ready for use sooner in
8255 a pipelined cpu, and we're already requiring plus_half == result.
8257 Note however that we need to be careful when x is big and already an
8258 integer. In that case "x+0.5" may round to an adjacent integer, causing
8259 us to return such a value, incorrectly. For instance if the hardware is
8260 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8261 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8262 returned. Or if the hardware is in round-upwards mode, then other bigger
8263 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8264 representable value, 2^128+2^76 (or whatever), again incorrect.
8266 These bad roundings of x+0.5 are avoided by testing at the start whether
8267 x is already an integer. If it is then clearly that's the desired result
8268 already. And if it's not then the exponent must be small enough to allow
8269 an 0.5 to be represented, and hence added without a bad rounding. */
8272 scm_c_round (double x
)
8274 double plus_half
, result
;
8279 plus_half
= x
+ 0.5;
8280 result
= floor (plus_half
);
8281 /* Adjust so that the rounding is towards even. */
8282 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8287 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8289 "Round the number @var{x} towards zero.")
8290 #define FUNC_NAME s_scm_truncate_number
8292 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8294 else if (SCM_REALP (x
))
8295 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8296 else if (SCM_FRACTIONP (x
))
8297 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8298 SCM_FRACTION_DENOMINATOR (x
));
8300 SCM_WTA_DISPATCH_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8301 s_scm_truncate_number
);
8305 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8307 "Round the number @var{x} towards the nearest integer. "
8308 "When it is exactly halfway between two integers, "
8309 "round towards the even one.")
8310 #define FUNC_NAME s_scm_round_number
8312 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8314 else if (SCM_REALP (x
))
8315 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8316 else if (SCM_FRACTIONP (x
))
8317 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8318 SCM_FRACTION_DENOMINATOR (x
));
8320 SCM_WTA_DISPATCH_1 (g_scm_round_number
, x
, SCM_ARG1
,
8321 s_scm_round_number
);
8325 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8327 "Round the number @var{x} towards minus infinity.")
8328 #define FUNC_NAME s_scm_floor
8330 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8332 else if (SCM_REALP (x
))
8333 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8334 else if (SCM_FRACTIONP (x
))
8335 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8336 SCM_FRACTION_DENOMINATOR (x
));
8338 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8342 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8344 "Round the number @var{x} towards infinity.")
8345 #define FUNC_NAME s_scm_ceiling
8347 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8349 else if (SCM_REALP (x
))
8350 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8351 else if (SCM_FRACTIONP (x
))
8352 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8353 SCM_FRACTION_DENOMINATOR (x
));
8355 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8359 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8361 "Return @var{x} raised to the power of @var{y}.")
8362 #define FUNC_NAME s_scm_expt
8364 if (scm_is_integer (y
))
8366 if (scm_is_true (scm_exact_p (y
)))
8367 return scm_integer_expt (x
, y
);
8370 /* Here we handle the case where the exponent is an inexact
8371 integer. We make the exponent exact in order to use
8372 scm_integer_expt, and thus avoid the spurious imaginary
8373 parts that may result from round-off errors in the general
8374 e^(y log x) method below (for example when squaring a large
8375 negative number). In this case, we must return an inexact
8376 result for correctness. We also make the base inexact so
8377 that scm_integer_expt will use fast inexact arithmetic
8378 internally. Note that making the base inexact is not
8379 sufficient to guarantee an inexact result, because
8380 scm_integer_expt will return an exact 1 when the exponent
8381 is 0, even if the base is inexact. */
8382 return scm_exact_to_inexact
8383 (scm_integer_expt (scm_exact_to_inexact (x
),
8384 scm_inexact_to_exact (y
)));
8387 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8389 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8391 else if (scm_is_complex (x
) && scm_is_complex (y
))
8392 return scm_exp (scm_product (scm_log (x
), y
));
8393 else if (scm_is_complex (x
))
8394 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8396 SCM_WTA_DISPATCH_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8400 /* sin/cos/tan/asin/acos/atan
8401 sinh/cosh/tanh/asinh/acosh/atanh
8402 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8403 Written by Jerry D. Hedden, (C) FSF.
8404 See the file `COPYING' for terms applying to this program. */
8406 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8408 "Compute the sine of @var{z}.")
8409 #define FUNC_NAME s_scm_sin
8411 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8412 return z
; /* sin(exact0) = exact0 */
8413 else if (scm_is_real (z
))
8414 return scm_from_double (sin (scm_to_double (z
)));
8415 else if (SCM_COMPLEXP (z
))
8417 x
= SCM_COMPLEX_REAL (z
);
8418 y
= SCM_COMPLEX_IMAG (z
);
8419 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8420 cos (x
) * sinh (y
));
8423 SCM_WTA_DISPATCH_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8427 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8429 "Compute the cosine of @var{z}.")
8430 #define FUNC_NAME s_scm_cos
8432 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8433 return SCM_INUM1
; /* cos(exact0) = exact1 */
8434 else if (scm_is_real (z
))
8435 return scm_from_double (cos (scm_to_double (z
)));
8436 else if (SCM_COMPLEXP (z
))
8438 x
= SCM_COMPLEX_REAL (z
);
8439 y
= SCM_COMPLEX_IMAG (z
);
8440 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8441 -sin (x
) * sinh (y
));
8444 SCM_WTA_DISPATCH_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8448 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8450 "Compute the tangent of @var{z}.")
8451 #define FUNC_NAME s_scm_tan
8453 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8454 return z
; /* tan(exact0) = exact0 */
8455 else if (scm_is_real (z
))
8456 return scm_from_double (tan (scm_to_double (z
)));
8457 else if (SCM_COMPLEXP (z
))
8459 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8460 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8461 w
= cos (x
) + cosh (y
);
8462 #ifndef ALLOW_DIVIDE_BY_ZERO
8464 scm_num_overflow (s_scm_tan
);
8466 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8469 SCM_WTA_DISPATCH_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8473 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8475 "Compute the hyperbolic sine of @var{z}.")
8476 #define FUNC_NAME s_scm_sinh
8478 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8479 return z
; /* sinh(exact0) = exact0 */
8480 else if (scm_is_real (z
))
8481 return scm_from_double (sinh (scm_to_double (z
)));
8482 else if (SCM_COMPLEXP (z
))
8484 x
= SCM_COMPLEX_REAL (z
);
8485 y
= SCM_COMPLEX_IMAG (z
);
8486 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8487 cosh (x
) * sin (y
));
8490 SCM_WTA_DISPATCH_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8494 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8496 "Compute the hyperbolic cosine of @var{z}.")
8497 #define FUNC_NAME s_scm_cosh
8499 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8500 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8501 else if (scm_is_real (z
))
8502 return scm_from_double (cosh (scm_to_double (z
)));
8503 else if (SCM_COMPLEXP (z
))
8505 x
= SCM_COMPLEX_REAL (z
);
8506 y
= SCM_COMPLEX_IMAG (z
);
8507 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8508 sinh (x
) * sin (y
));
8511 SCM_WTA_DISPATCH_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8515 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8517 "Compute the hyperbolic tangent of @var{z}.")
8518 #define FUNC_NAME s_scm_tanh
8520 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8521 return z
; /* tanh(exact0) = exact0 */
8522 else if (scm_is_real (z
))
8523 return scm_from_double (tanh (scm_to_double (z
)));
8524 else if (SCM_COMPLEXP (z
))
8526 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8527 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8528 w
= cosh (x
) + cos (y
);
8529 #ifndef ALLOW_DIVIDE_BY_ZERO
8531 scm_num_overflow (s_scm_tanh
);
8533 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8536 SCM_WTA_DISPATCH_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8540 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8542 "Compute the arc sine of @var{z}.")
8543 #define FUNC_NAME s_scm_asin
8545 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8546 return z
; /* asin(exact0) = exact0 */
8547 else if (scm_is_real (z
))
8549 double w
= scm_to_double (z
);
8550 if (w
>= -1.0 && w
<= 1.0)
8551 return scm_from_double (asin (w
));
8553 return scm_product (scm_c_make_rectangular (0, -1),
8554 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8556 else if (SCM_COMPLEXP (z
))
8558 x
= SCM_COMPLEX_REAL (z
);
8559 y
= SCM_COMPLEX_IMAG (z
);
8560 return scm_product (scm_c_make_rectangular (0, -1),
8561 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8564 SCM_WTA_DISPATCH_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8568 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8570 "Compute the arc cosine of @var{z}.")
8571 #define FUNC_NAME s_scm_acos
8573 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8574 return SCM_INUM0
; /* acos(exact1) = exact0 */
8575 else if (scm_is_real (z
))
8577 double w
= scm_to_double (z
);
8578 if (w
>= -1.0 && w
<= 1.0)
8579 return scm_from_double (acos (w
));
8581 return scm_sum (scm_from_double (acos (0.0)),
8582 scm_product (scm_c_make_rectangular (0, 1),
8583 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8585 else if (SCM_COMPLEXP (z
))
8587 x
= SCM_COMPLEX_REAL (z
);
8588 y
= SCM_COMPLEX_IMAG (z
);
8589 return scm_sum (scm_from_double (acos (0.0)),
8590 scm_product (scm_c_make_rectangular (0, 1),
8591 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8594 SCM_WTA_DISPATCH_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8598 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8600 "With one argument, compute the arc tangent of @var{z}.\n"
8601 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8602 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8603 #define FUNC_NAME s_scm_atan
8607 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8608 return z
; /* atan(exact0) = exact0 */
8609 else if (scm_is_real (z
))
8610 return scm_from_double (atan (scm_to_double (z
)));
8611 else if (SCM_COMPLEXP (z
))
8614 v
= SCM_COMPLEX_REAL (z
);
8615 w
= SCM_COMPLEX_IMAG (z
);
8616 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8617 scm_c_make_rectangular (v
, w
+ 1.0))),
8618 scm_c_make_rectangular (0, 2));
8621 SCM_WTA_DISPATCH_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8623 else if (scm_is_real (z
))
8625 if (scm_is_real (y
))
8626 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8628 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8631 SCM_WTA_DISPATCH_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8635 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8637 "Compute the inverse hyperbolic sine of @var{z}.")
8638 #define FUNC_NAME s_scm_sys_asinh
8640 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8641 return z
; /* asinh(exact0) = exact0 */
8642 else if (scm_is_real (z
))
8643 return scm_from_double (asinh (scm_to_double (z
)));
8644 else if (scm_is_number (z
))
8645 return scm_log (scm_sum (z
,
8646 scm_sqrt (scm_sum (scm_product (z
, z
),
8649 SCM_WTA_DISPATCH_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8653 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8655 "Compute the inverse hyperbolic cosine of @var{z}.")
8656 #define FUNC_NAME s_scm_sys_acosh
8658 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8659 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8660 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8661 return scm_from_double (acosh (scm_to_double (z
)));
8662 else if (scm_is_number (z
))
8663 return scm_log (scm_sum (z
,
8664 scm_sqrt (scm_difference (scm_product (z
, z
),
8667 SCM_WTA_DISPATCH_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8671 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8673 "Compute the inverse hyperbolic tangent of @var{z}.")
8674 #define FUNC_NAME s_scm_sys_atanh
8676 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8677 return z
; /* atanh(exact0) = exact0 */
8678 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8679 return scm_from_double (atanh (scm_to_double (z
)));
8680 else if (scm_is_number (z
))
8681 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8682 scm_difference (SCM_INUM1
, z
))),
8685 SCM_WTA_DISPATCH_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8690 scm_c_make_rectangular (double re
, double im
)
8694 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8696 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8697 SCM_COMPLEX_REAL (z
) = re
;
8698 SCM_COMPLEX_IMAG (z
) = im
;
8702 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8703 (SCM real_part
, SCM imaginary_part
),
8704 "Return a complex number constructed of the given @var{real-part} "
8705 "and @var{imaginary-part} parts.")
8706 #define FUNC_NAME s_scm_make_rectangular
8708 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8709 SCM_ARG1
, FUNC_NAME
, "real");
8710 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8711 SCM_ARG2
, FUNC_NAME
, "real");
8713 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8714 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8717 return scm_c_make_rectangular (scm_to_double (real_part
),
8718 scm_to_double (imaginary_part
));
8723 scm_c_make_polar (double mag
, double ang
)
8727 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8728 use it on Glibc-based systems that have it (it's a GNU extension). See
8729 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8731 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8732 sincos (ang
, &s
, &c
);
8738 /* If s and c are NaNs, this indicates that the angle is a NaN,
8739 infinite, or perhaps simply too large to determine its value
8740 mod 2*pi. However, we know something that the floating-point
8741 implementation doesn't know: We know that s and c are finite.
8742 Therefore, if the magnitude is zero, return a complex zero.
8744 The reason we check for the NaNs instead of using this case
8745 whenever mag == 0.0 is because when the angle is known, we'd
8746 like to return the correct kind of non-real complex zero:
8747 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8748 on which quadrant the angle is in.
8750 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8751 return scm_c_make_rectangular (0.0, 0.0);
8753 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8756 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8758 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8759 #define FUNC_NAME s_scm_make_polar
8761 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8762 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8764 /* If mag is exact0, return exact0 */
8765 if (scm_is_eq (mag
, SCM_INUM0
))
8767 /* Return a real if ang is exact0 */
8768 else if (scm_is_eq (ang
, SCM_INUM0
))
8771 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8776 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8778 "Return the real part of the number @var{z}.")
8779 #define FUNC_NAME s_scm_real_part
8781 if (SCM_COMPLEXP (z
))
8782 return scm_from_double (SCM_COMPLEX_REAL (z
));
8783 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8786 SCM_WTA_DISPATCH_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8791 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8793 "Return the imaginary part of the number @var{z}.")
8794 #define FUNC_NAME s_scm_imag_part
8796 if (SCM_COMPLEXP (z
))
8797 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8798 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8801 SCM_WTA_DISPATCH_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8805 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8807 "Return the numerator of the number @var{z}.")
8808 #define FUNC_NAME s_scm_numerator
8810 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8812 else if (SCM_FRACTIONP (z
))
8813 return SCM_FRACTION_NUMERATOR (z
);
8814 else if (SCM_REALP (z
))
8815 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8817 SCM_WTA_DISPATCH_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8822 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8824 "Return the denominator of the number @var{z}.")
8825 #define FUNC_NAME s_scm_denominator
8827 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8829 else if (SCM_FRACTIONP (z
))
8830 return SCM_FRACTION_DENOMINATOR (z
);
8831 else if (SCM_REALP (z
))
8832 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8834 SCM_WTA_DISPATCH_1 (g_scm_denominator
, z
, SCM_ARG1
, s_scm_denominator
);
8839 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8841 "Return the magnitude of the number @var{z}. This is the same as\n"
8842 "@code{abs} for real arguments, but also allows complex numbers.")
8843 #define FUNC_NAME s_scm_magnitude
8845 if (SCM_I_INUMP (z
))
8847 scm_t_inum zz
= SCM_I_INUM (z
);
8850 else if (SCM_POSFIXABLE (-zz
))
8851 return SCM_I_MAKINUM (-zz
);
8853 return scm_i_inum2big (-zz
);
8855 else if (SCM_BIGP (z
))
8857 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8858 scm_remember_upto_here_1 (z
);
8860 return scm_i_clonebig (z
, 0);
8864 else if (SCM_REALP (z
))
8865 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8866 else if (SCM_COMPLEXP (z
))
8867 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8868 else if (SCM_FRACTIONP (z
))
8870 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8872 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8873 SCM_FRACTION_DENOMINATOR (z
));
8876 SCM_WTA_DISPATCH_1 (g_scm_magnitude
, z
, SCM_ARG1
, s_scm_magnitude
);
8881 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8883 "Return the angle of the complex number @var{z}.")
8884 #define FUNC_NAME s_scm_angle
8886 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8887 flo0 to save allocating a new flonum with scm_from_double each time.
8888 But if atan2 follows the floating point rounding mode, then the value
8889 is not a constant. Maybe it'd be close enough though. */
8890 if (SCM_I_INUMP (z
))
8892 if (SCM_I_INUM (z
) >= 0)
8895 return scm_from_double (atan2 (0.0, -1.0));
8897 else if (SCM_BIGP (z
))
8899 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8900 scm_remember_upto_here_1 (z
);
8902 return scm_from_double (atan2 (0.0, -1.0));
8906 else if (SCM_REALP (z
))
8908 if (SCM_REAL_VALUE (z
) >= 0)
8911 return scm_from_double (atan2 (0.0, -1.0));
8913 else if (SCM_COMPLEXP (z
))
8914 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8915 else if (SCM_FRACTIONP (z
))
8917 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8919 else return scm_from_double (atan2 (0.0, -1.0));
8922 SCM_WTA_DISPATCH_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8927 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8929 "Convert the number @var{z} to its inexact representation.\n")
8930 #define FUNC_NAME s_scm_exact_to_inexact
8932 if (SCM_I_INUMP (z
))
8933 return scm_from_double ((double) SCM_I_INUM (z
));
8934 else if (SCM_BIGP (z
))
8935 return scm_from_double (scm_i_big2dbl (z
));
8936 else if (SCM_FRACTIONP (z
))
8937 return scm_from_double (scm_i_fraction2double (z
));
8938 else if (SCM_INEXACTP (z
))
8941 SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact
, z
, 1, s_scm_exact_to_inexact
);
8946 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8948 "Return an exact number that is numerically closest to @var{z}.")
8949 #define FUNC_NAME s_scm_inexact_to_exact
8951 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8958 val
= SCM_REAL_VALUE (z
);
8959 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8960 val
= SCM_COMPLEX_REAL (z
);
8962 SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact
, z
, 1, s_scm_inexact_to_exact
);
8964 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8965 SCM_OUT_OF_RANGE (1, z
);
8972 mpq_set_d (frac
, val
);
8973 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8974 scm_i_mpz2num (mpq_denref (frac
)));
8976 /* When scm_i_make_ratio throws, we leak the memory allocated
8986 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8988 "Returns the @emph{simplest} rational number differing\n"
8989 "from @var{x} by no more than @var{eps}.\n"
8991 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8992 "exact result when both its arguments are exact. Thus, you might need\n"
8993 "to use @code{inexact->exact} on the arguments.\n"
8996 "(rationalize (inexact->exact 1.2) 1/100)\n"
8999 #define FUNC_NAME s_scm_rationalize
9001 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9002 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9003 eps
= scm_abs (eps
);
9004 if (scm_is_false (scm_positive_p (eps
)))
9006 /* eps is either zero or a NaN */
9007 if (scm_is_true (scm_nan_p (eps
)))
9009 else if (SCM_INEXACTP (eps
))
9010 return scm_exact_to_inexact (x
);
9014 else if (scm_is_false (scm_finite_p (eps
)))
9016 if (scm_is_true (scm_finite_p (x
)))
9021 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9023 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9024 scm_ceiling (scm_difference (x
, eps
)))))
9026 /* There's an integer within range; we want the one closest to zero */
9027 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9029 /* zero is within range */
9030 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9035 else if (scm_is_true (scm_positive_p (x
)))
9036 return scm_ceiling (scm_difference (x
, eps
));
9038 return scm_floor (scm_sum (x
, eps
));
9042 /* Use continued fractions to find closest ratio. All
9043 arithmetic is done with exact numbers.
9046 SCM ex
= scm_inexact_to_exact (x
);
9047 SCM int_part
= scm_floor (ex
);
9049 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9050 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9054 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9055 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9057 /* We stop after a million iterations just to be absolutely sure
9058 that we don't go into an infinite loop. The process normally
9059 converges after less than a dozen iterations.
9062 while (++i
< 1000000)
9064 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9065 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9066 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9068 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9069 eps
))) /* abs(x-a/b) <= eps */
9071 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9072 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9073 return scm_exact_to_inexact (res
);
9077 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9079 tt
= scm_floor (rx
); /* tt = floor (rx) */
9085 scm_num_overflow (s_scm_rationalize
);
9090 /* conversion functions */
9093 scm_is_integer (SCM val
)
9095 return scm_is_true (scm_integer_p (val
));
9099 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9101 if (SCM_I_INUMP (val
))
9103 scm_t_signed_bits n
= SCM_I_INUM (val
);
9104 return n
>= min
&& n
<= max
;
9106 else if (SCM_BIGP (val
))
9108 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9110 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9112 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9114 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9115 return n
>= min
&& n
<= max
;
9125 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9126 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9129 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9130 SCM_I_BIG_MPZ (val
));
9132 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9144 return n
>= min
&& n
<= max
;
9152 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9154 if (SCM_I_INUMP (val
))
9156 scm_t_signed_bits n
= SCM_I_INUM (val
);
9157 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9159 else if (SCM_BIGP (val
))
9161 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9163 else if (max
<= ULONG_MAX
)
9165 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9167 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9168 return n
>= min
&& n
<= max
;
9178 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9181 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9182 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9185 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9186 SCM_I_BIG_MPZ (val
));
9188 return n
>= min
&& n
<= max
;
9196 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9198 scm_error (scm_out_of_range_key
,
9200 "Value out of range ~S to ~S: ~S",
9201 scm_list_3 (min
, max
, bad_val
),
9202 scm_list_1 (bad_val
));
9205 #define TYPE scm_t_intmax
9206 #define TYPE_MIN min
9207 #define TYPE_MAX max
9208 #define SIZEOF_TYPE 0
9209 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9210 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9211 #include "libguile/conv-integer.i.c"
9213 #define TYPE scm_t_uintmax
9214 #define TYPE_MIN min
9215 #define TYPE_MAX max
9216 #define SIZEOF_TYPE 0
9217 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9218 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9219 #include "libguile/conv-uinteger.i.c"
9221 #define TYPE scm_t_int8
9222 #define TYPE_MIN SCM_T_INT8_MIN
9223 #define TYPE_MAX SCM_T_INT8_MAX
9224 #define SIZEOF_TYPE 1
9225 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9226 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9227 #include "libguile/conv-integer.i.c"
9229 #define TYPE scm_t_uint8
9231 #define TYPE_MAX SCM_T_UINT8_MAX
9232 #define SIZEOF_TYPE 1
9233 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9234 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9235 #include "libguile/conv-uinteger.i.c"
9237 #define TYPE scm_t_int16
9238 #define TYPE_MIN SCM_T_INT16_MIN
9239 #define TYPE_MAX SCM_T_INT16_MAX
9240 #define SIZEOF_TYPE 2
9241 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9242 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9243 #include "libguile/conv-integer.i.c"
9245 #define TYPE scm_t_uint16
9247 #define TYPE_MAX SCM_T_UINT16_MAX
9248 #define SIZEOF_TYPE 2
9249 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9250 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9251 #include "libguile/conv-uinteger.i.c"
9253 #define TYPE scm_t_int32
9254 #define TYPE_MIN SCM_T_INT32_MIN
9255 #define TYPE_MAX SCM_T_INT32_MAX
9256 #define SIZEOF_TYPE 4
9257 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9258 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9259 #include "libguile/conv-integer.i.c"
9261 #define TYPE scm_t_uint32
9263 #define TYPE_MAX SCM_T_UINT32_MAX
9264 #define SIZEOF_TYPE 4
9265 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9266 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9267 #include "libguile/conv-uinteger.i.c"
9269 #define TYPE scm_t_wchar
9270 #define TYPE_MIN (scm_t_int32)-1
9271 #define TYPE_MAX (scm_t_int32)0x10ffff
9272 #define SIZEOF_TYPE 4
9273 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9274 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9275 #include "libguile/conv-integer.i.c"
9277 #define TYPE scm_t_int64
9278 #define TYPE_MIN SCM_T_INT64_MIN
9279 #define TYPE_MAX SCM_T_INT64_MAX
9280 #define SIZEOF_TYPE 8
9281 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9282 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9283 #include "libguile/conv-integer.i.c"
9285 #define TYPE scm_t_uint64
9287 #define TYPE_MAX SCM_T_UINT64_MAX
9288 #define SIZEOF_TYPE 8
9289 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9290 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9291 #include "libguile/conv-uinteger.i.c"
9294 scm_to_mpz (SCM val
, mpz_t rop
)
9296 if (SCM_I_INUMP (val
))
9297 mpz_set_si (rop
, SCM_I_INUM (val
));
9298 else if (SCM_BIGP (val
))
9299 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9301 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9305 scm_from_mpz (mpz_t val
)
9307 return scm_i_mpz2num (val
);
9311 scm_is_real (SCM val
)
9313 return scm_is_true (scm_real_p (val
));
9317 scm_is_rational (SCM val
)
9319 return scm_is_true (scm_rational_p (val
));
9323 scm_to_double (SCM val
)
9325 if (SCM_I_INUMP (val
))
9326 return SCM_I_INUM (val
);
9327 else if (SCM_BIGP (val
))
9328 return scm_i_big2dbl (val
);
9329 else if (SCM_FRACTIONP (val
))
9330 return scm_i_fraction2double (val
);
9331 else if (SCM_REALP (val
))
9332 return SCM_REAL_VALUE (val
);
9334 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9338 scm_from_double (double val
)
9342 z
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9344 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9345 SCM_REAL_VALUE (z
) = val
;
9350 #if SCM_ENABLE_DEPRECATED == 1
9353 scm_num2float (SCM num
, unsigned long pos
, const char *s_caller
)
9355 scm_c_issue_deprecation_warning
9356 ("`scm_num2float' is deprecated. Use scm_to_double instead.");
9360 float res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9364 scm_out_of_range (NULL
, num
);
9367 return scm_to_double (num
);
9371 scm_num2double (SCM num
, unsigned long pos
, const char *s_caller
)
9373 scm_c_issue_deprecation_warning
9374 ("`scm_num2double' is deprecated. Use scm_to_double instead.");
9378 double res
= mpz_get_d (SCM_I_BIG_MPZ (num
));
9382 scm_out_of_range (NULL
, num
);
9385 return scm_to_double (num
);
9391 scm_is_complex (SCM val
)
9393 return scm_is_true (scm_complex_p (val
));
9397 scm_c_real_part (SCM z
)
9399 if (SCM_COMPLEXP (z
))
9400 return SCM_COMPLEX_REAL (z
);
9403 /* Use the scm_real_part to get proper error checking and
9406 return scm_to_double (scm_real_part (z
));
9411 scm_c_imag_part (SCM z
)
9413 if (SCM_COMPLEXP (z
))
9414 return SCM_COMPLEX_IMAG (z
);
9417 /* Use the scm_imag_part to get proper error checking and
9418 dispatching. The result will almost always be 0.0, but not
9421 return scm_to_double (scm_imag_part (z
));
9426 scm_c_magnitude (SCM z
)
9428 return scm_to_double (scm_magnitude (z
));
9434 return scm_to_double (scm_angle (z
));
9438 scm_is_number (SCM z
)
9440 return scm_is_true (scm_number_p (z
));
9444 /* Returns log(x * 2^shift) */
9446 log_of_shifted_double (double x
, long shift
)
9448 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9450 if (x
> 0.0 || double_is_non_negative_zero (x
))
9451 return scm_from_double (ans
);
9453 return scm_c_make_rectangular (ans
, M_PI
);
9456 /* Returns log(n), for exact integer n of integer-length size */
9458 log_of_exact_integer_with_size (SCM n
, long size
)
9460 long shift
= size
- 2 * scm_dblprec
[0];
9463 return log_of_shifted_double
9464 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9467 return log_of_shifted_double (scm_to_double (n
), 0);
9470 /* Returns log(n), for exact integer n */
9472 log_of_exact_integer (SCM n
)
9474 return log_of_exact_integer_with_size
9475 (n
, scm_to_long (scm_integer_length (n
)));
9478 /* Returns log(n/d), for exact non-zero integers n and d */
9480 log_of_fraction (SCM n
, SCM d
)
9482 long n_size
= scm_to_long (scm_integer_length (n
));
9483 long d_size
= scm_to_long (scm_integer_length (d
));
9485 if (abs (n_size
- d_size
) > 1)
9486 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9487 log_of_exact_integer_with_size (d
, d_size
)));
9488 else if (scm_is_false (scm_negative_p (n
)))
9489 return scm_from_double
9490 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9492 return scm_c_make_rectangular
9493 (log1p (scm_to_double (scm_divide2real
9494 (scm_difference (scm_abs (n
), d
),
9500 /* In the following functions we dispatch to the real-arg funcs like log()
9501 when we know the arg is real, instead of just handing everything to
9502 clog() for instance. This is in case clog() doesn't optimize for a
9503 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9504 well use it to go straight to the applicable C func. */
9506 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9508 "Return the natural logarithm of @var{z}.")
9509 #define FUNC_NAME s_scm_log
9511 if (SCM_COMPLEXP (z
))
9513 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9514 && defined (SCM_COMPLEX_VALUE)
9515 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9517 double re
= SCM_COMPLEX_REAL (z
);
9518 double im
= SCM_COMPLEX_IMAG (z
);
9519 return scm_c_make_rectangular (log (hypot (re
, im
)),
9523 else if (SCM_REALP (z
))
9524 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9525 else if (SCM_I_INUMP (z
))
9527 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9528 if (scm_is_eq (z
, SCM_INUM0
))
9529 scm_num_overflow (s_scm_log
);
9531 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9533 else if (SCM_BIGP (z
))
9534 return log_of_exact_integer (z
);
9535 else if (SCM_FRACTIONP (z
))
9536 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9537 SCM_FRACTION_DENOMINATOR (z
));
9539 SCM_WTA_DISPATCH_1 (g_scm_log
, z
, 1, s_scm_log
);
9544 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9546 "Return the base 10 logarithm of @var{z}.")
9547 #define FUNC_NAME s_scm_log10
9549 if (SCM_COMPLEXP (z
))
9551 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9552 clog() and a multiply by M_LOG10E, rather than the fallback
9553 log10+hypot+atan2.) */
9554 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9555 && defined SCM_COMPLEX_VALUE
9556 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9558 double re
= SCM_COMPLEX_REAL (z
);
9559 double im
= SCM_COMPLEX_IMAG (z
);
9560 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9561 M_LOG10E
* atan2 (im
, re
));
9564 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9566 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9567 if (scm_is_eq (z
, SCM_INUM0
))
9568 scm_num_overflow (s_scm_log10
);
9571 double re
= scm_to_double (z
);
9572 double l
= log10 (fabs (re
));
9573 if (re
> 0.0 || double_is_non_negative_zero (re
))
9574 return scm_from_double (l
);
9576 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9579 else if (SCM_BIGP (z
))
9580 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9581 else if (SCM_FRACTIONP (z
))
9582 return scm_product (flo_log10e
,
9583 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9584 SCM_FRACTION_DENOMINATOR (z
)));
9586 SCM_WTA_DISPATCH_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9591 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9593 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9594 "base of natural logarithms (2.71828@dots{}).")
9595 #define FUNC_NAME s_scm_exp
9597 if (SCM_COMPLEXP (z
))
9599 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9600 && defined (SCM_COMPLEX_VALUE)
9601 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9603 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9604 SCM_COMPLEX_IMAG (z
));
9607 else if (SCM_NUMBERP (z
))
9609 /* When z is a negative bignum the conversion to double overflows,
9610 giving -infinity, but that's ok, the exp is still 0.0. */
9611 return scm_from_double (exp (scm_to_double (z
)));
9614 SCM_WTA_DISPATCH_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9619 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9621 "Return two exact non-negative integers @var{s} and @var{r}\n"
9622 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9623 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9624 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9627 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9629 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9633 scm_exact_integer_sqrt (k
, &s
, &r
);
9634 return scm_values (scm_list_2 (s
, r
));
9639 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9641 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9643 scm_t_inum kk
= SCM_I_INUM (k
);
9647 if (SCM_LIKELY (kk
> 0))
9652 uu
= (ss
+ kk
/ss
) / 2;
9654 *sp
= SCM_I_MAKINUM (ss
);
9655 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9657 else if (SCM_LIKELY (kk
== 0))
9658 *sp
= *rp
= SCM_INUM0
;
9660 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9661 "exact non-negative integer");
9663 else if (SCM_LIKELY (SCM_BIGP (k
)))
9667 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9668 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9669 "exact non-negative integer");
9672 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9673 scm_remember_upto_here_1 (k
);
9674 *sp
= scm_i_normbig (s
);
9675 *rp
= scm_i_normbig (r
);
9678 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9679 "exact non-negative integer");
9683 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9685 "Return the square root of @var{z}. Of the two possible roots\n"
9686 "(positive and negative), the one with positive real part\n"
9687 "is returned, or if that's zero then a positive imaginary part.\n"
9691 "(sqrt 9.0) @result{} 3.0\n"
9692 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9693 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9694 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9696 #define FUNC_NAME s_scm_sqrt
9698 if (SCM_COMPLEXP (z
))
9700 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9701 && defined SCM_COMPLEX_VALUE
9702 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9704 double re
= SCM_COMPLEX_REAL (z
);
9705 double im
= SCM_COMPLEX_IMAG (z
);
9706 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9707 0.5 * atan2 (im
, re
));
9710 else if (SCM_NUMBERP (z
))
9712 double xx
= scm_to_double (z
);
9714 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9716 return scm_from_double (sqrt (xx
));
9719 SCM_WTA_DISPATCH_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9730 if (scm_install_gmp_memory_functions
)
9731 mp_set_memory_functions (custom_gmp_malloc
,
9735 mpz_init_set_si (z_negative_one
, -1);
9737 /* It may be possible to tune the performance of some algorithms by using
9738 * the following constants to avoid the creation of bignums. Please, before
9739 * using these values, remember the two rules of program optimization:
9740 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9741 scm_c_define ("most-positive-fixnum",
9742 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9743 scm_c_define ("most-negative-fixnum",
9744 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9746 scm_add_feature ("complex");
9747 scm_add_feature ("inexact");
9748 flo0
= scm_from_double (0.0);
9749 flo_log10e
= scm_from_double (M_LOG10E
);
9751 /* determine floating point precision */
9752 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9754 init_dblprec(&scm_dblprec
[i
-2],i
);
9755 init_fx_radix(fx_per_radix
[i
-2],i
);
9758 /* hard code precision for base 10 if the preprocessor tells us to... */
9759 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9762 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9763 #include "libguile/numbers.x"