1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 /* General assumptions:
25 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
26 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
27 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
28 * XXX What about infinities? They are equal to their own floor! -mhw
29 * All objects satisfying SCM_FRACTIONP are never an integer.
34 - see if special casing bignums and reals in integer-exponent when
35 possible (to use mpz_pow and mpf_pow_ui) is faster.
37 - look in to better short-circuiting of common cases in
38 integer-expt and elsewhere.
40 - see if direct mpz operations can help in ash and elsewhere.
59 #include "libguile/_scm.h"
60 #include "libguile/feature.h"
61 #include "libguile/ports.h"
62 #include "libguile/root.h"
63 #include "libguile/smob.h"
64 #include "libguile/strings.h"
65 #include "libguile/bdw-gc.h"
67 #include "libguile/validate.h"
68 #include "libguile/numbers.h"
69 #include "libguile/deprecation.h"
71 #include "libguile/eq.h"
73 /* values per glibc, if not already defined */
75 #define M_LOG10E 0.43429448190325182765
78 #define M_LN2 0.69314718055994530942
81 #define M_PI 3.14159265358979323846
84 typedef scm_t_signed_bits scm_t_inum
;
85 #define scm_from_inum(x) (scm_from_signed_integer (x))
87 /* Tests to see if a C double is neither infinite nor a NaN.
88 TODO: if it's available, use C99's isfinite(x) instead */
89 #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
91 /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
92 of the infinity, but other platforms return a boolean only. */
93 #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
94 #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
99 Wonder if this might be faster for some of our code? A switch on
100 the numtag would jump directly to the right case, and the
101 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
103 #define SCM_I_NUMTAG_NOTNUM 0
104 #define SCM_I_NUMTAG_INUM 1
105 #define SCM_I_NUMTAG_BIG scm_tc16_big
106 #define SCM_I_NUMTAG_REAL scm_tc16_real
107 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
108 #define SCM_I_NUMTAG(x) \
109 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
110 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
111 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
112 : SCM_I_NUMTAG_NOTNUM)))
114 /* the macro above will not work as is with fractions */
117 /* Default to 1, because as we used to hard-code `free' as the
118 deallocator, we know that overriding these functions with
119 instrumented `malloc' / `free' is OK. */
120 int scm_install_gmp_memory_functions
= 1;
122 static SCM exactly_one_half
;
123 static SCM flo_log10e
;
125 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
127 /* FLOBUFLEN is the maximum number of characters neccessary for the
128 * printed or scm_string representation of an inexact number.
130 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
133 #if !defined (HAVE_ASINH)
134 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
136 #if !defined (HAVE_ACOSH)
137 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
139 #if !defined (HAVE_ATANH)
140 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
143 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
144 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
145 in March 2006), mpz_cmp_d now handles infinities properly. */
147 #define xmpz_cmp_d(z, d) \
148 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
150 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
154 #if defined (GUILE_I)
155 #if defined HAVE_COMPLEX_DOUBLE
157 /* For an SCM object Z which is a complex number (ie. satisfies
158 SCM_COMPLEXP), return its value as a C level "complex double". */
159 #define SCM_COMPLEX_VALUE(z) \
160 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
162 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
164 /* Convert a C "complex double" to an SCM value. */
166 scm_from_complex_double (complex double z
)
168 return scm_c_make_rectangular (creal (z
), cimag (z
));
171 #endif /* HAVE_COMPLEX_DOUBLE */
176 static mpz_t z_negative_one
;
180 /* Clear the `mpz_t' embedded in bignum PTR. */
182 finalize_bignum (GC_PTR ptr
, GC_PTR data
)
186 bignum
= SCM_PACK_POINTER (ptr
);
187 mpz_clear (SCM_I_BIG_MPZ (bignum
));
190 /* The next three functions (custom_libgmp_*) are passed to
191 mp_set_memory_functions (in GMP) so that memory used by the digits
192 themselves is known to the garbage collector. This is needed so
193 that GC will be run at appropriate times. Otherwise, a program which
194 creates many large bignums would malloc a huge amount of memory
195 before the GC runs. */
197 custom_gmp_malloc (size_t alloc_size
)
199 return scm_malloc (alloc_size
);
203 custom_gmp_realloc (void *old_ptr
, size_t old_size
, size_t new_size
)
205 return scm_realloc (old_ptr
, new_size
);
209 custom_gmp_free (void *ptr
, size_t size
)
215 /* Return a new uninitialized bignum. */
220 GC_finalization_proc prev_finalizer
;
221 GC_PTR prev_finalizer_data
;
223 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
224 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
228 GC_REGISTER_FINALIZER_NO_ORDER (p
, finalize_bignum
, NULL
,
230 &prev_finalizer_data
);
239 /* Return a newly created bignum. */
240 SCM z
= make_bignum ();
241 mpz_init (SCM_I_BIG_MPZ (z
));
246 scm_i_inum2big (scm_t_inum x
)
248 /* Return a newly created bignum initialized to X. */
249 SCM z
= make_bignum ();
250 #if SIZEOF_VOID_P == SIZEOF_LONG
251 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
253 /* Note that in this case, you'll also have to check all mpz_*_ui and
254 mpz_*_si invocations in Guile. */
255 #error creation of mpz not implemented for this inum size
261 scm_i_long2big (long x
)
263 /* Return a newly created bignum initialized to X. */
264 SCM z
= make_bignum ();
265 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
270 scm_i_ulong2big (unsigned long x
)
272 /* Return a newly created bignum initialized to X. */
273 SCM z
= make_bignum ();
274 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
279 scm_i_clonebig (SCM src_big
, int same_sign_p
)
281 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
282 SCM z
= make_bignum ();
283 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
285 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
290 scm_i_bigcmp (SCM x
, SCM y
)
292 /* Return neg if x < y, pos if x > y, and 0 if x == y */
293 /* presume we already know x and y are bignums */
294 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
295 scm_remember_upto_here_2 (x
, y
);
300 scm_i_dbl2big (double d
)
302 /* results are only defined if d is an integer */
303 SCM z
= make_bignum ();
304 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
308 /* Convert a integer in double representation to a SCM number. */
311 scm_i_dbl2num (double u
)
313 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
314 powers of 2, so there's no rounding when making "double" values
315 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
316 get rounded on a 64-bit machine, hence the "+1".
318 The use of floor() to force to an integer value ensures we get a
319 "numerically closest" value without depending on how a
320 double->long cast or how mpz_set_d will round. For reference,
321 double->long probably follows the hardware rounding mode,
322 mpz_set_d truncates towards zero. */
324 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
325 representable as a double? */
327 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
328 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
329 return SCM_I_MAKINUM ((scm_t_inum
) u
);
331 return scm_i_dbl2big (u
);
334 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
335 with R5RS exact->inexact.
337 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
338 (ie. truncate towards zero), then adjust to get the closest double by
339 examining the next lower bit and adding 1 (to the absolute value) if
342 Bignums exactly half way between representable doubles are rounded to the
343 next higher absolute value (ie. away from zero). This seems like an
344 adequate interpretation of R5RS "numerically closest", and it's easier
345 and faster than a full "nearest-even" style.
347 The bit test must be done on the absolute value of the mpz_t, which means
348 we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
349 negatives as twos complement.
351 In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
352 following the hardware rounding mode, but applied to the absolute
353 value of the mpz_t operand. This is not what we want so we put the
354 high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
355 (released in March 2006) mpz_get_d now always truncates towards zero.
357 ENHANCE-ME: The temporary init+clear to force the rounding in GMP
358 before 4.2 is a slowdown. It'd be faster to pick out the relevant
359 high bits with mpz_getlimbn. */
362 scm_i_big2dbl (SCM b
)
367 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
371 /* For GMP earlier than 4.2, force truncation towards zero */
373 /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
374 _not_ the number of bits, so this code will break badly on a
375 system with non-binary doubles. */
378 if (bits
> DBL_MANT_DIG
)
380 size_t shift
= bits
- DBL_MANT_DIG
;
381 mpz_init2 (tmp
, DBL_MANT_DIG
);
382 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
383 result
= ldexp (mpz_get_d (tmp
), shift
);
388 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
392 /* GMP 4.2 or later */
393 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
396 if (bits
> DBL_MANT_DIG
)
398 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
399 /* test bit number "pos" in absolute value */
400 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
401 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
403 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
407 scm_remember_upto_here_1 (b
);
412 scm_i_normbig (SCM b
)
414 /* convert a big back to a fixnum if it'll fit */
415 /* presume b is a bignum */
416 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
418 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
419 if (SCM_FIXABLE (val
))
420 b
= SCM_I_MAKINUM (val
);
425 static SCM_C_INLINE_KEYWORD SCM
426 scm_i_mpz2num (mpz_t b
)
428 /* convert a mpz number to a SCM number. */
429 if (mpz_fits_slong_p (b
))
431 scm_t_inum val
= mpz_get_si (b
);
432 if (SCM_FIXABLE (val
))
433 return SCM_I_MAKINUM (val
);
437 SCM z
= make_bignum ();
438 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
443 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
444 static SCM
scm_divide2real (SCM x
, SCM y
);
447 scm_i_make_ratio (SCM numerator
, SCM denominator
)
448 #define FUNC_NAME "make-ratio"
450 /* First make sure the arguments are proper.
452 if (SCM_I_INUMP (denominator
))
454 if (scm_is_eq (denominator
, SCM_INUM0
))
455 scm_num_overflow ("make-ratio");
456 if (scm_is_eq (denominator
, SCM_INUM1
))
461 if (!(SCM_BIGP(denominator
)))
462 SCM_WRONG_TYPE_ARG (2, denominator
);
464 if (!SCM_I_INUMP (numerator
) && !SCM_BIGP (numerator
))
465 SCM_WRONG_TYPE_ARG (1, numerator
);
467 /* Then flip signs so that the denominator is positive.
469 if (scm_is_true (scm_negative_p (denominator
)))
471 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
472 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
475 /* Now consider for each of the four fixnum/bignum combinations
476 whether the rational number is really an integer.
478 if (SCM_I_INUMP (numerator
))
480 scm_t_inum x
= SCM_I_INUM (numerator
);
481 if (scm_is_eq (numerator
, SCM_INUM0
))
483 if (SCM_I_INUMP (denominator
))
486 y
= SCM_I_INUM (denominator
);
490 return SCM_I_MAKINUM (x
/ y
);
494 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
495 of that value for the denominator, as a bignum. Apart from
496 that case, abs(bignum) > abs(inum) so inum/bignum is not an
498 if (x
== SCM_MOST_NEGATIVE_FIXNUM
499 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
500 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
501 return SCM_I_MAKINUM(-1);
504 else if (SCM_BIGP (numerator
))
506 if (SCM_I_INUMP (denominator
))
508 scm_t_inum yy
= SCM_I_INUM (denominator
);
509 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
510 return scm_divide (numerator
, denominator
);
514 if (scm_is_eq (numerator
, denominator
))
516 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
517 SCM_I_BIG_MPZ (denominator
)))
518 return scm_divide(numerator
, denominator
);
522 /* No, it's a proper fraction.
525 SCM divisor
= scm_gcd (numerator
, denominator
);
526 if (!(scm_is_eq (divisor
, SCM_INUM1
)))
528 numerator
= scm_divide (numerator
, divisor
);
529 denominator
= scm_divide (denominator
, divisor
);
532 return scm_double_cell (scm_tc16_fraction
,
533 SCM_UNPACK (numerator
),
534 SCM_UNPACK (denominator
), 0);
540 scm_i_fraction2double (SCM z
)
542 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
543 SCM_FRACTION_DENOMINATOR (z
)));
547 double_is_non_negative_zero (double x
)
549 static double zero
= 0.0;
551 return !memcmp (&x
, &zero
, sizeof(double));
554 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
556 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
558 #define FUNC_NAME s_scm_exact_p
560 if (SCM_INEXACTP (x
))
562 else if (SCM_NUMBERP (x
))
565 return scm_wta_dispatch_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
570 scm_is_exact (SCM val
)
572 return scm_is_true (scm_exact_p (val
));
575 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
577 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
579 #define FUNC_NAME s_scm_inexact_p
581 if (SCM_INEXACTP (x
))
583 else if (SCM_NUMBERP (x
))
586 return scm_wta_dispatch_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
591 scm_is_inexact (SCM val
)
593 return scm_is_true (scm_inexact_p (val
));
596 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
598 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
600 #define FUNC_NAME s_scm_odd_p
604 scm_t_inum val
= SCM_I_INUM (n
);
605 return scm_from_bool ((val
& 1L) != 0);
607 else if (SCM_BIGP (n
))
609 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
610 scm_remember_upto_here_1 (n
);
611 return scm_from_bool (odd_p
);
613 else if (SCM_REALP (n
))
615 double val
= SCM_REAL_VALUE (n
);
616 if (DOUBLE_IS_FINITE (val
))
618 double rem
= fabs (fmod (val
, 2.0));
625 return scm_wta_dispatch_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
630 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
632 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
634 #define FUNC_NAME s_scm_even_p
638 scm_t_inum val
= SCM_I_INUM (n
);
639 return scm_from_bool ((val
& 1L) == 0);
641 else if (SCM_BIGP (n
))
643 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
644 scm_remember_upto_here_1 (n
);
645 return scm_from_bool (even_p
);
647 else if (SCM_REALP (n
))
649 double val
= SCM_REAL_VALUE (n
);
650 if (DOUBLE_IS_FINITE (val
))
652 double rem
= fabs (fmod (val
, 2.0));
659 return scm_wta_dispatch_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
663 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
665 "Return @code{#t} if the real number @var{x} is neither\n"
666 "infinite nor a NaN, @code{#f} otherwise.")
667 #define FUNC_NAME s_scm_finite_p
670 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
671 else if (scm_is_real (x
))
674 return scm_wta_dispatch_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
678 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
680 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
681 "@samp{-inf.0}. Otherwise return @code{#f}.")
682 #define FUNC_NAME s_scm_inf_p
685 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
686 else if (scm_is_real (x
))
689 return scm_wta_dispatch_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
693 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
695 "Return @code{#t} if the real number @var{x} is a NaN,\n"
696 "or @code{#f} otherwise.")
697 #define FUNC_NAME s_scm_nan_p
700 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
701 else if (scm_is_real (x
))
704 return scm_wta_dispatch_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
708 /* Guile's idea of infinity. */
709 static double guile_Inf
;
711 /* Guile's idea of not a number. */
712 static double guile_NaN
;
715 guile_ieee_init (void)
717 /* Some version of gcc on some old version of Linux used to crash when
718 trying to make Inf and NaN. */
721 /* C99 INFINITY, when available.
722 FIXME: The standard allows for INFINITY to be something that overflows
723 at compile time. We ought to have a configure test to check for that
724 before trying to use it. (But in practice we believe this is not a
725 problem on any system guile is likely to target.) */
726 guile_Inf
= INFINITY
;
727 #elif defined HAVE_DINFINITY
729 extern unsigned int DINFINITY
[2];
730 guile_Inf
= (*((double *) (DINFINITY
)));
737 if (guile_Inf
== tmp
)
744 /* C99 NAN, when available */
746 #elif defined HAVE_DQNAN
749 extern unsigned int DQNAN
[2];
750 guile_NaN
= (*((double *)(DQNAN
)));
753 guile_NaN
= guile_Inf
/ guile_Inf
;
757 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
760 #define FUNC_NAME s_scm_inf
762 static int initialized
= 0;
768 return scm_from_double (guile_Inf
);
772 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
775 #define FUNC_NAME s_scm_nan
777 static int initialized
= 0;
783 return scm_from_double (guile_NaN
);
788 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
790 "Return the absolute value of @var{x}.")
791 #define FUNC_NAME s_scm_abs
795 scm_t_inum xx
= SCM_I_INUM (x
);
798 else if (SCM_POSFIXABLE (-xx
))
799 return SCM_I_MAKINUM (-xx
);
801 return scm_i_inum2big (-xx
);
803 else if (SCM_LIKELY (SCM_REALP (x
)))
805 double xx
= SCM_REAL_VALUE (x
);
806 /* If x is a NaN then xx<0 is false so we return x unchanged */
808 return scm_from_double (-xx
);
809 /* Handle signed zeroes properly */
810 else if (SCM_UNLIKELY (xx
== 0.0))
815 else if (SCM_BIGP (x
))
817 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
819 return scm_i_clonebig (x
, 0);
823 else if (SCM_FRACTIONP (x
))
825 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
827 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
828 SCM_FRACTION_DENOMINATOR (x
));
831 return scm_wta_dispatch_1 (g_scm_abs
, x
, 1, s_scm_abs
);
836 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
838 "Return the quotient of the numbers @var{x} and @var{y}.")
839 #define FUNC_NAME s_scm_quotient
841 if (SCM_LIKELY (scm_is_integer (x
)))
843 if (SCM_LIKELY (scm_is_integer (y
)))
844 return scm_truncate_quotient (x
, y
);
846 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
849 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
853 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
855 "Return the remainder of the numbers @var{x} and @var{y}.\n"
857 "(remainder 13 4) @result{} 1\n"
858 "(remainder -13 4) @result{} -1\n"
860 #define FUNC_NAME s_scm_remainder
862 if (SCM_LIKELY (scm_is_integer (x
)))
864 if (SCM_LIKELY (scm_is_integer (y
)))
865 return scm_truncate_remainder (x
, y
);
867 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
870 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
875 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
877 "Return the modulo of the numbers @var{x} and @var{y}.\n"
879 "(modulo 13 4) @result{} 1\n"
880 "(modulo -13 4) @result{} 3\n"
882 #define FUNC_NAME s_scm_modulo
884 if (SCM_LIKELY (scm_is_integer (x
)))
886 if (SCM_LIKELY (scm_is_integer (y
)))
887 return scm_floor_remainder (x
, y
);
889 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
892 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
896 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
897 two-valued functions. It is called from primitive generics that take
898 two arguments and return two values, when the core procedure is
899 unable to handle the given argument types. If there are GOOPS
900 methods for this primitive generic, it dispatches to GOOPS and, if
901 successful, expects two values to be returned, which are placed in
902 *rp1 and *rp2. If there are no GOOPS methods, it throws a
903 wrong-type-arg exception.
905 FIXME: This obviously belongs somewhere else, but until we decide on
906 the right API, it is here as a static function, because it is needed
907 by the *_divide functions below.
910 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
911 const char *subr
, SCM
*rp1
, SCM
*rp2
)
913 SCM vals
= scm_wta_dispatch_2 (gf
, a1
, a2
, pos
, subr
);
915 scm_i_extract_values_2 (vals
, rp1
, rp2
);
918 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
920 "Return the integer @var{q} such that\n"
921 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
922 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
924 "(euclidean-quotient 123 10) @result{} 12\n"
925 "(euclidean-quotient 123 -10) @result{} -12\n"
926 "(euclidean-quotient -123 10) @result{} -13\n"
927 "(euclidean-quotient -123 -10) @result{} 13\n"
928 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
929 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
931 #define FUNC_NAME s_scm_euclidean_quotient
933 if (scm_is_false (scm_negative_p (y
)))
934 return scm_floor_quotient (x
, y
);
936 return scm_ceiling_quotient (x
, y
);
940 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
942 "Return the real number @var{r} such that\n"
943 "@math{0 <= @var{r} < abs(@var{y})} and\n"
944 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
945 "for some integer @var{q}.\n"
947 "(euclidean-remainder 123 10) @result{} 3\n"
948 "(euclidean-remainder 123 -10) @result{} 3\n"
949 "(euclidean-remainder -123 10) @result{} 7\n"
950 "(euclidean-remainder -123 -10) @result{} 7\n"
951 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
952 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
954 #define FUNC_NAME s_scm_euclidean_remainder
956 if (scm_is_false (scm_negative_p (y
)))
957 return scm_floor_remainder (x
, y
);
959 return scm_ceiling_remainder (x
, y
);
963 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
965 "Return the integer @var{q} and the real number @var{r}\n"
966 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
967 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
969 "(euclidean/ 123 10) @result{} 12 and 3\n"
970 "(euclidean/ 123 -10) @result{} -12 and 3\n"
971 "(euclidean/ -123 10) @result{} -13 and 7\n"
972 "(euclidean/ -123 -10) @result{} 13 and 7\n"
973 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
974 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
976 #define FUNC_NAME s_scm_i_euclidean_divide
978 if (scm_is_false (scm_negative_p (y
)))
979 return scm_i_floor_divide (x
, y
);
981 return scm_i_ceiling_divide (x
, y
);
986 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
988 if (scm_is_false (scm_negative_p (y
)))
989 return scm_floor_divide (x
, y
, qp
, rp
);
991 return scm_ceiling_divide (x
, y
, qp
, rp
);
994 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
995 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
997 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
999 "Return the floor of @math{@var{x} / @var{y}}.\n"
1001 "(floor-quotient 123 10) @result{} 12\n"
1002 "(floor-quotient 123 -10) @result{} -13\n"
1003 "(floor-quotient -123 10) @result{} -13\n"
1004 "(floor-quotient -123 -10) @result{} 12\n"
1005 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1006 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1008 #define FUNC_NAME s_scm_floor_quotient
1010 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1012 scm_t_inum xx
= SCM_I_INUM (x
);
1013 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1015 scm_t_inum yy
= SCM_I_INUM (y
);
1016 scm_t_inum xx1
= xx
;
1018 if (SCM_LIKELY (yy
> 0))
1020 if (SCM_UNLIKELY (xx
< 0))
1023 else if (SCM_UNLIKELY (yy
== 0))
1024 scm_num_overflow (s_scm_floor_quotient
);
1028 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1029 return SCM_I_MAKINUM (qq
);
1031 return scm_i_inum2big (qq
);
1033 else if (SCM_BIGP (y
))
1035 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1036 scm_remember_upto_here_1 (y
);
1038 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1040 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1042 else if (SCM_REALP (y
))
1043 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1044 else if (SCM_FRACTIONP (y
))
1045 return scm_i_exact_rational_floor_quotient (x
, y
);
1047 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1048 s_scm_floor_quotient
);
1050 else if (SCM_BIGP (x
))
1052 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1054 scm_t_inum yy
= SCM_I_INUM (y
);
1055 if (SCM_UNLIKELY (yy
== 0))
1056 scm_num_overflow (s_scm_floor_quotient
);
1057 else if (SCM_UNLIKELY (yy
== 1))
1061 SCM q
= scm_i_mkbig ();
1063 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1066 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1067 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1069 scm_remember_upto_here_1 (x
);
1070 return scm_i_normbig (q
);
1073 else if (SCM_BIGP (y
))
1075 SCM q
= scm_i_mkbig ();
1076 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1079 scm_remember_upto_here_2 (x
, y
);
1080 return scm_i_normbig (q
);
1082 else if (SCM_REALP (y
))
1083 return scm_i_inexact_floor_quotient
1084 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1085 else if (SCM_FRACTIONP (y
))
1086 return scm_i_exact_rational_floor_quotient (x
, y
);
1088 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1089 s_scm_floor_quotient
);
1091 else if (SCM_REALP (x
))
1093 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1094 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1095 return scm_i_inexact_floor_quotient
1096 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1098 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1099 s_scm_floor_quotient
);
1101 else if (SCM_FRACTIONP (x
))
1104 return scm_i_inexact_floor_quotient
1105 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1106 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1107 return scm_i_exact_rational_floor_quotient (x
, y
);
1109 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1110 s_scm_floor_quotient
);
1113 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1114 s_scm_floor_quotient
);
1119 scm_i_inexact_floor_quotient (double x
, double y
)
1121 if (SCM_UNLIKELY (y
== 0))
1122 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1124 return scm_from_double (floor (x
/ y
));
1128 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1130 return scm_floor_quotient
1131 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1132 scm_product (scm_numerator (y
), scm_denominator (x
)));
1135 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1136 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1138 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1140 "Return the real number @var{r} such that\n"
1141 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1142 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1144 "(floor-remainder 123 10) @result{} 3\n"
1145 "(floor-remainder 123 -10) @result{} -7\n"
1146 "(floor-remainder -123 10) @result{} 7\n"
1147 "(floor-remainder -123 -10) @result{} -3\n"
1148 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1149 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1151 #define FUNC_NAME s_scm_floor_remainder
1153 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1155 scm_t_inum xx
= SCM_I_INUM (x
);
1156 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1158 scm_t_inum yy
= SCM_I_INUM (y
);
1159 if (SCM_UNLIKELY (yy
== 0))
1160 scm_num_overflow (s_scm_floor_remainder
);
1163 scm_t_inum rr
= xx
% yy
;
1164 int needs_adjustment
;
1166 if (SCM_LIKELY (yy
> 0))
1167 needs_adjustment
= (rr
< 0);
1169 needs_adjustment
= (rr
> 0);
1171 if (needs_adjustment
)
1173 return SCM_I_MAKINUM (rr
);
1176 else if (SCM_BIGP (y
))
1178 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1179 scm_remember_upto_here_1 (y
);
1184 SCM r
= scm_i_mkbig ();
1185 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1186 scm_remember_upto_here_1 (y
);
1187 return scm_i_normbig (r
);
1196 SCM r
= scm_i_mkbig ();
1197 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1198 scm_remember_upto_here_1 (y
);
1199 return scm_i_normbig (r
);
1202 else if (SCM_REALP (y
))
1203 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1204 else if (SCM_FRACTIONP (y
))
1205 return scm_i_exact_rational_floor_remainder (x
, y
);
1207 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1208 s_scm_floor_remainder
);
1210 else if (SCM_BIGP (x
))
1212 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1214 scm_t_inum yy
= SCM_I_INUM (y
);
1215 if (SCM_UNLIKELY (yy
== 0))
1216 scm_num_overflow (s_scm_floor_remainder
);
1221 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1223 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1224 scm_remember_upto_here_1 (x
);
1225 return SCM_I_MAKINUM (rr
);
1228 else if (SCM_BIGP (y
))
1230 SCM r
= scm_i_mkbig ();
1231 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1234 scm_remember_upto_here_2 (x
, y
);
1235 return scm_i_normbig (r
);
1237 else if (SCM_REALP (y
))
1238 return scm_i_inexact_floor_remainder
1239 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1240 else if (SCM_FRACTIONP (y
))
1241 return scm_i_exact_rational_floor_remainder (x
, y
);
1243 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1244 s_scm_floor_remainder
);
1246 else if (SCM_REALP (x
))
1248 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1249 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1250 return scm_i_inexact_floor_remainder
1251 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1253 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1254 s_scm_floor_remainder
);
1256 else if (SCM_FRACTIONP (x
))
1259 return scm_i_inexact_floor_remainder
1260 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1261 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1262 return scm_i_exact_rational_floor_remainder (x
, y
);
1264 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1265 s_scm_floor_remainder
);
1268 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1269 s_scm_floor_remainder
);
1274 scm_i_inexact_floor_remainder (double x
, double y
)
1276 /* Although it would be more efficient to use fmod here, we can't
1277 because it would in some cases produce results inconsistent with
1278 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1279 close). In particular, when x is very close to a multiple of y,
1280 then r might be either 0.0 or y, but those two cases must
1281 correspond to different choices of q. If r = 0.0 then q must be
1282 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1283 and remainder chooses the other, it would be bad. */
1284 if (SCM_UNLIKELY (y
== 0))
1285 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1287 return scm_from_double (x
- y
* floor (x
/ y
));
1291 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1293 SCM xd
= scm_denominator (x
);
1294 SCM yd
= scm_denominator (y
);
1295 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1296 scm_product (scm_numerator (y
), xd
));
1297 return scm_divide (r1
, scm_product (xd
, yd
));
1301 static void scm_i_inexact_floor_divide (double x
, double y
,
1303 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1306 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1308 "Return the integer @var{q} and the real number @var{r}\n"
1309 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1310 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1312 "(floor/ 123 10) @result{} 12 and 3\n"
1313 "(floor/ 123 -10) @result{} -13 and -7\n"
1314 "(floor/ -123 10) @result{} -13 and 7\n"
1315 "(floor/ -123 -10) @result{} 12 and -3\n"
1316 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1317 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1319 #define FUNC_NAME s_scm_i_floor_divide
1323 scm_floor_divide(x
, y
, &q
, &r
);
1324 return scm_values (scm_list_2 (q
, r
));
1328 #define s_scm_floor_divide s_scm_i_floor_divide
1329 #define g_scm_floor_divide g_scm_i_floor_divide
1332 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1334 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1336 scm_t_inum xx
= SCM_I_INUM (x
);
1337 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1339 scm_t_inum yy
= SCM_I_INUM (y
);
1340 if (SCM_UNLIKELY (yy
== 0))
1341 scm_num_overflow (s_scm_floor_divide
);
1344 scm_t_inum qq
= xx
/ yy
;
1345 scm_t_inum rr
= xx
% yy
;
1346 int needs_adjustment
;
1348 if (SCM_LIKELY (yy
> 0))
1349 needs_adjustment
= (rr
< 0);
1351 needs_adjustment
= (rr
> 0);
1353 if (needs_adjustment
)
1359 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1360 *qp
= SCM_I_MAKINUM (qq
);
1362 *qp
= scm_i_inum2big (qq
);
1363 *rp
= SCM_I_MAKINUM (rr
);
1367 else if (SCM_BIGP (y
))
1369 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1370 scm_remember_upto_here_1 (y
);
1375 SCM r
= scm_i_mkbig ();
1376 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1377 scm_remember_upto_here_1 (y
);
1378 *qp
= SCM_I_MAKINUM (-1);
1379 *rp
= scm_i_normbig (r
);
1394 SCM r
= scm_i_mkbig ();
1395 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1396 scm_remember_upto_here_1 (y
);
1397 *qp
= SCM_I_MAKINUM (-1);
1398 *rp
= scm_i_normbig (r
);
1402 else if (SCM_REALP (y
))
1403 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1404 else if (SCM_FRACTIONP (y
))
1405 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1407 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1408 s_scm_floor_divide
, qp
, rp
);
1410 else if (SCM_BIGP (x
))
1412 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1414 scm_t_inum yy
= SCM_I_INUM (y
);
1415 if (SCM_UNLIKELY (yy
== 0))
1416 scm_num_overflow (s_scm_floor_divide
);
1419 SCM q
= scm_i_mkbig ();
1420 SCM r
= scm_i_mkbig ();
1422 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1423 SCM_I_BIG_MPZ (x
), yy
);
1426 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1427 SCM_I_BIG_MPZ (x
), -yy
);
1428 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1430 scm_remember_upto_here_1 (x
);
1431 *qp
= scm_i_normbig (q
);
1432 *rp
= scm_i_normbig (r
);
1436 else if (SCM_BIGP (y
))
1438 SCM q
= scm_i_mkbig ();
1439 SCM r
= scm_i_mkbig ();
1440 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1441 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1442 scm_remember_upto_here_2 (x
, y
);
1443 *qp
= scm_i_normbig (q
);
1444 *rp
= scm_i_normbig (r
);
1447 else if (SCM_REALP (y
))
1448 return scm_i_inexact_floor_divide
1449 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1450 else if (SCM_FRACTIONP (y
))
1451 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1453 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1454 s_scm_floor_divide
, qp
, rp
);
1456 else if (SCM_REALP (x
))
1458 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1459 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1460 return scm_i_inexact_floor_divide
1461 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1463 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1464 s_scm_floor_divide
, qp
, rp
);
1466 else if (SCM_FRACTIONP (x
))
1469 return scm_i_inexact_floor_divide
1470 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1471 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1472 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1474 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1475 s_scm_floor_divide
, qp
, rp
);
1478 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1479 s_scm_floor_divide
, qp
, rp
);
1483 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1485 if (SCM_UNLIKELY (y
== 0))
1486 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1489 double q
= floor (x
/ y
);
1490 double r
= x
- q
* y
;
1491 *qp
= scm_from_double (q
);
1492 *rp
= scm_from_double (r
);
1497 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1500 SCM xd
= scm_denominator (x
);
1501 SCM yd
= scm_denominator (y
);
1503 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1504 scm_product (scm_numerator (y
), xd
),
1506 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1509 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1510 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1512 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1514 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1516 "(ceiling-quotient 123 10) @result{} 13\n"
1517 "(ceiling-quotient 123 -10) @result{} -12\n"
1518 "(ceiling-quotient -123 10) @result{} -12\n"
1519 "(ceiling-quotient -123 -10) @result{} 13\n"
1520 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1521 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1523 #define FUNC_NAME s_scm_ceiling_quotient
1525 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1527 scm_t_inum xx
= SCM_I_INUM (x
);
1528 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1530 scm_t_inum yy
= SCM_I_INUM (y
);
1531 if (SCM_UNLIKELY (yy
== 0))
1532 scm_num_overflow (s_scm_ceiling_quotient
);
1535 scm_t_inum xx1
= xx
;
1537 if (SCM_LIKELY (yy
> 0))
1539 if (SCM_LIKELY (xx
>= 0))
1545 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1546 return SCM_I_MAKINUM (qq
);
1548 return scm_i_inum2big (qq
);
1551 else if (SCM_BIGP (y
))
1553 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1554 scm_remember_upto_here_1 (y
);
1555 if (SCM_LIKELY (sign
> 0))
1557 if (SCM_LIKELY (xx
> 0))
1559 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1560 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1561 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1563 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1564 scm_remember_upto_here_1 (y
);
1565 return SCM_I_MAKINUM (-1);
1575 else if (SCM_REALP (y
))
1576 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1577 else if (SCM_FRACTIONP (y
))
1578 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1580 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1581 s_scm_ceiling_quotient
);
1583 else if (SCM_BIGP (x
))
1585 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1587 scm_t_inum yy
= SCM_I_INUM (y
);
1588 if (SCM_UNLIKELY (yy
== 0))
1589 scm_num_overflow (s_scm_ceiling_quotient
);
1590 else if (SCM_UNLIKELY (yy
== 1))
1594 SCM q
= scm_i_mkbig ();
1596 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1599 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1600 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1602 scm_remember_upto_here_1 (x
);
1603 return scm_i_normbig (q
);
1606 else if (SCM_BIGP (y
))
1608 SCM q
= scm_i_mkbig ();
1609 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1612 scm_remember_upto_here_2 (x
, y
);
1613 return scm_i_normbig (q
);
1615 else if (SCM_REALP (y
))
1616 return scm_i_inexact_ceiling_quotient
1617 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1618 else if (SCM_FRACTIONP (y
))
1619 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1621 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1622 s_scm_ceiling_quotient
);
1624 else if (SCM_REALP (x
))
1626 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1627 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1628 return scm_i_inexact_ceiling_quotient
1629 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1631 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1632 s_scm_ceiling_quotient
);
1634 else if (SCM_FRACTIONP (x
))
1637 return scm_i_inexact_ceiling_quotient
1638 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1639 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1640 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1642 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1643 s_scm_ceiling_quotient
);
1646 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1647 s_scm_ceiling_quotient
);
1652 scm_i_inexact_ceiling_quotient (double x
, double y
)
1654 if (SCM_UNLIKELY (y
== 0))
1655 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1657 return scm_from_double (ceil (x
/ y
));
1661 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1663 return scm_ceiling_quotient
1664 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1665 scm_product (scm_numerator (y
), scm_denominator (x
)));
1668 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1669 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1671 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1673 "Return the real number @var{r} such that\n"
1674 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1675 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1677 "(ceiling-remainder 123 10) @result{} -7\n"
1678 "(ceiling-remainder 123 -10) @result{} 3\n"
1679 "(ceiling-remainder -123 10) @result{} -3\n"
1680 "(ceiling-remainder -123 -10) @result{} 7\n"
1681 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1682 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1684 #define FUNC_NAME s_scm_ceiling_remainder
1686 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1688 scm_t_inum xx
= SCM_I_INUM (x
);
1689 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1691 scm_t_inum yy
= SCM_I_INUM (y
);
1692 if (SCM_UNLIKELY (yy
== 0))
1693 scm_num_overflow (s_scm_ceiling_remainder
);
1696 scm_t_inum rr
= xx
% yy
;
1697 int needs_adjustment
;
1699 if (SCM_LIKELY (yy
> 0))
1700 needs_adjustment
= (rr
> 0);
1702 needs_adjustment
= (rr
< 0);
1704 if (needs_adjustment
)
1706 return SCM_I_MAKINUM (rr
);
1709 else if (SCM_BIGP (y
))
1711 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1712 scm_remember_upto_here_1 (y
);
1713 if (SCM_LIKELY (sign
> 0))
1715 if (SCM_LIKELY (xx
> 0))
1717 SCM r
= scm_i_mkbig ();
1718 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1719 scm_remember_upto_here_1 (y
);
1720 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1721 return scm_i_normbig (r
);
1723 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1724 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1725 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1727 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1728 scm_remember_upto_here_1 (y
);
1738 SCM r
= scm_i_mkbig ();
1739 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1740 scm_remember_upto_here_1 (y
);
1741 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1742 return scm_i_normbig (r
);
1745 else if (SCM_REALP (y
))
1746 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1747 else if (SCM_FRACTIONP (y
))
1748 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1750 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1751 s_scm_ceiling_remainder
);
1753 else if (SCM_BIGP (x
))
1755 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1757 scm_t_inum yy
= SCM_I_INUM (y
);
1758 if (SCM_UNLIKELY (yy
== 0))
1759 scm_num_overflow (s_scm_ceiling_remainder
);
1764 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1766 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1767 scm_remember_upto_here_1 (x
);
1768 return SCM_I_MAKINUM (rr
);
1771 else if (SCM_BIGP (y
))
1773 SCM r
= scm_i_mkbig ();
1774 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1777 scm_remember_upto_here_2 (x
, y
);
1778 return scm_i_normbig (r
);
1780 else if (SCM_REALP (y
))
1781 return scm_i_inexact_ceiling_remainder
1782 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1783 else if (SCM_FRACTIONP (y
))
1784 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1786 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1787 s_scm_ceiling_remainder
);
1789 else if (SCM_REALP (x
))
1791 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1792 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1793 return scm_i_inexact_ceiling_remainder
1794 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1796 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1797 s_scm_ceiling_remainder
);
1799 else if (SCM_FRACTIONP (x
))
1802 return scm_i_inexact_ceiling_remainder
1803 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1804 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1805 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1807 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1808 s_scm_ceiling_remainder
);
1811 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1812 s_scm_ceiling_remainder
);
1817 scm_i_inexact_ceiling_remainder (double x
, double y
)
1819 /* Although it would be more efficient to use fmod here, we can't
1820 because it would in some cases produce results inconsistent with
1821 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1822 close). In particular, when x is very close to a multiple of y,
1823 then r might be either 0.0 or -y, but those two cases must
1824 correspond to different choices of q. If r = 0.0 then q must be
1825 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1826 and remainder chooses the other, it would be bad. */
1827 if (SCM_UNLIKELY (y
== 0))
1828 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1830 return scm_from_double (x
- y
* ceil (x
/ y
));
1834 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1836 SCM xd
= scm_denominator (x
);
1837 SCM yd
= scm_denominator (y
);
1838 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1839 scm_product (scm_numerator (y
), xd
));
1840 return scm_divide (r1
, scm_product (xd
, yd
));
1843 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1845 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1848 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1850 "Return the integer @var{q} and the real number @var{r}\n"
1851 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1852 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1854 "(ceiling/ 123 10) @result{} 13 and -7\n"
1855 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1856 "(ceiling/ -123 10) @result{} -12 and -3\n"
1857 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1858 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1859 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1861 #define FUNC_NAME s_scm_i_ceiling_divide
1865 scm_ceiling_divide(x
, y
, &q
, &r
);
1866 return scm_values (scm_list_2 (q
, r
));
1870 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1871 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1874 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1876 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1878 scm_t_inum xx
= SCM_I_INUM (x
);
1879 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1881 scm_t_inum yy
= SCM_I_INUM (y
);
1882 if (SCM_UNLIKELY (yy
== 0))
1883 scm_num_overflow (s_scm_ceiling_divide
);
1886 scm_t_inum qq
= xx
/ yy
;
1887 scm_t_inum rr
= xx
% yy
;
1888 int needs_adjustment
;
1890 if (SCM_LIKELY (yy
> 0))
1891 needs_adjustment
= (rr
> 0);
1893 needs_adjustment
= (rr
< 0);
1895 if (needs_adjustment
)
1900 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1901 *qp
= SCM_I_MAKINUM (qq
);
1903 *qp
= scm_i_inum2big (qq
);
1904 *rp
= SCM_I_MAKINUM (rr
);
1908 else if (SCM_BIGP (y
))
1910 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1911 scm_remember_upto_here_1 (y
);
1912 if (SCM_LIKELY (sign
> 0))
1914 if (SCM_LIKELY (xx
> 0))
1916 SCM r
= scm_i_mkbig ();
1917 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1918 scm_remember_upto_here_1 (y
);
1919 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1921 *rp
= scm_i_normbig (r
);
1923 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1924 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1925 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1927 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1928 scm_remember_upto_here_1 (y
);
1929 *qp
= SCM_I_MAKINUM (-1);
1945 SCM r
= scm_i_mkbig ();
1946 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1947 scm_remember_upto_here_1 (y
);
1948 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1950 *rp
= scm_i_normbig (r
);
1954 else if (SCM_REALP (y
))
1955 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1956 else if (SCM_FRACTIONP (y
))
1957 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1959 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1960 s_scm_ceiling_divide
, qp
, rp
);
1962 else if (SCM_BIGP (x
))
1964 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1966 scm_t_inum yy
= SCM_I_INUM (y
);
1967 if (SCM_UNLIKELY (yy
== 0))
1968 scm_num_overflow (s_scm_ceiling_divide
);
1971 SCM q
= scm_i_mkbig ();
1972 SCM r
= scm_i_mkbig ();
1974 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1975 SCM_I_BIG_MPZ (x
), yy
);
1978 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1979 SCM_I_BIG_MPZ (x
), -yy
);
1980 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1982 scm_remember_upto_here_1 (x
);
1983 *qp
= scm_i_normbig (q
);
1984 *rp
= scm_i_normbig (r
);
1988 else if (SCM_BIGP (y
))
1990 SCM q
= scm_i_mkbig ();
1991 SCM r
= scm_i_mkbig ();
1992 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1993 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1994 scm_remember_upto_here_2 (x
, y
);
1995 *qp
= scm_i_normbig (q
);
1996 *rp
= scm_i_normbig (r
);
1999 else if (SCM_REALP (y
))
2000 return scm_i_inexact_ceiling_divide
2001 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2002 else if (SCM_FRACTIONP (y
))
2003 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2005 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2006 s_scm_ceiling_divide
, qp
, rp
);
2008 else if (SCM_REALP (x
))
2010 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2011 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2012 return scm_i_inexact_ceiling_divide
2013 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2015 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2016 s_scm_ceiling_divide
, qp
, rp
);
2018 else if (SCM_FRACTIONP (x
))
2021 return scm_i_inexact_ceiling_divide
2022 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2023 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2024 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
2026 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
2027 s_scm_ceiling_divide
, qp
, rp
);
2030 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2031 s_scm_ceiling_divide
, qp
, rp
);
2035 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2037 if (SCM_UNLIKELY (y
== 0))
2038 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2041 double q
= ceil (x
/ y
);
2042 double r
= x
- q
* y
;
2043 *qp
= scm_from_double (q
);
2044 *rp
= scm_from_double (r
);
2049 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2052 SCM xd
= scm_denominator (x
);
2053 SCM yd
= scm_denominator (y
);
2055 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2056 scm_product (scm_numerator (y
), xd
),
2058 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2061 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2062 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2064 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2066 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2068 "(truncate-quotient 123 10) @result{} 12\n"
2069 "(truncate-quotient 123 -10) @result{} -12\n"
2070 "(truncate-quotient -123 10) @result{} -12\n"
2071 "(truncate-quotient -123 -10) @result{} 12\n"
2072 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2073 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2075 #define FUNC_NAME s_scm_truncate_quotient
2077 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2079 scm_t_inum xx
= SCM_I_INUM (x
);
2080 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2082 scm_t_inum yy
= SCM_I_INUM (y
);
2083 if (SCM_UNLIKELY (yy
== 0))
2084 scm_num_overflow (s_scm_truncate_quotient
);
2087 scm_t_inum qq
= xx
/ yy
;
2088 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2089 return SCM_I_MAKINUM (qq
);
2091 return scm_i_inum2big (qq
);
2094 else if (SCM_BIGP (y
))
2096 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2097 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2098 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2100 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2101 scm_remember_upto_here_1 (y
);
2102 return SCM_I_MAKINUM (-1);
2107 else if (SCM_REALP (y
))
2108 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2109 else if (SCM_FRACTIONP (y
))
2110 return scm_i_exact_rational_truncate_quotient (x
, y
);
2112 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2113 s_scm_truncate_quotient
);
2115 else if (SCM_BIGP (x
))
2117 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2119 scm_t_inum yy
= SCM_I_INUM (y
);
2120 if (SCM_UNLIKELY (yy
== 0))
2121 scm_num_overflow (s_scm_truncate_quotient
);
2122 else if (SCM_UNLIKELY (yy
== 1))
2126 SCM q
= scm_i_mkbig ();
2128 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2131 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2132 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2134 scm_remember_upto_here_1 (x
);
2135 return scm_i_normbig (q
);
2138 else if (SCM_BIGP (y
))
2140 SCM q
= scm_i_mkbig ();
2141 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2144 scm_remember_upto_here_2 (x
, y
);
2145 return scm_i_normbig (q
);
2147 else if (SCM_REALP (y
))
2148 return scm_i_inexact_truncate_quotient
2149 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2150 else if (SCM_FRACTIONP (y
))
2151 return scm_i_exact_rational_truncate_quotient (x
, y
);
2153 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2154 s_scm_truncate_quotient
);
2156 else if (SCM_REALP (x
))
2158 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2159 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2160 return scm_i_inexact_truncate_quotient
2161 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2163 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2164 s_scm_truncate_quotient
);
2166 else if (SCM_FRACTIONP (x
))
2169 return scm_i_inexact_truncate_quotient
2170 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2171 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2172 return scm_i_exact_rational_truncate_quotient (x
, y
);
2174 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2175 s_scm_truncate_quotient
);
2178 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2179 s_scm_truncate_quotient
);
2184 scm_i_inexact_truncate_quotient (double x
, double y
)
2186 if (SCM_UNLIKELY (y
== 0))
2187 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2189 return scm_from_double (trunc (x
/ y
));
2193 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2195 return scm_truncate_quotient
2196 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2197 scm_product (scm_numerator (y
), scm_denominator (x
)));
2200 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2201 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2203 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2205 "Return the real number @var{r} such that\n"
2206 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2207 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2209 "(truncate-remainder 123 10) @result{} 3\n"
2210 "(truncate-remainder 123 -10) @result{} 3\n"
2211 "(truncate-remainder -123 10) @result{} -3\n"
2212 "(truncate-remainder -123 -10) @result{} -3\n"
2213 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2214 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2216 #define FUNC_NAME s_scm_truncate_remainder
2218 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2220 scm_t_inum xx
= SCM_I_INUM (x
);
2221 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2223 scm_t_inum yy
= SCM_I_INUM (y
);
2224 if (SCM_UNLIKELY (yy
== 0))
2225 scm_num_overflow (s_scm_truncate_remainder
);
2227 return SCM_I_MAKINUM (xx
% yy
);
2229 else if (SCM_BIGP (y
))
2231 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2232 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2233 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2235 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2236 scm_remember_upto_here_1 (y
);
2242 else if (SCM_REALP (y
))
2243 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2244 else if (SCM_FRACTIONP (y
))
2245 return scm_i_exact_rational_truncate_remainder (x
, y
);
2247 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2248 s_scm_truncate_remainder
);
2250 else if (SCM_BIGP (x
))
2252 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2254 scm_t_inum yy
= SCM_I_INUM (y
);
2255 if (SCM_UNLIKELY (yy
== 0))
2256 scm_num_overflow (s_scm_truncate_remainder
);
2259 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2260 (yy
> 0) ? yy
: -yy
)
2261 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2262 scm_remember_upto_here_1 (x
);
2263 return SCM_I_MAKINUM (rr
);
2266 else if (SCM_BIGP (y
))
2268 SCM r
= scm_i_mkbig ();
2269 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2272 scm_remember_upto_here_2 (x
, y
);
2273 return scm_i_normbig (r
);
2275 else if (SCM_REALP (y
))
2276 return scm_i_inexact_truncate_remainder
2277 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2278 else if (SCM_FRACTIONP (y
))
2279 return scm_i_exact_rational_truncate_remainder (x
, y
);
2281 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2282 s_scm_truncate_remainder
);
2284 else if (SCM_REALP (x
))
2286 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2287 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2288 return scm_i_inexact_truncate_remainder
2289 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2291 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2292 s_scm_truncate_remainder
);
2294 else if (SCM_FRACTIONP (x
))
2297 return scm_i_inexact_truncate_remainder
2298 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2299 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2300 return scm_i_exact_rational_truncate_remainder (x
, y
);
2302 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2303 s_scm_truncate_remainder
);
2306 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2307 s_scm_truncate_remainder
);
2312 scm_i_inexact_truncate_remainder (double x
, double y
)
2314 /* Although it would be more efficient to use fmod here, we can't
2315 because it would in some cases produce results inconsistent with
2316 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2317 close). In particular, when x is very close to a multiple of y,
2318 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2319 correspond to different choices of q. If quotient chooses one and
2320 remainder chooses the other, it would be bad. */
2321 if (SCM_UNLIKELY (y
== 0))
2322 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2324 return scm_from_double (x
- y
* trunc (x
/ y
));
2328 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2330 SCM xd
= scm_denominator (x
);
2331 SCM yd
= scm_denominator (y
);
2332 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2333 scm_product (scm_numerator (y
), xd
));
2334 return scm_divide (r1
, scm_product (xd
, yd
));
2338 static void scm_i_inexact_truncate_divide (double x
, double y
,
2340 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2343 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2345 "Return the integer @var{q} and the real number @var{r}\n"
2346 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2347 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2349 "(truncate/ 123 10) @result{} 12 and 3\n"
2350 "(truncate/ 123 -10) @result{} -12 and 3\n"
2351 "(truncate/ -123 10) @result{} -12 and -3\n"
2352 "(truncate/ -123 -10) @result{} 12 and -3\n"
2353 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2354 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2356 #define FUNC_NAME s_scm_i_truncate_divide
2360 scm_truncate_divide(x
, y
, &q
, &r
);
2361 return scm_values (scm_list_2 (q
, r
));
2365 #define s_scm_truncate_divide s_scm_i_truncate_divide
2366 #define g_scm_truncate_divide g_scm_i_truncate_divide
2369 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2371 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2373 scm_t_inum xx
= SCM_I_INUM (x
);
2374 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2376 scm_t_inum yy
= SCM_I_INUM (y
);
2377 if (SCM_UNLIKELY (yy
== 0))
2378 scm_num_overflow (s_scm_truncate_divide
);
2381 scm_t_inum qq
= xx
/ yy
;
2382 scm_t_inum rr
= xx
% yy
;
2383 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2384 *qp
= SCM_I_MAKINUM (qq
);
2386 *qp
= scm_i_inum2big (qq
);
2387 *rp
= SCM_I_MAKINUM (rr
);
2391 else if (SCM_BIGP (y
))
2393 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2394 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2395 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2397 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2398 scm_remember_upto_here_1 (y
);
2399 *qp
= SCM_I_MAKINUM (-1);
2409 else if (SCM_REALP (y
))
2410 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2411 else if (SCM_FRACTIONP (y
))
2412 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2414 return two_valued_wta_dispatch_2
2415 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2416 s_scm_truncate_divide
, qp
, rp
);
2418 else if (SCM_BIGP (x
))
2420 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2422 scm_t_inum yy
= SCM_I_INUM (y
);
2423 if (SCM_UNLIKELY (yy
== 0))
2424 scm_num_overflow (s_scm_truncate_divide
);
2427 SCM q
= scm_i_mkbig ();
2430 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2431 SCM_I_BIG_MPZ (x
), yy
);
2434 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2435 SCM_I_BIG_MPZ (x
), -yy
);
2436 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2438 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2439 scm_remember_upto_here_1 (x
);
2440 *qp
= scm_i_normbig (q
);
2441 *rp
= SCM_I_MAKINUM (rr
);
2445 else if (SCM_BIGP (y
))
2447 SCM q
= scm_i_mkbig ();
2448 SCM r
= scm_i_mkbig ();
2449 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2450 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2451 scm_remember_upto_here_2 (x
, y
);
2452 *qp
= scm_i_normbig (q
);
2453 *rp
= scm_i_normbig (r
);
2455 else if (SCM_REALP (y
))
2456 return scm_i_inexact_truncate_divide
2457 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2458 else if (SCM_FRACTIONP (y
))
2459 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2461 return two_valued_wta_dispatch_2
2462 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2463 s_scm_truncate_divide
, qp
, rp
);
2465 else if (SCM_REALP (x
))
2467 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2468 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2469 return scm_i_inexact_truncate_divide
2470 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2472 return two_valued_wta_dispatch_2
2473 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2474 s_scm_truncate_divide
, qp
, rp
);
2476 else if (SCM_FRACTIONP (x
))
2479 return scm_i_inexact_truncate_divide
2480 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2481 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2482 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2484 return two_valued_wta_dispatch_2
2485 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2486 s_scm_truncate_divide
, qp
, rp
);
2489 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2490 s_scm_truncate_divide
, qp
, rp
);
2494 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2496 if (SCM_UNLIKELY (y
== 0))
2497 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2500 double q
= trunc (x
/ y
);
2501 double r
= x
- q
* y
;
2502 *qp
= scm_from_double (q
);
2503 *rp
= scm_from_double (r
);
2508 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2511 SCM xd
= scm_denominator (x
);
2512 SCM yd
= scm_denominator (y
);
2514 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2515 scm_product (scm_numerator (y
), xd
),
2517 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2520 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2521 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2522 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2524 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2526 "Return the integer @var{q} such that\n"
2527 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2528 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2530 "(centered-quotient 123 10) @result{} 12\n"
2531 "(centered-quotient 123 -10) @result{} -12\n"
2532 "(centered-quotient -123 10) @result{} -12\n"
2533 "(centered-quotient -123 -10) @result{} 12\n"
2534 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2535 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2537 #define FUNC_NAME s_scm_centered_quotient
2539 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2541 scm_t_inum xx
= SCM_I_INUM (x
);
2542 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2544 scm_t_inum yy
= SCM_I_INUM (y
);
2545 if (SCM_UNLIKELY (yy
== 0))
2546 scm_num_overflow (s_scm_centered_quotient
);
2549 scm_t_inum qq
= xx
/ yy
;
2550 scm_t_inum rr
= xx
% yy
;
2551 if (SCM_LIKELY (xx
> 0))
2553 if (SCM_LIKELY (yy
> 0))
2555 if (rr
>= (yy
+ 1) / 2)
2560 if (rr
>= (1 - yy
) / 2)
2566 if (SCM_LIKELY (yy
> 0))
2577 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2578 return SCM_I_MAKINUM (qq
);
2580 return scm_i_inum2big (qq
);
2583 else if (SCM_BIGP (y
))
2585 /* Pass a denormalized bignum version of x (even though it
2586 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2587 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2589 else if (SCM_REALP (y
))
2590 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2591 else if (SCM_FRACTIONP (y
))
2592 return scm_i_exact_rational_centered_quotient (x
, y
);
2594 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2595 s_scm_centered_quotient
);
2597 else if (SCM_BIGP (x
))
2599 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2601 scm_t_inum yy
= SCM_I_INUM (y
);
2602 if (SCM_UNLIKELY (yy
== 0))
2603 scm_num_overflow (s_scm_centered_quotient
);
2604 else if (SCM_UNLIKELY (yy
== 1))
2608 SCM q
= scm_i_mkbig ();
2610 /* Arrange for rr to initially be non-positive,
2611 because that simplifies the test to see
2612 if it is within the needed bounds. */
2615 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2616 SCM_I_BIG_MPZ (x
), yy
);
2617 scm_remember_upto_here_1 (x
);
2619 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2620 SCM_I_BIG_MPZ (q
), 1);
2624 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2625 SCM_I_BIG_MPZ (x
), -yy
);
2626 scm_remember_upto_here_1 (x
);
2627 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2629 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2630 SCM_I_BIG_MPZ (q
), 1);
2632 return scm_i_normbig (q
);
2635 else if (SCM_BIGP (y
))
2636 return scm_i_bigint_centered_quotient (x
, y
);
2637 else if (SCM_REALP (y
))
2638 return scm_i_inexact_centered_quotient
2639 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2640 else if (SCM_FRACTIONP (y
))
2641 return scm_i_exact_rational_centered_quotient (x
, y
);
2643 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2644 s_scm_centered_quotient
);
2646 else if (SCM_REALP (x
))
2648 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2649 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2650 return scm_i_inexact_centered_quotient
2651 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2653 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2654 s_scm_centered_quotient
);
2656 else if (SCM_FRACTIONP (x
))
2659 return scm_i_inexact_centered_quotient
2660 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2661 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2662 return scm_i_exact_rational_centered_quotient (x
, y
);
2664 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2665 s_scm_centered_quotient
);
2668 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2669 s_scm_centered_quotient
);
2674 scm_i_inexact_centered_quotient (double x
, double y
)
2676 if (SCM_LIKELY (y
> 0))
2677 return scm_from_double (floor (x
/y
+ 0.5));
2678 else if (SCM_LIKELY (y
< 0))
2679 return scm_from_double (ceil (x
/y
- 0.5));
2681 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2686 /* Assumes that both x and y are bigints, though
2687 x might be able to fit into a fixnum. */
2689 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2693 /* Note that x might be small enough to fit into a
2694 fixnum, so we must not let it escape into the wild */
2698 /* min_r will eventually become -abs(y)/2 */
2699 min_r
= scm_i_mkbig ();
2700 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2701 SCM_I_BIG_MPZ (y
), 1);
2703 /* Arrange for rr to initially be non-positive,
2704 because that simplifies the test to see
2705 if it is within the needed bounds. */
2706 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2708 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2709 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2710 scm_remember_upto_here_2 (x
, y
);
2711 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2712 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2713 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2714 SCM_I_BIG_MPZ (q
), 1);
2718 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2719 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2720 scm_remember_upto_here_2 (x
, y
);
2721 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2722 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2723 SCM_I_BIG_MPZ (q
), 1);
2725 scm_remember_upto_here_2 (r
, min_r
);
2726 return scm_i_normbig (q
);
2730 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2732 return scm_centered_quotient
2733 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2734 scm_product (scm_numerator (y
), scm_denominator (x
)));
2737 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2738 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2739 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2741 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2743 "Return the real number @var{r} such that\n"
2744 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2745 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2746 "for some integer @var{q}.\n"
2748 "(centered-remainder 123 10) @result{} 3\n"
2749 "(centered-remainder 123 -10) @result{} 3\n"
2750 "(centered-remainder -123 10) @result{} -3\n"
2751 "(centered-remainder -123 -10) @result{} -3\n"
2752 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2753 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2755 #define FUNC_NAME s_scm_centered_remainder
2757 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2759 scm_t_inum xx
= SCM_I_INUM (x
);
2760 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2762 scm_t_inum yy
= SCM_I_INUM (y
);
2763 if (SCM_UNLIKELY (yy
== 0))
2764 scm_num_overflow (s_scm_centered_remainder
);
2767 scm_t_inum rr
= xx
% yy
;
2768 if (SCM_LIKELY (xx
> 0))
2770 if (SCM_LIKELY (yy
> 0))
2772 if (rr
>= (yy
+ 1) / 2)
2777 if (rr
>= (1 - yy
) / 2)
2783 if (SCM_LIKELY (yy
> 0))
2794 return SCM_I_MAKINUM (rr
);
2797 else if (SCM_BIGP (y
))
2799 /* Pass a denormalized bignum version of x (even though it
2800 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2801 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2803 else if (SCM_REALP (y
))
2804 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2805 else if (SCM_FRACTIONP (y
))
2806 return scm_i_exact_rational_centered_remainder (x
, y
);
2808 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2809 s_scm_centered_remainder
);
2811 else if (SCM_BIGP (x
))
2813 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2815 scm_t_inum yy
= SCM_I_INUM (y
);
2816 if (SCM_UNLIKELY (yy
== 0))
2817 scm_num_overflow (s_scm_centered_remainder
);
2821 /* Arrange for rr to initially be non-positive,
2822 because that simplifies the test to see
2823 if it is within the needed bounds. */
2826 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2827 scm_remember_upto_here_1 (x
);
2833 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2834 scm_remember_upto_here_1 (x
);
2838 return SCM_I_MAKINUM (rr
);
2841 else if (SCM_BIGP (y
))
2842 return scm_i_bigint_centered_remainder (x
, y
);
2843 else if (SCM_REALP (y
))
2844 return scm_i_inexact_centered_remainder
2845 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2846 else if (SCM_FRACTIONP (y
))
2847 return scm_i_exact_rational_centered_remainder (x
, y
);
2849 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2850 s_scm_centered_remainder
);
2852 else if (SCM_REALP (x
))
2854 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2855 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2856 return scm_i_inexact_centered_remainder
2857 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2859 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2860 s_scm_centered_remainder
);
2862 else if (SCM_FRACTIONP (x
))
2865 return scm_i_inexact_centered_remainder
2866 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2867 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2868 return scm_i_exact_rational_centered_remainder (x
, y
);
2870 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2871 s_scm_centered_remainder
);
2874 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2875 s_scm_centered_remainder
);
2880 scm_i_inexact_centered_remainder (double x
, double y
)
2884 /* Although it would be more efficient to use fmod here, we can't
2885 because it would in some cases produce results inconsistent with
2886 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2887 close). In particular, when x-y/2 is very close to a multiple of
2888 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2889 two cases must correspond to different choices of q. If quotient
2890 chooses one and remainder chooses the other, it would be bad. */
2891 if (SCM_LIKELY (y
> 0))
2892 q
= floor (x
/y
+ 0.5);
2893 else if (SCM_LIKELY (y
< 0))
2894 q
= ceil (x
/y
- 0.5);
2896 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2899 return scm_from_double (x
- q
* y
);
2902 /* Assumes that both x and y are bigints, though
2903 x might be able to fit into a fixnum. */
2905 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2909 /* Note that x might be small enough to fit into a
2910 fixnum, so we must not let it escape into the wild */
2913 /* min_r will eventually become -abs(y)/2 */
2914 min_r
= scm_i_mkbig ();
2915 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2916 SCM_I_BIG_MPZ (y
), 1);
2918 /* Arrange for rr to initially be non-positive,
2919 because that simplifies the test to see
2920 if it is within the needed bounds. */
2921 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2923 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2924 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2925 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2926 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2927 mpz_add (SCM_I_BIG_MPZ (r
),
2933 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2934 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2935 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2936 mpz_sub (SCM_I_BIG_MPZ (r
),
2940 scm_remember_upto_here_2 (x
, y
);
2941 return scm_i_normbig (r
);
2945 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2947 SCM xd
= scm_denominator (x
);
2948 SCM yd
= scm_denominator (y
);
2949 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2950 scm_product (scm_numerator (y
), xd
));
2951 return scm_divide (r1
, scm_product (xd
, yd
));
2955 static void scm_i_inexact_centered_divide (double x
, double y
,
2957 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2958 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2961 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2963 "Return the integer @var{q} and the real number @var{r}\n"
2964 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2965 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2967 "(centered/ 123 10) @result{} 12 and 3\n"
2968 "(centered/ 123 -10) @result{} -12 and 3\n"
2969 "(centered/ -123 10) @result{} -12 and -3\n"
2970 "(centered/ -123 -10) @result{} 12 and -3\n"
2971 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2972 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2974 #define FUNC_NAME s_scm_i_centered_divide
2978 scm_centered_divide(x
, y
, &q
, &r
);
2979 return scm_values (scm_list_2 (q
, r
));
2983 #define s_scm_centered_divide s_scm_i_centered_divide
2984 #define g_scm_centered_divide g_scm_i_centered_divide
2987 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2989 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2991 scm_t_inum xx
= SCM_I_INUM (x
);
2992 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2994 scm_t_inum yy
= SCM_I_INUM (y
);
2995 if (SCM_UNLIKELY (yy
== 0))
2996 scm_num_overflow (s_scm_centered_divide
);
2999 scm_t_inum qq
= xx
/ yy
;
3000 scm_t_inum rr
= xx
% yy
;
3001 if (SCM_LIKELY (xx
> 0))
3003 if (SCM_LIKELY (yy
> 0))
3005 if (rr
>= (yy
+ 1) / 2)
3010 if (rr
>= (1 - yy
) / 2)
3016 if (SCM_LIKELY (yy
> 0))
3027 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3028 *qp
= SCM_I_MAKINUM (qq
);
3030 *qp
= scm_i_inum2big (qq
);
3031 *rp
= SCM_I_MAKINUM (rr
);
3035 else if (SCM_BIGP (y
))
3037 /* Pass a denormalized bignum version of x (even though it
3038 can fit in a fixnum) to scm_i_bigint_centered_divide */
3039 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3041 else if (SCM_REALP (y
))
3042 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3043 else if (SCM_FRACTIONP (y
))
3044 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3046 return two_valued_wta_dispatch_2
3047 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3048 s_scm_centered_divide
, qp
, rp
);
3050 else if (SCM_BIGP (x
))
3052 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3054 scm_t_inum yy
= SCM_I_INUM (y
);
3055 if (SCM_UNLIKELY (yy
== 0))
3056 scm_num_overflow (s_scm_centered_divide
);
3059 SCM q
= scm_i_mkbig ();
3061 /* Arrange for rr to initially be non-positive,
3062 because that simplifies the test to see
3063 if it is within the needed bounds. */
3066 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3067 SCM_I_BIG_MPZ (x
), yy
);
3068 scm_remember_upto_here_1 (x
);
3071 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3072 SCM_I_BIG_MPZ (q
), 1);
3078 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3079 SCM_I_BIG_MPZ (x
), -yy
);
3080 scm_remember_upto_here_1 (x
);
3081 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3084 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3085 SCM_I_BIG_MPZ (q
), 1);
3089 *qp
= scm_i_normbig (q
);
3090 *rp
= SCM_I_MAKINUM (rr
);
3094 else if (SCM_BIGP (y
))
3095 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3096 else if (SCM_REALP (y
))
3097 return scm_i_inexact_centered_divide
3098 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3099 else if (SCM_FRACTIONP (y
))
3100 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3102 return two_valued_wta_dispatch_2
3103 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3104 s_scm_centered_divide
, qp
, rp
);
3106 else if (SCM_REALP (x
))
3108 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3109 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3110 return scm_i_inexact_centered_divide
3111 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3113 return two_valued_wta_dispatch_2
3114 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3115 s_scm_centered_divide
, qp
, rp
);
3117 else if (SCM_FRACTIONP (x
))
3120 return scm_i_inexact_centered_divide
3121 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3122 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3123 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3125 return two_valued_wta_dispatch_2
3126 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3127 s_scm_centered_divide
, qp
, rp
);
3130 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3131 s_scm_centered_divide
, qp
, rp
);
3135 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3139 if (SCM_LIKELY (y
> 0))
3140 q
= floor (x
/y
+ 0.5);
3141 else if (SCM_LIKELY (y
< 0))
3142 q
= ceil (x
/y
- 0.5);
3144 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3148 *qp
= scm_from_double (q
);
3149 *rp
= scm_from_double (r
);
3152 /* Assumes that both x and y are bigints, though
3153 x might be able to fit into a fixnum. */
3155 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3159 /* Note that x might be small enough to fit into a
3160 fixnum, so we must not let it escape into the wild */
3164 /* min_r will eventually become -abs(y/2) */
3165 min_r
= scm_i_mkbig ();
3166 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3167 SCM_I_BIG_MPZ (y
), 1);
3169 /* Arrange for rr to initially be non-positive,
3170 because that simplifies the test to see
3171 if it is within the needed bounds. */
3172 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3174 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3175 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3176 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3177 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3179 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3180 SCM_I_BIG_MPZ (q
), 1);
3181 mpz_add (SCM_I_BIG_MPZ (r
),
3188 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3189 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3190 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3192 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3193 SCM_I_BIG_MPZ (q
), 1);
3194 mpz_sub (SCM_I_BIG_MPZ (r
),
3199 scm_remember_upto_here_2 (x
, y
);
3200 *qp
= scm_i_normbig (q
);
3201 *rp
= scm_i_normbig (r
);
3205 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3208 SCM xd
= scm_denominator (x
);
3209 SCM yd
= scm_denominator (y
);
3211 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3212 scm_product (scm_numerator (y
), xd
),
3214 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3217 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3218 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3219 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3221 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3223 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3224 "with ties going to the nearest even integer.\n"
3226 "(round-quotient 123 10) @result{} 12\n"
3227 "(round-quotient 123 -10) @result{} -12\n"
3228 "(round-quotient -123 10) @result{} -12\n"
3229 "(round-quotient -123 -10) @result{} 12\n"
3230 "(round-quotient 125 10) @result{} 12\n"
3231 "(round-quotient 127 10) @result{} 13\n"
3232 "(round-quotient 135 10) @result{} 14\n"
3233 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3234 "(round-quotient 16/3 -10/7) @result{} -4\n"
3236 #define FUNC_NAME s_scm_round_quotient
3238 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3240 scm_t_inum xx
= SCM_I_INUM (x
);
3241 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3243 scm_t_inum yy
= SCM_I_INUM (y
);
3244 if (SCM_UNLIKELY (yy
== 0))
3245 scm_num_overflow (s_scm_round_quotient
);
3248 scm_t_inum qq
= xx
/ yy
;
3249 scm_t_inum rr
= xx
% yy
;
3251 scm_t_inum r2
= 2 * rr
;
3253 if (SCM_LIKELY (yy
< 0))
3273 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3274 return SCM_I_MAKINUM (qq
);
3276 return scm_i_inum2big (qq
);
3279 else if (SCM_BIGP (y
))
3281 /* Pass a denormalized bignum version of x (even though it
3282 can fit in a fixnum) to scm_i_bigint_round_quotient */
3283 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3285 else if (SCM_REALP (y
))
3286 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3287 else if (SCM_FRACTIONP (y
))
3288 return scm_i_exact_rational_round_quotient (x
, y
);
3290 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3291 s_scm_round_quotient
);
3293 else if (SCM_BIGP (x
))
3295 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3297 scm_t_inum yy
= SCM_I_INUM (y
);
3298 if (SCM_UNLIKELY (yy
== 0))
3299 scm_num_overflow (s_scm_round_quotient
);
3300 else if (SCM_UNLIKELY (yy
== 1))
3304 SCM q
= scm_i_mkbig ();
3306 int needs_adjustment
;
3310 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3311 SCM_I_BIG_MPZ (x
), yy
);
3312 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3313 needs_adjustment
= (2*rr
>= yy
);
3315 needs_adjustment
= (2*rr
> yy
);
3319 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3320 SCM_I_BIG_MPZ (x
), -yy
);
3321 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3322 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3323 needs_adjustment
= (2*rr
<= yy
);
3325 needs_adjustment
= (2*rr
< yy
);
3327 scm_remember_upto_here_1 (x
);
3328 if (needs_adjustment
)
3329 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3330 return scm_i_normbig (q
);
3333 else if (SCM_BIGP (y
))
3334 return scm_i_bigint_round_quotient (x
, y
);
3335 else if (SCM_REALP (y
))
3336 return scm_i_inexact_round_quotient
3337 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3338 else if (SCM_FRACTIONP (y
))
3339 return scm_i_exact_rational_round_quotient (x
, y
);
3341 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3342 s_scm_round_quotient
);
3344 else if (SCM_REALP (x
))
3346 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3347 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3348 return scm_i_inexact_round_quotient
3349 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3351 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3352 s_scm_round_quotient
);
3354 else if (SCM_FRACTIONP (x
))
3357 return scm_i_inexact_round_quotient
3358 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3359 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3360 return scm_i_exact_rational_round_quotient (x
, y
);
3362 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3363 s_scm_round_quotient
);
3366 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3367 s_scm_round_quotient
);
3372 scm_i_inexact_round_quotient (double x
, double y
)
3374 if (SCM_UNLIKELY (y
== 0))
3375 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3377 return scm_from_double (scm_c_round (x
/ y
));
3380 /* Assumes that both x and y are bigints, though
3381 x might be able to fit into a fixnum. */
3383 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3386 int cmp
, needs_adjustment
;
3388 /* Note that x might be small enough to fit into a
3389 fixnum, so we must not let it escape into the wild */
3392 r2
= scm_i_mkbig ();
3394 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3395 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3396 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3397 scm_remember_upto_here_2 (x
, r
);
3399 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3400 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3401 needs_adjustment
= (cmp
>= 0);
3403 needs_adjustment
= (cmp
> 0);
3404 scm_remember_upto_here_2 (r2
, y
);
3406 if (needs_adjustment
)
3407 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3409 return scm_i_normbig (q
);
3413 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3415 return scm_round_quotient
3416 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3417 scm_product (scm_numerator (y
), scm_denominator (x
)));
3420 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3421 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3422 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3424 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3426 "Return the real number @var{r} such that\n"
3427 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3428 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3429 "nearest integer, with ties going to the nearest\n"
3432 "(round-remainder 123 10) @result{} 3\n"
3433 "(round-remainder 123 -10) @result{} 3\n"
3434 "(round-remainder -123 10) @result{} -3\n"
3435 "(round-remainder -123 -10) @result{} -3\n"
3436 "(round-remainder 125 10) @result{} 5\n"
3437 "(round-remainder 127 10) @result{} -3\n"
3438 "(round-remainder 135 10) @result{} -5\n"
3439 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3440 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3442 #define FUNC_NAME s_scm_round_remainder
3444 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3446 scm_t_inum xx
= SCM_I_INUM (x
);
3447 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3449 scm_t_inum yy
= SCM_I_INUM (y
);
3450 if (SCM_UNLIKELY (yy
== 0))
3451 scm_num_overflow (s_scm_round_remainder
);
3454 scm_t_inum qq
= xx
/ yy
;
3455 scm_t_inum rr
= xx
% yy
;
3457 scm_t_inum r2
= 2 * rr
;
3459 if (SCM_LIKELY (yy
< 0))
3479 return SCM_I_MAKINUM (rr
);
3482 else if (SCM_BIGP (y
))
3484 /* Pass a denormalized bignum version of x (even though it
3485 can fit in a fixnum) to scm_i_bigint_round_remainder */
3486 return scm_i_bigint_round_remainder
3487 (scm_i_long2big (xx
), y
);
3489 else if (SCM_REALP (y
))
3490 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3491 else if (SCM_FRACTIONP (y
))
3492 return scm_i_exact_rational_round_remainder (x
, y
);
3494 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3495 s_scm_round_remainder
);
3497 else if (SCM_BIGP (x
))
3499 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3501 scm_t_inum yy
= SCM_I_INUM (y
);
3502 if (SCM_UNLIKELY (yy
== 0))
3503 scm_num_overflow (s_scm_round_remainder
);
3506 SCM q
= scm_i_mkbig ();
3508 int needs_adjustment
;
3512 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3513 SCM_I_BIG_MPZ (x
), yy
);
3514 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3515 needs_adjustment
= (2*rr
>= yy
);
3517 needs_adjustment
= (2*rr
> yy
);
3521 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3522 SCM_I_BIG_MPZ (x
), -yy
);
3523 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3524 needs_adjustment
= (2*rr
<= yy
);
3526 needs_adjustment
= (2*rr
< yy
);
3528 scm_remember_upto_here_2 (x
, q
);
3529 if (needs_adjustment
)
3531 return SCM_I_MAKINUM (rr
);
3534 else if (SCM_BIGP (y
))
3535 return scm_i_bigint_round_remainder (x
, y
);
3536 else if (SCM_REALP (y
))
3537 return scm_i_inexact_round_remainder
3538 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3539 else if (SCM_FRACTIONP (y
))
3540 return scm_i_exact_rational_round_remainder (x
, y
);
3542 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3543 s_scm_round_remainder
);
3545 else if (SCM_REALP (x
))
3547 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3548 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3549 return scm_i_inexact_round_remainder
3550 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3552 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3553 s_scm_round_remainder
);
3555 else if (SCM_FRACTIONP (x
))
3558 return scm_i_inexact_round_remainder
3559 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3560 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3561 return scm_i_exact_rational_round_remainder (x
, y
);
3563 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3564 s_scm_round_remainder
);
3567 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3568 s_scm_round_remainder
);
3573 scm_i_inexact_round_remainder (double x
, double y
)
3575 /* Although it would be more efficient to use fmod here, we can't
3576 because it would in some cases produce results inconsistent with
3577 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3578 close). In particular, when x-y/2 is very close to a multiple of
3579 y, then r might be either -abs(y/2) or abs(y/2), but those two
3580 cases must correspond to different choices of q. If quotient
3581 chooses one and remainder chooses the other, it would be bad. */
3583 if (SCM_UNLIKELY (y
== 0))
3584 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3587 double q
= scm_c_round (x
/ y
);
3588 return scm_from_double (x
- q
* y
);
3592 /* Assumes that both x and y are bigints, though
3593 x might be able to fit into a fixnum. */
3595 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3598 int cmp
, needs_adjustment
;
3600 /* Note that x might be small enough to fit into a
3601 fixnum, so we must not let it escape into the wild */
3604 r2
= scm_i_mkbig ();
3606 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3607 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3608 scm_remember_upto_here_1 (x
);
3609 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3611 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3612 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3613 needs_adjustment
= (cmp
>= 0);
3615 needs_adjustment
= (cmp
> 0);
3616 scm_remember_upto_here_2 (q
, r2
);
3618 if (needs_adjustment
)
3619 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3621 scm_remember_upto_here_1 (y
);
3622 return scm_i_normbig (r
);
3626 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3628 SCM xd
= scm_denominator (x
);
3629 SCM yd
= scm_denominator (y
);
3630 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3631 scm_product (scm_numerator (y
), xd
));
3632 return scm_divide (r1
, scm_product (xd
, yd
));
3636 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3637 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3638 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3640 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3642 "Return the integer @var{q} and the real number @var{r}\n"
3643 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3644 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3645 "nearest integer, with ties going to the nearest even integer.\n"
3647 "(round/ 123 10) @result{} 12 and 3\n"
3648 "(round/ 123 -10) @result{} -12 and 3\n"
3649 "(round/ -123 10) @result{} -12 and -3\n"
3650 "(round/ -123 -10) @result{} 12 and -3\n"
3651 "(round/ 125 10) @result{} 12 and 5\n"
3652 "(round/ 127 10) @result{} 13 and -3\n"
3653 "(round/ 135 10) @result{} 14 and -5\n"
3654 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3655 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3657 #define FUNC_NAME s_scm_i_round_divide
3661 scm_round_divide(x
, y
, &q
, &r
);
3662 return scm_values (scm_list_2 (q
, r
));
3666 #define s_scm_round_divide s_scm_i_round_divide
3667 #define g_scm_round_divide g_scm_i_round_divide
3670 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3672 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3674 scm_t_inum xx
= SCM_I_INUM (x
);
3675 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3677 scm_t_inum yy
= SCM_I_INUM (y
);
3678 if (SCM_UNLIKELY (yy
== 0))
3679 scm_num_overflow (s_scm_round_divide
);
3682 scm_t_inum qq
= xx
/ yy
;
3683 scm_t_inum rr
= xx
% yy
;
3685 scm_t_inum r2
= 2 * rr
;
3687 if (SCM_LIKELY (yy
< 0))
3707 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3708 *qp
= SCM_I_MAKINUM (qq
);
3710 *qp
= scm_i_inum2big (qq
);
3711 *rp
= SCM_I_MAKINUM (rr
);
3715 else if (SCM_BIGP (y
))
3717 /* Pass a denormalized bignum version of x (even though it
3718 can fit in a fixnum) to scm_i_bigint_round_divide */
3719 return scm_i_bigint_round_divide
3720 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3722 else if (SCM_REALP (y
))
3723 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3724 else if (SCM_FRACTIONP (y
))
3725 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3727 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3728 s_scm_round_divide
, qp
, rp
);
3730 else if (SCM_BIGP (x
))
3732 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3734 scm_t_inum yy
= SCM_I_INUM (y
);
3735 if (SCM_UNLIKELY (yy
== 0))
3736 scm_num_overflow (s_scm_round_divide
);
3739 SCM q
= scm_i_mkbig ();
3741 int needs_adjustment
;
3745 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3746 SCM_I_BIG_MPZ (x
), yy
);
3747 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3748 needs_adjustment
= (2*rr
>= yy
);
3750 needs_adjustment
= (2*rr
> yy
);
3754 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3755 SCM_I_BIG_MPZ (x
), -yy
);
3756 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3757 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3758 needs_adjustment
= (2*rr
<= yy
);
3760 needs_adjustment
= (2*rr
< yy
);
3762 scm_remember_upto_here_1 (x
);
3763 if (needs_adjustment
)
3765 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3768 *qp
= scm_i_normbig (q
);
3769 *rp
= SCM_I_MAKINUM (rr
);
3773 else if (SCM_BIGP (y
))
3774 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3775 else if (SCM_REALP (y
))
3776 return scm_i_inexact_round_divide
3777 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3778 else if (SCM_FRACTIONP (y
))
3779 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3781 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3782 s_scm_round_divide
, qp
, rp
);
3784 else if (SCM_REALP (x
))
3786 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3787 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3788 return scm_i_inexact_round_divide
3789 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3791 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3792 s_scm_round_divide
, qp
, rp
);
3794 else if (SCM_FRACTIONP (x
))
3797 return scm_i_inexact_round_divide
3798 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3799 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3800 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3802 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3803 s_scm_round_divide
, qp
, rp
);
3806 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3807 s_scm_round_divide
, qp
, rp
);
3811 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3813 if (SCM_UNLIKELY (y
== 0))
3814 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3817 double q
= scm_c_round (x
/ y
);
3818 double r
= x
- q
* y
;
3819 *qp
= scm_from_double (q
);
3820 *rp
= scm_from_double (r
);
3824 /* Assumes that both x and y are bigints, though
3825 x might be able to fit into a fixnum. */
3827 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3830 int cmp
, needs_adjustment
;
3832 /* Note that x might be small enough to fit into a
3833 fixnum, so we must not let it escape into the wild */
3836 r2
= scm_i_mkbig ();
3838 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3839 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3840 scm_remember_upto_here_1 (x
);
3841 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3843 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3844 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3845 needs_adjustment
= (cmp
>= 0);
3847 needs_adjustment
= (cmp
> 0);
3849 if (needs_adjustment
)
3851 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3852 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3855 scm_remember_upto_here_2 (r2
, y
);
3856 *qp
= scm_i_normbig (q
);
3857 *rp
= scm_i_normbig (r
);
3861 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3864 SCM xd
= scm_denominator (x
);
3865 SCM yd
= scm_denominator (y
);
3867 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3868 scm_product (scm_numerator (y
), xd
),
3870 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3874 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3875 (SCM x
, SCM y
, SCM rest
),
3876 "Return the greatest common divisor of all parameter values.\n"
3877 "If called without arguments, 0 is returned.")
3878 #define FUNC_NAME s_scm_i_gcd
3880 while (!scm_is_null (rest
))
3881 { x
= scm_gcd (x
, y
);
3883 rest
= scm_cdr (rest
);
3885 return scm_gcd (x
, y
);
3889 #define s_gcd s_scm_i_gcd
3890 #define g_gcd g_scm_i_gcd
3893 scm_gcd (SCM x
, SCM y
)
3896 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3898 if (SCM_I_INUMP (x
))
3900 if (SCM_I_INUMP (y
))
3902 scm_t_inum xx
= SCM_I_INUM (x
);
3903 scm_t_inum yy
= SCM_I_INUM (y
);
3904 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3905 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3915 /* Determine a common factor 2^k */
3916 while (!(1 & (u
| v
)))
3922 /* Now, any factor 2^n can be eliminated */
3942 return (SCM_POSFIXABLE (result
)
3943 ? SCM_I_MAKINUM (result
)
3944 : scm_i_inum2big (result
));
3946 else if (SCM_BIGP (y
))
3952 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3954 else if (SCM_BIGP (x
))
3956 if (SCM_I_INUMP (y
))
3961 yy
= SCM_I_INUM (y
);
3966 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3967 scm_remember_upto_here_1 (x
);
3968 return (SCM_POSFIXABLE (result
)
3969 ? SCM_I_MAKINUM (result
)
3970 : scm_from_unsigned_integer (result
));
3972 else if (SCM_BIGP (y
))
3974 SCM result
= scm_i_mkbig ();
3975 mpz_gcd (SCM_I_BIG_MPZ (result
),
3978 scm_remember_upto_here_2 (x
, y
);
3979 return scm_i_normbig (result
);
3982 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3985 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3988 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3989 (SCM x
, SCM y
, SCM rest
),
3990 "Return the least common multiple of the arguments.\n"
3991 "If called without arguments, 1 is returned.")
3992 #define FUNC_NAME s_scm_i_lcm
3994 while (!scm_is_null (rest
))
3995 { x
= scm_lcm (x
, y
);
3997 rest
= scm_cdr (rest
);
3999 return scm_lcm (x
, y
);
4003 #define s_lcm s_scm_i_lcm
4004 #define g_lcm g_scm_i_lcm
4007 scm_lcm (SCM n1
, SCM n2
)
4009 if (SCM_UNBNDP (n2
))
4011 if (SCM_UNBNDP (n1
))
4012 return SCM_I_MAKINUM (1L);
4013 n2
= SCM_I_MAKINUM (1L);
4016 if (SCM_UNLIKELY (!(SCM_I_INUMP (n1
) || SCM_BIGP (n1
))))
4017 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
4019 if (SCM_UNLIKELY (!(SCM_I_INUMP (n2
) || SCM_BIGP (n2
))))
4020 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
4022 if (SCM_I_INUMP (n1
))
4024 if (SCM_I_INUMP (n2
))
4026 SCM d
= scm_gcd (n1
, n2
);
4027 if (scm_is_eq (d
, SCM_INUM0
))
4030 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4034 /* inum n1, big n2 */
4037 SCM result
= scm_i_mkbig ();
4038 scm_t_inum nn1
= SCM_I_INUM (n1
);
4039 if (nn1
== 0) return SCM_INUM0
;
4040 if (nn1
< 0) nn1
= - nn1
;
4041 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4042 scm_remember_upto_here_1 (n2
);
4050 if (SCM_I_INUMP (n2
))
4057 SCM result
= scm_i_mkbig ();
4058 mpz_lcm(SCM_I_BIG_MPZ (result
),
4060 SCM_I_BIG_MPZ (n2
));
4061 scm_remember_upto_here_2(n1
, n2
);
4062 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4068 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4073 + + + x (map digit:logand X Y)
4074 + - + x (map digit:logand X (lognot (+ -1 Y)))
4075 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4076 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4081 + + + (map digit:logior X Y)
4082 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4083 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4084 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4089 + + + (map digit:logxor X Y)
4090 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4091 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4092 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4097 + + (any digit:logand X Y)
4098 + - (any digit:logand X (lognot (+ -1 Y)))
4099 - + (any digit:logand (lognot (+ -1 X)) Y)
4104 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4105 (SCM x
, SCM y
, SCM rest
),
4106 "Return the bitwise AND of the integer arguments.\n\n"
4108 "(logand) @result{} -1\n"
4109 "(logand 7) @result{} 7\n"
4110 "(logand #b111 #b011 #b001) @result{} 1\n"
4112 #define FUNC_NAME s_scm_i_logand
4114 while (!scm_is_null (rest
))
4115 { x
= scm_logand (x
, y
);
4117 rest
= scm_cdr (rest
);
4119 return scm_logand (x
, y
);
4123 #define s_scm_logand s_scm_i_logand
4125 SCM
scm_logand (SCM n1
, SCM n2
)
4126 #define FUNC_NAME s_scm_logand
4130 if (SCM_UNBNDP (n2
))
4132 if (SCM_UNBNDP (n1
))
4133 return SCM_I_MAKINUM (-1);
4134 else if (!SCM_NUMBERP (n1
))
4135 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4136 else if (SCM_NUMBERP (n1
))
4139 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4142 if (SCM_I_INUMP (n1
))
4144 nn1
= SCM_I_INUM (n1
);
4145 if (SCM_I_INUMP (n2
))
4147 scm_t_inum nn2
= SCM_I_INUM (n2
);
4148 return SCM_I_MAKINUM (nn1
& nn2
);
4150 else if SCM_BIGP (n2
)
4156 SCM result_z
= scm_i_mkbig ();
4158 mpz_init_set_si (nn1_z
, nn1
);
4159 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4160 scm_remember_upto_here_1 (n2
);
4162 return scm_i_normbig (result_z
);
4166 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4168 else if (SCM_BIGP (n1
))
4170 if (SCM_I_INUMP (n2
))
4173 nn1
= SCM_I_INUM (n1
);
4176 else if (SCM_BIGP (n2
))
4178 SCM result_z
= scm_i_mkbig ();
4179 mpz_and (SCM_I_BIG_MPZ (result_z
),
4181 SCM_I_BIG_MPZ (n2
));
4182 scm_remember_upto_here_2 (n1
, n2
);
4183 return scm_i_normbig (result_z
);
4186 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4189 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4194 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4195 (SCM x
, SCM y
, SCM rest
),
4196 "Return the bitwise OR of the integer arguments.\n\n"
4198 "(logior) @result{} 0\n"
4199 "(logior 7) @result{} 7\n"
4200 "(logior #b000 #b001 #b011) @result{} 3\n"
4202 #define FUNC_NAME s_scm_i_logior
4204 while (!scm_is_null (rest
))
4205 { x
= scm_logior (x
, y
);
4207 rest
= scm_cdr (rest
);
4209 return scm_logior (x
, y
);
4213 #define s_scm_logior s_scm_i_logior
4215 SCM
scm_logior (SCM n1
, SCM n2
)
4216 #define FUNC_NAME s_scm_logior
4220 if (SCM_UNBNDP (n2
))
4222 if (SCM_UNBNDP (n1
))
4224 else if (SCM_NUMBERP (n1
))
4227 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4230 if (SCM_I_INUMP (n1
))
4232 nn1
= SCM_I_INUM (n1
);
4233 if (SCM_I_INUMP (n2
))
4235 long nn2
= SCM_I_INUM (n2
);
4236 return SCM_I_MAKINUM (nn1
| nn2
);
4238 else if (SCM_BIGP (n2
))
4244 SCM result_z
= scm_i_mkbig ();
4246 mpz_init_set_si (nn1_z
, nn1
);
4247 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4248 scm_remember_upto_here_1 (n2
);
4250 return scm_i_normbig (result_z
);
4254 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4256 else if (SCM_BIGP (n1
))
4258 if (SCM_I_INUMP (n2
))
4261 nn1
= SCM_I_INUM (n1
);
4264 else if (SCM_BIGP (n2
))
4266 SCM result_z
= scm_i_mkbig ();
4267 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4269 SCM_I_BIG_MPZ (n2
));
4270 scm_remember_upto_here_2 (n1
, n2
);
4271 return scm_i_normbig (result_z
);
4274 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4277 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4282 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4283 (SCM x
, SCM y
, SCM rest
),
4284 "Return the bitwise XOR of the integer arguments. A bit is\n"
4285 "set in the result if it is set in an odd number of arguments.\n"
4287 "(logxor) @result{} 0\n"
4288 "(logxor 7) @result{} 7\n"
4289 "(logxor #b000 #b001 #b011) @result{} 2\n"
4290 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4292 #define FUNC_NAME s_scm_i_logxor
4294 while (!scm_is_null (rest
))
4295 { x
= scm_logxor (x
, y
);
4297 rest
= scm_cdr (rest
);
4299 return scm_logxor (x
, y
);
4303 #define s_scm_logxor s_scm_i_logxor
4305 SCM
scm_logxor (SCM n1
, SCM n2
)
4306 #define FUNC_NAME s_scm_logxor
4310 if (SCM_UNBNDP (n2
))
4312 if (SCM_UNBNDP (n1
))
4314 else if (SCM_NUMBERP (n1
))
4317 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4320 if (SCM_I_INUMP (n1
))
4322 nn1
= SCM_I_INUM (n1
);
4323 if (SCM_I_INUMP (n2
))
4325 scm_t_inum nn2
= SCM_I_INUM (n2
);
4326 return SCM_I_MAKINUM (nn1
^ nn2
);
4328 else if (SCM_BIGP (n2
))
4332 SCM result_z
= scm_i_mkbig ();
4334 mpz_init_set_si (nn1_z
, nn1
);
4335 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4336 scm_remember_upto_here_1 (n2
);
4338 return scm_i_normbig (result_z
);
4342 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4344 else if (SCM_BIGP (n1
))
4346 if (SCM_I_INUMP (n2
))
4349 nn1
= SCM_I_INUM (n1
);
4352 else if (SCM_BIGP (n2
))
4354 SCM result_z
= scm_i_mkbig ();
4355 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4357 SCM_I_BIG_MPZ (n2
));
4358 scm_remember_upto_here_2 (n1
, n2
);
4359 return scm_i_normbig (result_z
);
4362 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4365 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4370 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4372 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4373 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4374 "without actually calculating the @code{logand}, just testing\n"
4378 "(logtest #b0100 #b1011) @result{} #f\n"
4379 "(logtest #b0100 #b0111) @result{} #t\n"
4381 #define FUNC_NAME s_scm_logtest
4385 if (SCM_I_INUMP (j
))
4387 nj
= SCM_I_INUM (j
);
4388 if (SCM_I_INUMP (k
))
4390 scm_t_inum nk
= SCM_I_INUM (k
);
4391 return scm_from_bool (nj
& nk
);
4393 else if (SCM_BIGP (k
))
4401 mpz_init_set_si (nj_z
, nj
);
4402 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4403 scm_remember_upto_here_1 (k
);
4404 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4410 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4412 else if (SCM_BIGP (j
))
4414 if (SCM_I_INUMP (k
))
4417 nj
= SCM_I_INUM (j
);
4420 else if (SCM_BIGP (k
))
4424 mpz_init (result_z
);
4428 scm_remember_upto_here_2 (j
, k
);
4429 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4430 mpz_clear (result_z
);
4434 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4437 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4442 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4444 "Test whether bit number @var{index} in @var{j} is set.\n"
4445 "@var{index} starts from 0 for the least significant bit.\n"
4448 "(logbit? 0 #b1101) @result{} #t\n"
4449 "(logbit? 1 #b1101) @result{} #f\n"
4450 "(logbit? 2 #b1101) @result{} #t\n"
4451 "(logbit? 3 #b1101) @result{} #t\n"
4452 "(logbit? 4 #b1101) @result{} #f\n"
4454 #define FUNC_NAME s_scm_logbit_p
4456 unsigned long int iindex
;
4457 iindex
= scm_to_ulong (index
);
4459 if (SCM_I_INUMP (j
))
4461 /* bits above what's in an inum follow the sign bit */
4462 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4463 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4465 else if (SCM_BIGP (j
))
4467 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4468 scm_remember_upto_here_1 (j
);
4469 return scm_from_bool (val
);
4472 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4477 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4479 "Return the integer which is the ones-complement of the integer\n"
4483 "(number->string (lognot #b10000000) 2)\n"
4484 " @result{} \"-10000001\"\n"
4485 "(number->string (lognot #b0) 2)\n"
4486 " @result{} \"-1\"\n"
4488 #define FUNC_NAME s_scm_lognot
4490 if (SCM_I_INUMP (n
)) {
4491 /* No overflow here, just need to toggle all the bits making up the inum.
4492 Enhancement: No need to strip the tag and add it back, could just xor
4493 a block of 1 bits, if that worked with the various debug versions of
4495 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4497 } else if (SCM_BIGP (n
)) {
4498 SCM result
= scm_i_mkbig ();
4499 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4500 scm_remember_upto_here_1 (n
);
4504 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4509 /* returns 0 if IN is not an integer. OUT must already be
4512 coerce_to_big (SCM in
, mpz_t out
)
4515 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4516 else if (SCM_I_INUMP (in
))
4517 mpz_set_si (out
, SCM_I_INUM (in
));
4524 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4525 (SCM n
, SCM k
, SCM m
),
4526 "Return @var{n} raised to the integer exponent\n"
4527 "@var{k}, modulo @var{m}.\n"
4530 "(modulo-expt 2 3 5)\n"
4533 #define FUNC_NAME s_scm_modulo_expt
4539 /* There are two classes of error we might encounter --
4540 1) Math errors, which we'll report by calling scm_num_overflow,
4542 2) wrong-type errors, which of course we'll report by calling
4544 We don't report those errors immediately, however; instead we do
4545 some cleanup first. These variables tell us which error (if
4546 any) we should report after cleaning up.
4548 int report_overflow
= 0;
4550 int position_of_wrong_type
= 0;
4551 SCM value_of_wrong_type
= SCM_INUM0
;
4553 SCM result
= SCM_UNDEFINED
;
4559 if (scm_is_eq (m
, SCM_INUM0
))
4561 report_overflow
= 1;
4565 if (!coerce_to_big (n
, n_tmp
))
4567 value_of_wrong_type
= n
;
4568 position_of_wrong_type
= 1;
4572 if (!coerce_to_big (k
, k_tmp
))
4574 value_of_wrong_type
= k
;
4575 position_of_wrong_type
= 2;
4579 if (!coerce_to_big (m
, m_tmp
))
4581 value_of_wrong_type
= m
;
4582 position_of_wrong_type
= 3;
4586 /* if the exponent K is negative, and we simply call mpz_powm, we
4587 will get a divide-by-zero exception when an inverse 1/n mod m
4588 doesn't exist (or is not unique). Since exceptions are hard to
4589 handle, we'll attempt the inversion "by hand" -- that way, we get
4590 a simple failure code, which is easy to handle. */
4592 if (-1 == mpz_sgn (k_tmp
))
4594 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4596 report_overflow
= 1;
4599 mpz_neg (k_tmp
, k_tmp
);
4602 result
= scm_i_mkbig ();
4603 mpz_powm (SCM_I_BIG_MPZ (result
),
4608 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4609 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4616 if (report_overflow
)
4617 scm_num_overflow (FUNC_NAME
);
4619 if (position_of_wrong_type
)
4620 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4621 value_of_wrong_type
);
4623 return scm_i_normbig (result
);
4627 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4629 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4630 "exact integer, @var{n} can be any number.\n"
4632 "Negative @var{k} is supported, and results in\n"
4633 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4634 "@math{@var{n}^0} is 1, as usual, and that\n"
4635 "includes @math{0^0} is 1.\n"
4638 "(integer-expt 2 5) @result{} 32\n"
4639 "(integer-expt -3 3) @result{} -27\n"
4640 "(integer-expt 5 -3) @result{} 1/125\n"
4641 "(integer-expt 0 0) @result{} 1\n"
4643 #define FUNC_NAME s_scm_integer_expt
4646 SCM z_i2
= SCM_BOOL_F
;
4648 SCM acc
= SCM_I_MAKINUM (1L);
4650 /* Specifically refrain from checking the type of the first argument.
4651 This allows us to exponentiate any object that can be multiplied.
4652 If we must raise to a negative power, we must also be able to
4653 take its reciprocal. */
4654 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4655 SCM_WRONG_TYPE_ARG (2, k
);
4657 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4658 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4659 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4660 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4661 /* The next check is necessary only because R6RS specifies different
4662 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4663 we simply skip this case and move on. */
4664 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4666 /* k cannot be 0 at this point, because we
4667 have already checked for that case above */
4668 if (scm_is_true (scm_positive_p (k
)))
4670 else /* return NaN for (0 ^ k) for negative k per R6RS */
4674 if (SCM_I_INUMP (k
))
4675 i2
= SCM_I_INUM (k
);
4676 else if (SCM_BIGP (k
))
4678 z_i2
= scm_i_clonebig (k
, 1);
4679 scm_remember_upto_here_1 (k
);
4683 SCM_WRONG_TYPE_ARG (2, k
);
4687 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4689 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4690 n
= scm_divide (n
, SCM_UNDEFINED
);
4694 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4698 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4700 return scm_product (acc
, n
);
4702 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4703 acc
= scm_product (acc
, n
);
4704 n
= scm_product (n
, n
);
4705 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4713 n
= scm_divide (n
, SCM_UNDEFINED
);
4720 return scm_product (acc
, n
);
4722 acc
= scm_product (acc
, n
);
4723 n
= scm_product (n
, n
);
4730 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4732 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4733 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4735 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4736 "@var{cnt} is negative it's a division, rounded towards negative\n"
4737 "infinity. (Note that this is not the same rounding as\n"
4738 "@code{quotient} does.)\n"
4740 "With @var{n} viewed as an infinite precision twos complement,\n"
4741 "@code{ash} means a left shift introducing zero bits, or a right\n"
4742 "shift dropping bits.\n"
4745 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4746 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4748 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4749 "(ash -23 -2) @result{} -6\n"
4751 #define FUNC_NAME s_scm_ash
4754 bits_to_shift
= scm_to_long (cnt
);
4756 if (SCM_I_INUMP (n
))
4758 scm_t_inum nn
= SCM_I_INUM (n
);
4760 if (bits_to_shift
> 0)
4762 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4763 overflow a non-zero fixnum. For smaller shifts we check the
4764 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4765 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4766 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4772 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4774 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4777 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4781 SCM result
= scm_i_inum2big (nn
);
4782 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4789 bits_to_shift
= -bits_to_shift
;
4790 if (bits_to_shift
>= SCM_LONG_BIT
)
4791 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4793 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4797 else if (SCM_BIGP (n
))
4801 if (bits_to_shift
== 0)
4804 result
= scm_i_mkbig ();
4805 if (bits_to_shift
>= 0)
4807 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4813 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4814 we have to allocate a bignum even if the result is going to be a
4816 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4818 return scm_i_normbig (result
);
4824 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4830 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4831 (SCM n
, SCM start
, SCM end
),
4832 "Return the integer composed of the @var{start} (inclusive)\n"
4833 "through @var{end} (exclusive) bits of @var{n}. The\n"
4834 "@var{start}th bit becomes the 0-th bit in the result.\n"
4837 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4838 " @result{} \"1010\"\n"
4839 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4840 " @result{} \"10110\"\n"
4842 #define FUNC_NAME s_scm_bit_extract
4844 unsigned long int istart
, iend
, bits
;
4845 istart
= scm_to_ulong (start
);
4846 iend
= scm_to_ulong (end
);
4847 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4849 /* how many bits to keep */
4850 bits
= iend
- istart
;
4852 if (SCM_I_INUMP (n
))
4854 scm_t_inum in
= SCM_I_INUM (n
);
4856 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4857 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4858 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4860 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4862 /* Since we emulate two's complement encoded numbers, this
4863 * special case requires us to produce a result that has
4864 * more bits than can be stored in a fixnum.
4866 SCM result
= scm_i_inum2big (in
);
4867 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4872 /* mask down to requisite bits */
4873 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4874 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4876 else if (SCM_BIGP (n
))
4881 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4885 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4886 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4887 such bits into a ulong. */
4888 result
= scm_i_mkbig ();
4889 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4890 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4891 result
= scm_i_normbig (result
);
4893 scm_remember_upto_here_1 (n
);
4897 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4902 static const char scm_logtab
[] = {
4903 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4906 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4908 "Return the number of bits in integer @var{n}. If integer is\n"
4909 "positive, the 1-bits in its binary representation are counted.\n"
4910 "If negative, the 0-bits in its two's-complement binary\n"
4911 "representation are counted. If 0, 0 is returned.\n"
4914 "(logcount #b10101010)\n"
4921 #define FUNC_NAME s_scm_logcount
4923 if (SCM_I_INUMP (n
))
4925 unsigned long c
= 0;
4926 scm_t_inum nn
= SCM_I_INUM (n
);
4931 c
+= scm_logtab
[15 & nn
];
4934 return SCM_I_MAKINUM (c
);
4936 else if (SCM_BIGP (n
))
4938 unsigned long count
;
4939 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4940 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4942 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4943 scm_remember_upto_here_1 (n
);
4944 return SCM_I_MAKINUM (count
);
4947 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4952 static const char scm_ilentab
[] = {
4953 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4957 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4959 "Return the number of bits necessary to represent @var{n}.\n"
4962 "(integer-length #b10101010)\n"
4964 "(integer-length 0)\n"
4966 "(integer-length #b1111)\n"
4969 #define FUNC_NAME s_scm_integer_length
4971 if (SCM_I_INUMP (n
))
4973 unsigned long c
= 0;
4975 scm_t_inum nn
= SCM_I_INUM (n
);
4981 l
= scm_ilentab
[15 & nn
];
4984 return SCM_I_MAKINUM (c
- 4 + l
);
4986 else if (SCM_BIGP (n
))
4988 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4989 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4990 1 too big, so check for that and adjust. */
4991 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4992 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4993 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4994 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4996 scm_remember_upto_here_1 (n
);
4997 return SCM_I_MAKINUM (size
);
5000 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
5004 /*** NUMBERS -> STRINGS ***/
5005 #define SCM_MAX_DBL_PREC 60
5006 #define SCM_MAX_DBL_RADIX 36
5008 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
5009 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
5010 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
5013 void init_dblprec(int *prec
, int radix
) {
5014 /* determine floating point precision by adding successively
5015 smaller increments to 1.0 until it is considered == 1.0 */
5016 double f
= ((double)1.0)/radix
;
5017 double fsum
= 1.0 + f
;
5022 if (++(*prec
) > SCM_MAX_DBL_PREC
)
5034 void init_fx_radix(double *fx_list
, int radix
)
5036 /* initialize a per-radix list of tolerances. When added
5037 to a number < 1.0, we can determine if we should raund
5038 up and quit converting a number to a string. */
5042 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5043 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5046 /* use this array as a way to generate a single digit */
5047 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5050 idbl2str (double f
, char *a
, int radix
)
5052 int efmt
, dpt
, d
, i
, wp
;
5054 #ifdef DBL_MIN_10_EXP
5057 #endif /* DBL_MIN_10_EXP */
5062 radix
> SCM_MAX_DBL_RADIX
)
5064 /* revert to existing behavior */
5068 wp
= scm_dblprec
[radix
-2];
5069 fx
= fx_per_radix
[radix
-2];
5073 #ifdef HAVE_COPYSIGN
5074 double sgn
= copysign (1.0, f
);
5079 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5085 strcpy (a
, "-inf.0");
5087 strcpy (a
, "+inf.0");
5092 strcpy (a
, "+nan.0");
5102 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5103 make-uniform-vector, from causing infinite loops. */
5104 /* just do the checking...if it passes, we do the conversion for our
5105 radix again below */
5112 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5120 while (f_cpy
> 10.0)
5123 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5144 if (f
+ fx
[wp
] >= radix
)
5150 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5171 a
[ch
++] = number_chars
[d
];
5174 if (f
+ fx
[wp
] >= 1.0)
5176 a
[ch
- 1] = number_chars
[d
+1];
5187 if ((dpt
> 4) && (exp
> 6))
5189 d
= (a
[0] == '-' ? 2 : 1);
5190 for (i
= ch
++; i
> d
; i
--)
5202 if (a
[ch
- 1] == '.')
5203 a
[ch
++] = '0'; /* trailing zero */
5212 for (i
= radix
; i
<= exp
; i
*= radix
);
5213 for (i
/= radix
; i
; i
/= radix
)
5215 a
[ch
++] = number_chars
[exp
/ i
];
5224 icmplx2str (double real
, double imag
, char *str
, int radix
)
5229 i
= idbl2str (real
, str
, radix
);
5230 #ifdef HAVE_COPYSIGN
5231 sgn
= copysign (1.0, imag
);
5235 /* Don't output a '+' for negative numbers or for Inf and
5236 NaN. They will provide their own sign. */
5237 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5239 i
+= idbl2str (imag
, &str
[i
], radix
);
5245 iflo2str (SCM flt
, char *str
, int radix
)
5248 if (SCM_REALP (flt
))
5249 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5251 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5256 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5257 characters in the result.
5259 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5261 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5266 return scm_iuint2str (-num
, rad
, p
) + 1;
5269 return scm_iuint2str (num
, rad
, p
);
5272 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5273 characters in the result.
5275 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5277 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5281 scm_t_uintmax n
= num
;
5283 if (rad
< 2 || rad
> 36)
5284 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5286 for (n
/= rad
; n
> 0; n
/= rad
)
5296 p
[i
] = number_chars
[d
];
5301 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5303 "Return a string holding the external representation of the\n"
5304 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5305 "inexact, a radix of 10 will be used.")
5306 #define FUNC_NAME s_scm_number_to_string
5310 if (SCM_UNBNDP (radix
))
5313 base
= scm_to_signed_integer (radix
, 2, 36);
5315 if (SCM_I_INUMP (n
))
5317 char num_buf
[SCM_INTBUFLEN
];
5318 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5319 return scm_from_locale_stringn (num_buf
, length
);
5321 else if (SCM_BIGP (n
))
5323 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5324 scm_remember_upto_here_1 (n
);
5325 return scm_take_locale_string (str
);
5327 else if (SCM_FRACTIONP (n
))
5329 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5330 scm_from_locale_string ("/"),
5331 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5333 else if (SCM_INEXACTP (n
))
5335 char num_buf
[FLOBUFLEN
];
5336 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5339 SCM_WRONG_TYPE_ARG (1, n
);
5344 /* These print routines used to be stubbed here so that scm_repl.c
5345 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5348 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5350 char num_buf
[FLOBUFLEN
];
5351 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5356 scm_i_print_double (double val
, SCM port
)
5358 char num_buf
[FLOBUFLEN
];
5359 scm_lfwrite_unlocked (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5363 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5366 char num_buf
[FLOBUFLEN
];
5367 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5372 scm_i_print_complex (double real
, double imag
, SCM port
)
5374 char num_buf
[FLOBUFLEN
];
5375 scm_lfwrite_unlocked (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5379 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5382 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5383 scm_display (str
, port
);
5384 scm_remember_upto_here_1 (str
);
5389 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5391 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5392 size_t len
= strlen (str
);
5393 void (*freefunc
) (void *, size_t);
5394 mp_get_memory_functions (NULL
, NULL
, &freefunc
);
5395 scm_remember_upto_here_1 (exp
);
5396 scm_lfwrite_unlocked (str
, len
, port
);
5397 freefunc (str
, len
+ 1);
5400 /*** END nums->strs ***/
5403 /*** STRINGS -> NUMBERS ***/
5405 /* The following functions implement the conversion from strings to numbers.
5406 * The implementation somehow follows the grammar for numbers as it is given
5407 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5408 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5409 * points should be noted about the implementation:
5411 * * Each function keeps a local index variable 'idx' that points at the
5412 * current position within the parsed string. The global index is only
5413 * updated if the function could parse the corresponding syntactic unit
5416 * * Similarly, the functions keep track of indicators of inexactness ('#',
5417 * '.' or exponents) using local variables ('hash_seen', 'x').
5419 * * Sequences of digits are parsed into temporary variables holding fixnums.
5420 * Only if these fixnums would overflow, the result variables are updated
5421 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5422 * the temporary variables holding the fixnums are cleared, and the process
5423 * starts over again. If for example fixnums were able to store five decimal
5424 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5425 * and the result was computed as 12345 * 100000 + 67890. In other words,
5426 * only every five digits two bignum operations were performed.
5428 * Notes on the handling of exactness specifiers:
5430 * When parsing non-real complex numbers, we apply exactness specifiers on
5431 * per-component basis, as is done in PLT Scheme. For complex numbers
5432 * written in rectangular form, exactness specifiers are applied to the
5433 * real and imaginary parts before calling scm_make_rectangular. For
5434 * complex numbers written in polar form, exactness specifiers are applied
5435 * to the magnitude and angle before calling scm_make_polar.
5437 * There are two kinds of exactness specifiers: forced and implicit. A
5438 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5439 * the entire number, and applies to both components of a complex number.
5440 * "#e" causes each component to be made exact, and "#i" causes each
5441 * component to be made inexact. If no forced exactness specifier is
5442 * present, then the exactness of each component is determined
5443 * independently by the presence or absence of a decimal point or hash mark
5444 * within that component. If a decimal point or hash mark is present, the
5445 * component is made inexact, otherwise it is made exact.
5447 * After the exactness specifiers have been applied to each component, they
5448 * are passed to either scm_make_rectangular or scm_make_polar to produce
5449 * the final result. Note that this will result in a real number if the
5450 * imaginary part, magnitude, or angle is an exact 0.
5452 * For example, (string->number "#i5.0+0i") does the equivalent of:
5454 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5457 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5459 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5461 /* Caller is responsible for checking that the return value is in range
5462 for the given radix, which should be <= 36. */
5464 char_decimal_value (scm_t_uint32 c
)
5466 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5467 that's certainly above any valid decimal, so we take advantage of
5468 that to elide some tests. */
5469 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5471 /* If that failed, try extended hexadecimals, then. Only accept ascii
5476 if (c
>= (scm_t_uint32
) 'a')
5477 d
= c
- (scm_t_uint32
)'a' + 10U;
5482 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5483 in base RADIX. Upon success, return the unsigned integer and update
5484 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5486 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5487 unsigned int radix
, enum t_exactness
*p_exactness
)
5489 unsigned int idx
= *p_idx
;
5490 unsigned int hash_seen
= 0;
5491 scm_t_bits shift
= 1;
5493 unsigned int digit_value
;
5496 size_t len
= scm_i_string_length (mem
);
5501 c
= scm_i_string_ref (mem
, idx
);
5502 digit_value
= char_decimal_value (c
);
5503 if (digit_value
>= radix
)
5507 result
= SCM_I_MAKINUM (digit_value
);
5510 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5520 digit_value
= char_decimal_value (c
);
5521 /* This check catches non-decimals in addition to out-of-range
5523 if (digit_value
>= radix
)
5528 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5530 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5532 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5539 shift
= shift
* radix
;
5540 add
= add
* radix
+ digit_value
;
5545 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5547 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5551 *p_exactness
= INEXACT
;
5557 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5558 * covers the parts of the rules that start at a potential point. The value
5559 * of the digits up to the point have been parsed by the caller and are given
5560 * in variable result. The content of *p_exactness indicates, whether a hash
5561 * has already been seen in the digits before the point.
5564 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5567 mem2decimal_from_point (SCM result
, SCM mem
,
5568 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5570 unsigned int idx
= *p_idx
;
5571 enum t_exactness x
= *p_exactness
;
5572 size_t len
= scm_i_string_length (mem
);
5577 if (scm_i_string_ref (mem
, idx
) == '.')
5579 scm_t_bits shift
= 1;
5581 unsigned int digit_value
;
5582 SCM big_shift
= SCM_INUM1
;
5587 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5588 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5593 digit_value
= DIGIT2UINT (c
);
5604 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5606 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5607 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5609 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5617 add
= add
* 10 + digit_value
;
5623 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5624 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5625 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5628 result
= scm_divide (result
, big_shift
);
5630 /* We've seen a decimal point, thus the value is implicitly inexact. */
5642 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5644 switch (scm_i_string_ref (mem
, idx
))
5656 c
= scm_i_string_ref (mem
, idx
);
5664 c
= scm_i_string_ref (mem
, idx
);
5673 c
= scm_i_string_ref (mem
, idx
);
5678 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5682 exponent
= DIGIT2UINT (c
);
5685 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5686 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5689 if (exponent
<= SCM_MAXEXP
)
5690 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5696 if (exponent
> SCM_MAXEXP
)
5698 size_t exp_len
= idx
- start
;
5699 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5700 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5701 scm_out_of_range ("string->number", exp_num
);
5704 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5706 result
= scm_product (result
, e
);
5708 result
= scm_divide (result
, e
);
5710 /* We've seen an exponent, thus the value is implicitly inexact. */
5728 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5731 mem2ureal (SCM mem
, unsigned int *p_idx
,
5732 unsigned int radix
, enum t_exactness forced_x
)
5734 unsigned int idx
= *p_idx
;
5736 size_t len
= scm_i_string_length (mem
);
5738 /* Start off believing that the number will be exact. This changes
5739 to INEXACT if we see a decimal point or a hash. */
5740 enum t_exactness implicit_x
= EXACT
;
5745 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5751 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5753 /* Cobble up the fractional part. We might want to set the
5754 NaN's mantissa from it. */
5756 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
), SCM_INUM0
))
5758 #if SCM_ENABLE_DEPRECATED == 1
5759 scm_c_issue_deprecation_warning
5760 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5770 if (scm_i_string_ref (mem
, idx
) == '.')
5774 else if (idx
+ 1 == len
)
5776 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5779 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5780 p_idx
, &implicit_x
);
5786 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5787 if (scm_is_false (uinteger
))
5792 else if (scm_i_string_ref (mem
, idx
) == '/')
5800 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5801 if (scm_is_false (divisor
))
5804 /* both are int/big here, I assume */
5805 result
= scm_i_make_ratio (uinteger
, divisor
);
5807 else if (radix
== 10)
5809 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5810 if (scm_is_false (result
))
5822 if (SCM_INEXACTP (result
))
5823 return scm_inexact_to_exact (result
);
5827 if (SCM_INEXACTP (result
))
5830 return scm_exact_to_inexact (result
);
5832 if (implicit_x
== INEXACT
)
5834 if (SCM_INEXACTP (result
))
5837 return scm_exact_to_inexact (result
);
5843 /* We should never get here */
5844 scm_syserror ("mem2ureal");
5848 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5851 mem2complex (SCM mem
, unsigned int idx
,
5852 unsigned int radix
, enum t_exactness forced_x
)
5857 size_t len
= scm_i_string_length (mem
);
5862 c
= scm_i_string_ref (mem
, idx
);
5877 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5878 if (scm_is_false (ureal
))
5880 /* input must be either +i or -i */
5885 if (scm_i_string_ref (mem
, idx
) == 'i'
5886 || scm_i_string_ref (mem
, idx
) == 'I')
5892 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5899 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5900 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5905 c
= scm_i_string_ref (mem
, idx
);
5909 /* either +<ureal>i or -<ureal>i */
5916 return scm_make_rectangular (SCM_INUM0
, ureal
);
5919 /* polar input: <real>@<real>. */
5930 c
= scm_i_string_ref (mem
, idx
);
5948 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5949 if (scm_is_false (angle
))
5954 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5955 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5957 result
= scm_make_polar (ureal
, angle
);
5962 /* expecting input matching <real>[+-]<ureal>?i */
5969 int sign
= (c
== '+') ? 1 : -1;
5970 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5972 if (scm_is_false (imag
))
5973 imag
= SCM_I_MAKINUM (sign
);
5974 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5975 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5979 if (scm_i_string_ref (mem
, idx
) != 'i'
5980 && scm_i_string_ref (mem
, idx
) != 'I')
5987 return scm_make_rectangular (ureal
, imag
);
5996 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
5998 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
6001 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
6003 unsigned int idx
= 0;
6004 unsigned int radix
= NO_RADIX
;
6005 enum t_exactness forced_x
= NO_EXACTNESS
;
6006 size_t len
= scm_i_string_length (mem
);
6008 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6009 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
6011 switch (scm_i_string_ref (mem
, idx
+ 1))
6014 if (radix
!= NO_RADIX
)
6019 if (radix
!= NO_RADIX
)
6024 if (forced_x
!= NO_EXACTNESS
)
6029 if (forced_x
!= NO_EXACTNESS
)
6034 if (radix
!= NO_RADIX
)
6039 if (radix
!= NO_RADIX
)
6049 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6050 if (radix
== NO_RADIX
)
6051 radix
= default_radix
;
6053 return mem2complex (mem
, idx
, radix
, forced_x
);
6057 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6058 unsigned int default_radix
)
6060 SCM str
= scm_from_locale_stringn (mem
, len
);
6062 return scm_i_string_to_number (str
, default_radix
);
6066 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6067 (SCM string
, SCM radix
),
6068 "Return a number of the maximally precise representation\n"
6069 "expressed by the given @var{string}. @var{radix} must be an\n"
6070 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6071 "is a default radix that may be overridden by an explicit radix\n"
6072 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6073 "supplied, then the default radix is 10. If string is not a\n"
6074 "syntactically valid notation for a number, then\n"
6075 "@code{string->number} returns @code{#f}.")
6076 #define FUNC_NAME s_scm_string_to_number
6080 SCM_VALIDATE_STRING (1, string
);
6082 if (SCM_UNBNDP (radix
))
6085 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6087 answer
= scm_i_string_to_number (string
, base
);
6088 scm_remember_upto_here_1 (string
);
6094 /*** END strs->nums ***/
6097 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6099 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6101 #define FUNC_NAME s_scm_number_p
6103 return scm_from_bool (SCM_NUMBERP (x
));
6107 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6109 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6110 "otherwise. Note that the sets of real, rational and integer\n"
6111 "values form subsets of the set of complex numbers, i. e. the\n"
6112 "predicate will also be fulfilled if @var{x} is a real,\n"
6113 "rational or integer number.")
6114 #define FUNC_NAME s_scm_complex_p
6116 /* all numbers are complex. */
6117 return scm_number_p (x
);
6121 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6123 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6124 "otherwise. Note that the set of integer values forms a subset of\n"
6125 "the set of real numbers, i. e. the predicate will also be\n"
6126 "fulfilled if @var{x} is an integer number.")
6127 #define FUNC_NAME s_scm_real_p
6129 return scm_from_bool
6130 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6134 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6136 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6137 "otherwise. Note that the set of integer values forms a subset of\n"
6138 "the set of rational numbers, i. e. the predicate will also be\n"
6139 "fulfilled if @var{x} is an integer number.")
6140 #define FUNC_NAME s_scm_rational_p
6142 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6144 else if (SCM_REALP (x
))
6145 /* due to their limited precision, finite floating point numbers are
6146 rational as well. (finite means neither infinity nor a NaN) */
6147 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6153 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6155 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6157 #define FUNC_NAME s_scm_integer_p
6159 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6161 else if (SCM_REALP (x
))
6163 double val
= SCM_REAL_VALUE (x
);
6164 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6172 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6173 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6174 (SCM x
, SCM y
, SCM rest
),
6175 "Return @code{#t} if all parameters are numerically equal.")
6176 #define FUNC_NAME s_scm_i_num_eq_p
6178 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6180 while (!scm_is_null (rest
))
6182 if (scm_is_false (scm_num_eq_p (x
, y
)))
6186 rest
= scm_cdr (rest
);
6188 return scm_num_eq_p (x
, y
);
6192 scm_num_eq_p (SCM x
, SCM y
)
6195 if (SCM_I_INUMP (x
))
6197 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6198 if (SCM_I_INUMP (y
))
6200 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6201 return scm_from_bool (xx
== yy
);
6203 else if (SCM_BIGP (y
))
6205 else if (SCM_REALP (y
))
6207 /* On a 32-bit system an inum fits a double, we can cast the inum
6208 to a double and compare.
6210 But on a 64-bit system an inum is bigger than a double and
6211 casting it to a double (call that dxx) will round. dxx is at
6212 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6213 an integer and fits a long. So we cast yy to a long and
6214 compare with plain xx.
6216 An alternative (for any size system actually) would be to check
6217 yy is an integer (with floor) and is in range of an inum
6218 (compare against appropriate powers of 2) then test
6219 xx==(scm_t_signed_bits)yy. It's just a matter of which
6220 casts/comparisons might be fastest or easiest for the cpu. */
6222 double yy
= SCM_REAL_VALUE (y
);
6223 return scm_from_bool ((double) xx
== yy
6224 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6225 || xx
== (scm_t_signed_bits
) yy
));
6227 else if (SCM_COMPLEXP (y
))
6228 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6229 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6230 else if (SCM_FRACTIONP (y
))
6233 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6236 else if (SCM_BIGP (x
))
6238 if (SCM_I_INUMP (y
))
6240 else if (SCM_BIGP (y
))
6242 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6243 scm_remember_upto_here_2 (x
, y
);
6244 return scm_from_bool (0 == cmp
);
6246 else if (SCM_REALP (y
))
6249 if (isnan (SCM_REAL_VALUE (y
)))
6251 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6252 scm_remember_upto_here_1 (x
);
6253 return scm_from_bool (0 == cmp
);
6255 else if (SCM_COMPLEXP (y
))
6258 if (0.0 != SCM_COMPLEX_IMAG (y
))
6260 if (isnan (SCM_COMPLEX_REAL (y
)))
6262 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6263 scm_remember_upto_here_1 (x
);
6264 return scm_from_bool (0 == cmp
);
6266 else if (SCM_FRACTIONP (y
))
6269 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6272 else if (SCM_REALP (x
))
6274 double xx
= SCM_REAL_VALUE (x
);
6275 if (SCM_I_INUMP (y
))
6277 /* see comments with inum/real above */
6278 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6279 return scm_from_bool (xx
== (double) yy
6280 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6281 || (scm_t_signed_bits
) xx
== yy
));
6283 else if (SCM_BIGP (y
))
6286 if (isnan (SCM_REAL_VALUE (x
)))
6288 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6289 scm_remember_upto_here_1 (y
);
6290 return scm_from_bool (0 == cmp
);
6292 else if (SCM_REALP (y
))
6293 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6294 else if (SCM_COMPLEXP (y
))
6295 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6296 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6297 else if (SCM_FRACTIONP (y
))
6299 double xx
= SCM_REAL_VALUE (x
);
6303 return scm_from_bool (xx
< 0.0);
6304 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6308 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6311 else if (SCM_COMPLEXP (x
))
6313 if (SCM_I_INUMP (y
))
6314 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6315 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6316 else if (SCM_BIGP (y
))
6319 if (0.0 != SCM_COMPLEX_IMAG (x
))
6321 if (isnan (SCM_COMPLEX_REAL (x
)))
6323 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6324 scm_remember_upto_here_1 (y
);
6325 return scm_from_bool (0 == cmp
);
6327 else if (SCM_REALP (y
))
6328 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6329 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6330 else if (SCM_COMPLEXP (y
))
6331 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6332 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6333 else if (SCM_FRACTIONP (y
))
6336 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6338 xx
= SCM_COMPLEX_REAL (x
);
6342 return scm_from_bool (xx
< 0.0);
6343 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6347 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6350 else if (SCM_FRACTIONP (x
))
6352 if (SCM_I_INUMP (y
))
6354 else if (SCM_BIGP (y
))
6356 else if (SCM_REALP (y
))
6358 double yy
= SCM_REAL_VALUE (y
);
6362 return scm_from_bool (0.0 < yy
);
6363 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6366 else if (SCM_COMPLEXP (y
))
6369 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6371 yy
= SCM_COMPLEX_REAL (y
);
6375 return scm_from_bool (0.0 < yy
);
6376 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6379 else if (SCM_FRACTIONP (y
))
6380 return scm_i_fraction_equalp (x
, y
);
6382 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6386 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6391 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6392 done are good for inums, but for bignums an answer can almost always be
6393 had by just examining a few high bits of the operands, as done by GMP in
6394 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6395 of the float exponent to take into account. */
6397 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6398 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6399 (SCM x
, SCM y
, SCM rest
),
6400 "Return @code{#t} if the list of parameters is monotonically\n"
6402 #define FUNC_NAME s_scm_i_num_less_p
6404 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6406 while (!scm_is_null (rest
))
6408 if (scm_is_false (scm_less_p (x
, y
)))
6412 rest
= scm_cdr (rest
);
6414 return scm_less_p (x
, y
);
6418 scm_less_p (SCM x
, SCM y
)
6421 if (SCM_I_INUMP (x
))
6423 scm_t_inum xx
= SCM_I_INUM (x
);
6424 if (SCM_I_INUMP (y
))
6426 scm_t_inum yy
= SCM_I_INUM (y
);
6427 return scm_from_bool (xx
< yy
);
6429 else if (SCM_BIGP (y
))
6431 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6432 scm_remember_upto_here_1 (y
);
6433 return scm_from_bool (sgn
> 0);
6435 else if (SCM_REALP (y
))
6436 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6437 else if (SCM_FRACTIONP (y
))
6439 /* "x < a/b" becomes "x*b < a" */
6441 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6442 y
= SCM_FRACTION_NUMERATOR (y
);
6446 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6447 s_scm_i_num_less_p
);
6449 else if (SCM_BIGP (x
))
6451 if (SCM_I_INUMP (y
))
6453 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6454 scm_remember_upto_here_1 (x
);
6455 return scm_from_bool (sgn
< 0);
6457 else if (SCM_BIGP (y
))
6459 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6460 scm_remember_upto_here_2 (x
, y
);
6461 return scm_from_bool (cmp
< 0);
6463 else if (SCM_REALP (y
))
6466 if (isnan (SCM_REAL_VALUE (y
)))
6468 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6469 scm_remember_upto_here_1 (x
);
6470 return scm_from_bool (cmp
< 0);
6472 else if (SCM_FRACTIONP (y
))
6475 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6476 s_scm_i_num_less_p
);
6478 else if (SCM_REALP (x
))
6480 if (SCM_I_INUMP (y
))
6481 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6482 else if (SCM_BIGP (y
))
6485 if (isnan (SCM_REAL_VALUE (x
)))
6487 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6488 scm_remember_upto_here_1 (y
);
6489 return scm_from_bool (cmp
> 0);
6491 else if (SCM_REALP (y
))
6492 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6493 else if (SCM_FRACTIONP (y
))
6495 double xx
= SCM_REAL_VALUE (x
);
6499 return scm_from_bool (xx
< 0.0);
6500 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6504 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6505 s_scm_i_num_less_p
);
6507 else if (SCM_FRACTIONP (x
))
6509 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6511 /* "a/b < y" becomes "a < y*b" */
6512 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6513 x
= SCM_FRACTION_NUMERATOR (x
);
6516 else if (SCM_REALP (y
))
6518 double yy
= SCM_REAL_VALUE (y
);
6522 return scm_from_bool (0.0 < yy
);
6523 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6526 else if (SCM_FRACTIONP (y
))
6528 /* "a/b < c/d" becomes "a*d < c*b" */
6529 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6530 SCM_FRACTION_DENOMINATOR (y
));
6531 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6532 SCM_FRACTION_DENOMINATOR (x
));
6538 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6539 s_scm_i_num_less_p
);
6542 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6543 s_scm_i_num_less_p
);
6547 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6548 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6549 (SCM x
, SCM y
, SCM rest
),
6550 "Return @code{#t} if the list of parameters is monotonically\n"
6552 #define FUNC_NAME s_scm_i_num_gr_p
6554 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6556 while (!scm_is_null (rest
))
6558 if (scm_is_false (scm_gr_p (x
, y
)))
6562 rest
= scm_cdr (rest
);
6564 return scm_gr_p (x
, y
);
6567 #define FUNC_NAME s_scm_i_num_gr_p
6569 scm_gr_p (SCM x
, SCM y
)
6571 if (!SCM_NUMBERP (x
))
6572 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6573 else if (!SCM_NUMBERP (y
))
6574 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6576 return scm_less_p (y
, x
);
6581 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6582 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6583 (SCM x
, SCM y
, SCM rest
),
6584 "Return @code{#t} if the list of parameters is monotonically\n"
6586 #define FUNC_NAME s_scm_i_num_leq_p
6588 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6590 while (!scm_is_null (rest
))
6592 if (scm_is_false (scm_leq_p (x
, y
)))
6596 rest
= scm_cdr (rest
);
6598 return scm_leq_p (x
, y
);
6601 #define FUNC_NAME s_scm_i_num_leq_p
6603 scm_leq_p (SCM x
, SCM y
)
6605 if (!SCM_NUMBERP (x
))
6606 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6607 else if (!SCM_NUMBERP (y
))
6608 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6609 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6612 return scm_not (scm_less_p (y
, x
));
6617 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6618 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6619 (SCM x
, SCM y
, SCM rest
),
6620 "Return @code{#t} if the list of parameters is monotonically\n"
6622 #define FUNC_NAME s_scm_i_num_geq_p
6624 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6626 while (!scm_is_null (rest
))
6628 if (scm_is_false (scm_geq_p (x
, y
)))
6632 rest
= scm_cdr (rest
);
6634 return scm_geq_p (x
, y
);
6637 #define FUNC_NAME s_scm_i_num_geq_p
6639 scm_geq_p (SCM x
, SCM y
)
6641 if (!SCM_NUMBERP (x
))
6642 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6643 else if (!SCM_NUMBERP (y
))
6644 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6645 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6648 return scm_not (scm_less_p (x
, y
));
6653 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6655 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6657 #define FUNC_NAME s_scm_zero_p
6659 if (SCM_I_INUMP (z
))
6660 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6661 else if (SCM_BIGP (z
))
6663 else if (SCM_REALP (z
))
6664 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6665 else if (SCM_COMPLEXP (z
))
6666 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6667 && SCM_COMPLEX_IMAG (z
) == 0.0);
6668 else if (SCM_FRACTIONP (z
))
6671 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6676 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6678 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6680 #define FUNC_NAME s_scm_positive_p
6682 if (SCM_I_INUMP (x
))
6683 return scm_from_bool (SCM_I_INUM (x
) > 0);
6684 else if (SCM_BIGP (x
))
6686 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6687 scm_remember_upto_here_1 (x
);
6688 return scm_from_bool (sgn
> 0);
6690 else if (SCM_REALP (x
))
6691 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6692 else if (SCM_FRACTIONP (x
))
6693 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6695 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6700 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6702 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6704 #define FUNC_NAME s_scm_negative_p
6706 if (SCM_I_INUMP (x
))
6707 return scm_from_bool (SCM_I_INUM (x
) < 0);
6708 else if (SCM_BIGP (x
))
6710 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6711 scm_remember_upto_here_1 (x
);
6712 return scm_from_bool (sgn
< 0);
6714 else if (SCM_REALP (x
))
6715 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6716 else if (SCM_FRACTIONP (x
))
6717 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6719 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6724 /* scm_min and scm_max return an inexact when either argument is inexact, as
6725 required by r5rs. On that basis, for exact/inexact combinations the
6726 exact is converted to inexact to compare and possibly return. This is
6727 unlike scm_less_p above which takes some trouble to preserve all bits in
6728 its test, such trouble is not required for min and max. */
6730 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6731 (SCM x
, SCM y
, SCM rest
),
6732 "Return the maximum of all parameter values.")
6733 #define FUNC_NAME s_scm_i_max
6735 while (!scm_is_null (rest
))
6736 { x
= scm_max (x
, y
);
6738 rest
= scm_cdr (rest
);
6740 return scm_max (x
, y
);
6744 #define s_max s_scm_i_max
6745 #define g_max g_scm_i_max
6748 scm_max (SCM x
, SCM y
)
6753 return scm_wta_dispatch_0 (g_max
, s_max
);
6754 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6757 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
6760 if (SCM_I_INUMP (x
))
6762 scm_t_inum xx
= SCM_I_INUM (x
);
6763 if (SCM_I_INUMP (y
))
6765 scm_t_inum yy
= SCM_I_INUM (y
);
6766 return (xx
< yy
) ? y
: x
;
6768 else if (SCM_BIGP (y
))
6770 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6771 scm_remember_upto_here_1 (y
);
6772 return (sgn
< 0) ? x
: y
;
6774 else if (SCM_REALP (y
))
6777 double yyd
= SCM_REAL_VALUE (y
);
6780 return scm_from_double (xxd
);
6781 /* If y is a NaN, then "==" is false and we return the NaN */
6782 else if (SCM_LIKELY (!(xxd
== yyd
)))
6784 /* Handle signed zeroes properly */
6790 else if (SCM_FRACTIONP (y
))
6793 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6796 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6798 else if (SCM_BIGP (x
))
6800 if (SCM_I_INUMP (y
))
6802 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6803 scm_remember_upto_here_1 (x
);
6804 return (sgn
< 0) ? y
: x
;
6806 else if (SCM_BIGP (y
))
6808 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6809 scm_remember_upto_here_2 (x
, y
);
6810 return (cmp
> 0) ? x
: y
;
6812 else if (SCM_REALP (y
))
6814 /* if y==NaN then xx>yy is false, so we return the NaN y */
6817 xx
= scm_i_big2dbl (x
);
6818 yy
= SCM_REAL_VALUE (y
);
6819 return (xx
> yy
? scm_from_double (xx
) : y
);
6821 else if (SCM_FRACTIONP (y
))
6826 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6828 else if (SCM_REALP (x
))
6830 if (SCM_I_INUMP (y
))
6832 scm_t_inum yy
= SCM_I_INUM (y
);
6833 double xxd
= SCM_REAL_VALUE (x
);
6837 return scm_from_double (yyd
);
6838 /* If x is a NaN, then "==" is false and we return the NaN */
6839 else if (SCM_LIKELY (!(xxd
== yyd
)))
6841 /* Handle signed zeroes properly */
6847 else if (SCM_BIGP (y
))
6852 else if (SCM_REALP (y
))
6854 double xx
= SCM_REAL_VALUE (x
);
6855 double yy
= SCM_REAL_VALUE (y
);
6857 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6860 else if (SCM_LIKELY (xx
< yy
))
6862 /* If neither (xx > yy) nor (xx < yy), then
6863 either they're equal or one is a NaN */
6864 else if (SCM_UNLIKELY (isnan (xx
)))
6865 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6866 else if (SCM_UNLIKELY (isnan (yy
)))
6867 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6868 /* xx == yy, but handle signed zeroes properly */
6869 else if (double_is_non_negative_zero (yy
))
6874 else if (SCM_FRACTIONP (y
))
6876 double yy
= scm_i_fraction2double (y
);
6877 double xx
= SCM_REAL_VALUE (x
);
6878 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6881 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6883 else if (SCM_FRACTIONP (x
))
6885 if (SCM_I_INUMP (y
))
6889 else if (SCM_BIGP (y
))
6893 else if (SCM_REALP (y
))
6895 double xx
= scm_i_fraction2double (x
);
6896 /* if y==NaN then ">" is false, so we return the NaN y */
6897 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6899 else if (SCM_FRACTIONP (y
))
6904 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6907 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6911 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6912 (SCM x
, SCM y
, SCM rest
),
6913 "Return the minimum of all parameter values.")
6914 #define FUNC_NAME s_scm_i_min
6916 while (!scm_is_null (rest
))
6917 { x
= scm_min (x
, y
);
6919 rest
= scm_cdr (rest
);
6921 return scm_min (x
, y
);
6925 #define s_min s_scm_i_min
6926 #define g_min g_scm_i_min
6929 scm_min (SCM x
, SCM y
)
6934 return scm_wta_dispatch_0 (g_min
, s_min
);
6935 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6938 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
6941 if (SCM_I_INUMP (x
))
6943 scm_t_inum xx
= SCM_I_INUM (x
);
6944 if (SCM_I_INUMP (y
))
6946 scm_t_inum yy
= SCM_I_INUM (y
);
6947 return (xx
< yy
) ? x
: y
;
6949 else if (SCM_BIGP (y
))
6951 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6952 scm_remember_upto_here_1 (y
);
6953 return (sgn
< 0) ? y
: x
;
6955 else if (SCM_REALP (y
))
6958 /* if y==NaN then "<" is false and we return NaN */
6959 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6961 else if (SCM_FRACTIONP (y
))
6964 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6967 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6969 else if (SCM_BIGP (x
))
6971 if (SCM_I_INUMP (y
))
6973 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6974 scm_remember_upto_here_1 (x
);
6975 return (sgn
< 0) ? x
: y
;
6977 else if (SCM_BIGP (y
))
6979 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6980 scm_remember_upto_here_2 (x
, y
);
6981 return (cmp
> 0) ? y
: x
;
6983 else if (SCM_REALP (y
))
6985 /* if y==NaN then xx<yy is false, so we return the NaN y */
6988 xx
= scm_i_big2dbl (x
);
6989 yy
= SCM_REAL_VALUE (y
);
6990 return (xx
< yy
? scm_from_double (xx
) : y
);
6992 else if (SCM_FRACTIONP (y
))
6997 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6999 else if (SCM_REALP (x
))
7001 if (SCM_I_INUMP (y
))
7003 double z
= SCM_I_INUM (y
);
7004 /* if x==NaN then "<" is false and we return NaN */
7005 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
7007 else if (SCM_BIGP (y
))
7012 else if (SCM_REALP (y
))
7014 double xx
= SCM_REAL_VALUE (x
);
7015 double yy
= SCM_REAL_VALUE (y
);
7017 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
7020 else if (SCM_LIKELY (xx
> yy
))
7022 /* If neither (xx < yy) nor (xx > yy), then
7023 either they're equal or one is a NaN */
7024 else if (SCM_UNLIKELY (isnan (xx
)))
7025 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
7026 else if (SCM_UNLIKELY (isnan (yy
)))
7027 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
7028 /* xx == yy, but handle signed zeroes properly */
7029 else if (double_is_non_negative_zero (xx
))
7034 else if (SCM_FRACTIONP (y
))
7036 double yy
= scm_i_fraction2double (y
);
7037 double xx
= SCM_REAL_VALUE (x
);
7038 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7041 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7043 else if (SCM_FRACTIONP (x
))
7045 if (SCM_I_INUMP (y
))
7049 else if (SCM_BIGP (y
))
7053 else if (SCM_REALP (y
))
7055 double xx
= scm_i_fraction2double (x
);
7056 /* if y==NaN then "<" is false, so we return the NaN y */
7057 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7059 else if (SCM_FRACTIONP (y
))
7064 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7067 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7071 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7072 (SCM x
, SCM y
, SCM rest
),
7073 "Return the sum of all parameter values. Return 0 if called without\n"
7075 #define FUNC_NAME s_scm_i_sum
7077 while (!scm_is_null (rest
))
7078 { x
= scm_sum (x
, y
);
7080 rest
= scm_cdr (rest
);
7082 return scm_sum (x
, y
);
7086 #define s_sum s_scm_i_sum
7087 #define g_sum g_scm_i_sum
7090 scm_sum (SCM x
, SCM y
)
7092 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7094 if (SCM_NUMBERP (x
)) return x
;
7095 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7096 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7099 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7101 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7103 scm_t_inum xx
= SCM_I_INUM (x
);
7104 scm_t_inum yy
= SCM_I_INUM (y
);
7105 scm_t_inum z
= xx
+ yy
;
7106 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7108 else if (SCM_BIGP (y
))
7113 else if (SCM_REALP (y
))
7115 scm_t_inum xx
= SCM_I_INUM (x
);
7116 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7118 else if (SCM_COMPLEXP (y
))
7120 scm_t_inum xx
= SCM_I_INUM (x
);
7121 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7122 SCM_COMPLEX_IMAG (y
));
7124 else if (SCM_FRACTIONP (y
))
7125 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7126 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7127 SCM_FRACTION_DENOMINATOR (y
));
7129 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7130 } else if (SCM_BIGP (x
))
7132 if (SCM_I_INUMP (y
))
7137 inum
= SCM_I_INUM (y
);
7140 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7143 SCM result
= scm_i_mkbig ();
7144 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7145 scm_remember_upto_here_1 (x
);
7146 /* we know the result will have to be a bignum */
7149 return scm_i_normbig (result
);
7153 SCM result
= scm_i_mkbig ();
7154 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7155 scm_remember_upto_here_1 (x
);
7156 /* we know the result will have to be a bignum */
7159 return scm_i_normbig (result
);
7162 else if (SCM_BIGP (y
))
7164 SCM result
= scm_i_mkbig ();
7165 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7166 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7167 mpz_add (SCM_I_BIG_MPZ (result
),
7170 scm_remember_upto_here_2 (x
, y
);
7171 /* we know the result will have to be a bignum */
7174 return scm_i_normbig (result
);
7176 else if (SCM_REALP (y
))
7178 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7179 scm_remember_upto_here_1 (x
);
7180 return scm_from_double (result
);
7182 else if (SCM_COMPLEXP (y
))
7184 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7185 + SCM_COMPLEX_REAL (y
));
7186 scm_remember_upto_here_1 (x
);
7187 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7189 else if (SCM_FRACTIONP (y
))
7190 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7191 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7192 SCM_FRACTION_DENOMINATOR (y
));
7194 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7196 else if (SCM_REALP (x
))
7198 if (SCM_I_INUMP (y
))
7199 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7200 else if (SCM_BIGP (y
))
7202 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7203 scm_remember_upto_here_1 (y
);
7204 return scm_from_double (result
);
7206 else if (SCM_REALP (y
))
7207 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7208 else if (SCM_COMPLEXP (y
))
7209 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7210 SCM_COMPLEX_IMAG (y
));
7211 else if (SCM_FRACTIONP (y
))
7212 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7214 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7216 else if (SCM_COMPLEXP (x
))
7218 if (SCM_I_INUMP (y
))
7219 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7220 SCM_COMPLEX_IMAG (x
));
7221 else if (SCM_BIGP (y
))
7223 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7224 + SCM_COMPLEX_REAL (x
));
7225 scm_remember_upto_here_1 (y
);
7226 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7228 else if (SCM_REALP (y
))
7229 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7230 SCM_COMPLEX_IMAG (x
));
7231 else if (SCM_COMPLEXP (y
))
7232 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7233 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7234 else if (SCM_FRACTIONP (y
))
7235 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7236 SCM_COMPLEX_IMAG (x
));
7238 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7240 else if (SCM_FRACTIONP (x
))
7242 if (SCM_I_INUMP (y
))
7243 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7244 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7245 SCM_FRACTION_DENOMINATOR (x
));
7246 else if (SCM_BIGP (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_REALP (y
))
7251 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7252 else if (SCM_COMPLEXP (y
))
7253 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7254 SCM_COMPLEX_IMAG (y
));
7255 else if (SCM_FRACTIONP (y
))
7256 /* a/b + c/d = (ad + bc) / bd */
7257 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7258 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7259 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7261 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7264 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7268 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7270 "Return @math{@var{x}+1}.")
7271 #define FUNC_NAME s_scm_oneplus
7273 return scm_sum (x
, SCM_INUM1
);
7278 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7279 (SCM x
, SCM y
, SCM rest
),
7280 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7281 "the sum of all but the first argument are subtracted from the first\n"
7283 #define FUNC_NAME s_scm_i_difference
7285 while (!scm_is_null (rest
))
7286 { x
= scm_difference (x
, y
);
7288 rest
= scm_cdr (rest
);
7290 return scm_difference (x
, y
);
7294 #define s_difference s_scm_i_difference
7295 #define g_difference g_scm_i_difference
7298 scm_difference (SCM x
, SCM y
)
7299 #define FUNC_NAME s_difference
7301 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7304 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7306 if (SCM_I_INUMP (x
))
7308 scm_t_inum xx
= -SCM_I_INUM (x
);
7309 if (SCM_FIXABLE (xx
))
7310 return SCM_I_MAKINUM (xx
);
7312 return scm_i_inum2big (xx
);
7314 else if (SCM_BIGP (x
))
7315 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7316 bignum, but negating that gives a fixnum. */
7317 return scm_i_normbig (scm_i_clonebig (x
, 0));
7318 else if (SCM_REALP (x
))
7319 return scm_from_double (-SCM_REAL_VALUE (x
));
7320 else if (SCM_COMPLEXP (x
))
7321 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7322 -SCM_COMPLEX_IMAG (x
));
7323 else if (SCM_FRACTIONP (x
))
7324 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7325 SCM_FRACTION_DENOMINATOR (x
));
7327 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7330 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7332 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7334 scm_t_inum xx
= SCM_I_INUM (x
);
7335 scm_t_inum yy
= SCM_I_INUM (y
);
7336 scm_t_inum z
= xx
- yy
;
7337 if (SCM_FIXABLE (z
))
7338 return SCM_I_MAKINUM (z
);
7340 return scm_i_inum2big (z
);
7342 else if (SCM_BIGP (y
))
7344 /* inum-x - big-y */
7345 scm_t_inum xx
= SCM_I_INUM (x
);
7349 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7350 bignum, but negating that gives a fixnum. */
7351 return scm_i_normbig (scm_i_clonebig (y
, 0));
7355 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7356 SCM result
= scm_i_mkbig ();
7359 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7362 /* x - y == -(y + -x) */
7363 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7364 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7366 scm_remember_upto_here_1 (y
);
7368 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7369 /* we know the result will have to be a bignum */
7372 return scm_i_normbig (result
);
7375 else if (SCM_REALP (y
))
7377 scm_t_inum xx
= SCM_I_INUM (x
);
7380 * We need to handle x == exact 0
7381 * specially because R6RS states that:
7382 * (- 0.0) ==> -0.0 and
7383 * (- 0.0 0.0) ==> 0.0
7384 * and the scheme compiler changes
7385 * (- 0.0) into (- 0 0.0)
7386 * So we need to treat (- 0 0.0) like (- 0.0).
7387 * At the C level, (-x) is different than (0.0 - x).
7388 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7391 return scm_from_double (- SCM_REAL_VALUE (y
));
7393 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7395 else if (SCM_COMPLEXP (y
))
7397 scm_t_inum xx
= SCM_I_INUM (x
);
7399 /* We need to handle x == exact 0 specially.
7400 See the comment above (for SCM_REALP (y)) */
7402 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7403 - SCM_COMPLEX_IMAG (y
));
7405 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7406 - SCM_COMPLEX_IMAG (y
));
7408 else if (SCM_FRACTIONP (y
))
7409 /* a - b/c = (ac - b) / c */
7410 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7411 SCM_FRACTION_NUMERATOR (y
)),
7412 SCM_FRACTION_DENOMINATOR (y
));
7414 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7416 else if (SCM_BIGP (x
))
7418 if (SCM_I_INUMP (y
))
7420 /* big-x - inum-y */
7421 scm_t_inum yy
= SCM_I_INUM (y
);
7422 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7424 scm_remember_upto_here_1 (x
);
7426 return (SCM_FIXABLE (-yy
) ?
7427 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7430 SCM result
= scm_i_mkbig ();
7433 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7435 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7436 scm_remember_upto_here_1 (x
);
7438 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7439 /* we know the result will have to be a bignum */
7442 return scm_i_normbig (result
);
7445 else if (SCM_BIGP (y
))
7447 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7448 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7449 SCM result
= scm_i_mkbig ();
7450 mpz_sub (SCM_I_BIG_MPZ (result
),
7453 scm_remember_upto_here_2 (x
, y
);
7454 /* we know the result will have to be a bignum */
7455 if ((sgn_x
== 1) && (sgn_y
== -1))
7457 if ((sgn_x
== -1) && (sgn_y
== 1))
7459 return scm_i_normbig (result
);
7461 else if (SCM_REALP (y
))
7463 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7464 scm_remember_upto_here_1 (x
);
7465 return scm_from_double (result
);
7467 else if (SCM_COMPLEXP (y
))
7469 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7470 - SCM_COMPLEX_REAL (y
));
7471 scm_remember_upto_here_1 (x
);
7472 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7474 else if (SCM_FRACTIONP (y
))
7475 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7476 SCM_FRACTION_NUMERATOR (y
)),
7477 SCM_FRACTION_DENOMINATOR (y
));
7479 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7481 else if (SCM_REALP (x
))
7483 if (SCM_I_INUMP (y
))
7484 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7485 else if (SCM_BIGP (y
))
7487 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7488 scm_remember_upto_here_1 (x
);
7489 return scm_from_double (result
);
7491 else if (SCM_REALP (y
))
7492 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7493 else if (SCM_COMPLEXP (y
))
7494 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7495 -SCM_COMPLEX_IMAG (y
));
7496 else if (SCM_FRACTIONP (y
))
7497 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7499 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7501 else if (SCM_COMPLEXP (x
))
7503 if (SCM_I_INUMP (y
))
7504 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7505 SCM_COMPLEX_IMAG (x
));
7506 else if (SCM_BIGP (y
))
7508 double real_part
= (SCM_COMPLEX_REAL (x
)
7509 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7510 scm_remember_upto_here_1 (x
);
7511 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7513 else if (SCM_REALP (y
))
7514 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7515 SCM_COMPLEX_IMAG (x
));
7516 else if (SCM_COMPLEXP (y
))
7517 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7518 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7519 else if (SCM_FRACTIONP (y
))
7520 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7521 SCM_COMPLEX_IMAG (x
));
7523 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7525 else if (SCM_FRACTIONP (x
))
7527 if (SCM_I_INUMP (y
))
7528 /* a/b - c = (a - cb) / b */
7529 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7530 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7531 SCM_FRACTION_DENOMINATOR (x
));
7532 else if (SCM_BIGP (y
))
7533 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7534 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7535 SCM_FRACTION_DENOMINATOR (x
));
7536 else if (SCM_REALP (y
))
7537 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7538 else if (SCM_COMPLEXP (y
))
7539 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7540 -SCM_COMPLEX_IMAG (y
));
7541 else if (SCM_FRACTIONP (y
))
7542 /* a/b - c/d = (ad - bc) / bd */
7543 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7544 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7545 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7547 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7550 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7555 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7557 "Return @math{@var{x}-1}.")
7558 #define FUNC_NAME s_scm_oneminus
7560 return scm_difference (x
, SCM_INUM1
);
7565 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7566 (SCM x
, SCM y
, SCM rest
),
7567 "Return the product of all arguments. If called without arguments,\n"
7569 #define FUNC_NAME s_scm_i_product
7571 while (!scm_is_null (rest
))
7572 { x
= scm_product (x
, y
);
7574 rest
= scm_cdr (rest
);
7576 return scm_product (x
, y
);
7580 #define s_product s_scm_i_product
7581 #define g_product g_scm_i_product
7584 scm_product (SCM x
, SCM y
)
7586 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7589 return SCM_I_MAKINUM (1L);
7590 else if (SCM_NUMBERP (x
))
7593 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
7596 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7601 xx
= SCM_I_INUM (x
);
7606 /* exact1 is the universal multiplicative identity */
7610 /* exact0 times a fixnum is exact0: optimize this case */
7611 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7613 /* if the other argument is inexact, the result is inexact,
7614 and we must do the multiplication in order to handle
7615 infinities and NaNs properly. */
7616 else if (SCM_REALP (y
))
7617 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7618 else if (SCM_COMPLEXP (y
))
7619 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7620 0.0 * SCM_COMPLEX_IMAG (y
));
7621 /* we've already handled inexact numbers,
7622 so y must be exact, and we return exact0 */
7623 else if (SCM_NUMP (y
))
7626 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7630 * This case is important for more than just optimization.
7631 * It handles the case of negating
7632 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7633 * which is a bignum that must be changed back into a fixnum.
7634 * Failure to do so will cause the following to return #f:
7635 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7637 return scm_difference(y
, SCM_UNDEFINED
);
7641 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7643 scm_t_inum yy
= SCM_I_INUM (y
);
7644 scm_t_inum kk
= xx
* yy
;
7645 SCM k
= SCM_I_MAKINUM (kk
);
7646 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7650 SCM result
= scm_i_inum2big (xx
);
7651 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7652 return scm_i_normbig (result
);
7655 else if (SCM_BIGP (y
))
7657 SCM result
= scm_i_mkbig ();
7658 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7659 scm_remember_upto_here_1 (y
);
7662 else if (SCM_REALP (y
))
7663 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7664 else if (SCM_COMPLEXP (y
))
7665 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7666 xx
* SCM_COMPLEX_IMAG (y
));
7667 else if (SCM_FRACTIONP (y
))
7668 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7669 SCM_FRACTION_DENOMINATOR (y
));
7671 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7673 else if (SCM_BIGP (x
))
7675 if (SCM_I_INUMP (y
))
7680 else if (SCM_BIGP (y
))
7682 SCM result
= scm_i_mkbig ();
7683 mpz_mul (SCM_I_BIG_MPZ (result
),
7686 scm_remember_upto_here_2 (x
, y
);
7689 else if (SCM_REALP (y
))
7691 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7692 scm_remember_upto_here_1 (x
);
7693 return scm_from_double (result
);
7695 else if (SCM_COMPLEXP (y
))
7697 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7698 scm_remember_upto_here_1 (x
);
7699 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7700 z
* SCM_COMPLEX_IMAG (y
));
7702 else if (SCM_FRACTIONP (y
))
7703 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7704 SCM_FRACTION_DENOMINATOR (y
));
7706 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7708 else if (SCM_REALP (x
))
7710 if (SCM_I_INUMP (y
))
7715 else if (SCM_BIGP (y
))
7717 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7718 scm_remember_upto_here_1 (y
);
7719 return scm_from_double (result
);
7721 else if (SCM_REALP (y
))
7722 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7723 else if (SCM_COMPLEXP (y
))
7724 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7725 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7726 else if (SCM_FRACTIONP (y
))
7727 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7729 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7731 else if (SCM_COMPLEXP (x
))
7733 if (SCM_I_INUMP (y
))
7738 else if (SCM_BIGP (y
))
7740 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7741 scm_remember_upto_here_1 (y
);
7742 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7743 z
* SCM_COMPLEX_IMAG (x
));
7745 else if (SCM_REALP (y
))
7746 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7747 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7748 else if (SCM_COMPLEXP (y
))
7750 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7751 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7752 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7753 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7755 else if (SCM_FRACTIONP (y
))
7757 double yy
= scm_i_fraction2double (y
);
7758 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7759 yy
* SCM_COMPLEX_IMAG (x
));
7762 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7764 else if (SCM_FRACTIONP (x
))
7766 if (SCM_I_INUMP (y
))
7767 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7768 SCM_FRACTION_DENOMINATOR (x
));
7769 else if (SCM_BIGP (y
))
7770 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7771 SCM_FRACTION_DENOMINATOR (x
));
7772 else if (SCM_REALP (y
))
7773 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7774 else if (SCM_COMPLEXP (y
))
7776 double xx
= scm_i_fraction2double (x
);
7777 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7778 xx
* SCM_COMPLEX_IMAG (y
));
7780 else if (SCM_FRACTIONP (y
))
7781 /* a/b * c/d = ac / bd */
7782 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7783 SCM_FRACTION_NUMERATOR (y
)),
7784 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7785 SCM_FRACTION_DENOMINATOR (y
)));
7787 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7790 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7793 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7794 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7795 #define ALLOW_DIVIDE_BY_ZERO
7796 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7799 /* The code below for complex division is adapted from the GNU
7800 libstdc++, which adapted it from f2c's libF77, and is subject to
7803 /****************************************************************
7804 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7806 Permission to use, copy, modify, and distribute this software
7807 and its documentation for any purpose and without fee is hereby
7808 granted, provided that the above copyright notice appear in all
7809 copies and that both that the copyright notice and this
7810 permission notice and warranty disclaimer appear in supporting
7811 documentation, and that the names of AT&T Bell Laboratories or
7812 Bellcore or any of their entities not be used in advertising or
7813 publicity pertaining to distribution of the software without
7814 specific, written prior permission.
7816 AT&T and Bellcore disclaim all warranties with regard to this
7817 software, including all implied warranties of merchantability
7818 and fitness. In no event shall AT&T or Bellcore be liable for
7819 any special, indirect or consequential damages or any damages
7820 whatsoever resulting from loss of use, data or profits, whether
7821 in an action of contract, negligence or other tortious action,
7822 arising out of or in connection with the use or performance of
7824 ****************************************************************/
7826 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7827 (SCM x
, SCM y
, SCM rest
),
7828 "Divide the first argument by the product of the remaining\n"
7829 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7831 #define FUNC_NAME s_scm_i_divide
7833 while (!scm_is_null (rest
))
7834 { x
= scm_divide (x
, y
);
7836 rest
= scm_cdr (rest
);
7838 return scm_divide (x
, y
);
7842 #define s_divide s_scm_i_divide
7843 #define g_divide g_scm_i_divide
7846 do_divide (SCM x
, SCM y
, int inexact
)
7847 #define FUNC_NAME s_divide
7851 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7854 return scm_wta_dispatch_0 (g_divide
, s_divide
);
7855 else if (SCM_I_INUMP (x
))
7857 scm_t_inum xx
= SCM_I_INUM (x
);
7858 if (xx
== 1 || xx
== -1)
7860 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7862 scm_num_overflow (s_divide
);
7867 return scm_from_double (1.0 / (double) xx
);
7868 else return scm_i_make_ratio (SCM_INUM1
, x
);
7871 else if (SCM_BIGP (x
))
7874 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7875 else return scm_i_make_ratio (SCM_INUM1
, x
);
7877 else if (SCM_REALP (x
))
7879 double xx
= SCM_REAL_VALUE (x
);
7880 #ifndef ALLOW_DIVIDE_BY_ZERO
7882 scm_num_overflow (s_divide
);
7885 return scm_from_double (1.0 / xx
);
7887 else if (SCM_COMPLEXP (x
))
7889 double r
= SCM_COMPLEX_REAL (x
);
7890 double i
= SCM_COMPLEX_IMAG (x
);
7891 if (fabs(r
) <= fabs(i
))
7894 double d
= i
* (1.0 + t
* t
);
7895 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7900 double d
= r
* (1.0 + t
* t
);
7901 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7904 else if (SCM_FRACTIONP (x
))
7905 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7906 SCM_FRACTION_NUMERATOR (x
));
7908 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7911 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7913 scm_t_inum xx
= SCM_I_INUM (x
);
7914 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7916 scm_t_inum yy
= SCM_I_INUM (y
);
7919 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7920 scm_num_overflow (s_divide
);
7922 return scm_from_double ((double) xx
/ (double) yy
);
7925 else if (xx
% yy
!= 0)
7928 return scm_from_double ((double) xx
/ (double) yy
);
7929 else return scm_i_make_ratio (x
, y
);
7933 scm_t_inum z
= xx
/ yy
;
7934 if (SCM_FIXABLE (z
))
7935 return SCM_I_MAKINUM (z
);
7937 return scm_i_inum2big (z
);
7940 else if (SCM_BIGP (y
))
7943 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7944 else return scm_i_make_ratio (x
, y
);
7946 else if (SCM_REALP (y
))
7948 double yy
= SCM_REAL_VALUE (y
);
7949 #ifndef ALLOW_DIVIDE_BY_ZERO
7951 scm_num_overflow (s_divide
);
7954 return scm_from_double ((double) xx
/ yy
);
7956 else if (SCM_COMPLEXP (y
))
7959 complex_div
: /* y _must_ be a complex number */
7961 double r
= SCM_COMPLEX_REAL (y
);
7962 double i
= SCM_COMPLEX_IMAG (y
);
7963 if (fabs(r
) <= fabs(i
))
7966 double d
= i
* (1.0 + t
* t
);
7967 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7972 double d
= r
* (1.0 + t
* t
);
7973 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7977 else if (SCM_FRACTIONP (y
))
7978 /* a / b/c = ac / b */
7979 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7980 SCM_FRACTION_NUMERATOR (y
));
7982 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7984 else if (SCM_BIGP (x
))
7986 if (SCM_I_INUMP (y
))
7988 scm_t_inum yy
= SCM_I_INUM (y
);
7991 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7992 scm_num_overflow (s_divide
);
7994 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7995 scm_remember_upto_here_1 (x
);
7996 return (sgn
== 0) ? scm_nan () : scm_inf ();
8003 /* FIXME: HMM, what are the relative performance issues here?
8004 We need to test. Is it faster on average to test
8005 divisible_p, then perform whichever operation, or is it
8006 faster to perform the integer div opportunistically and
8007 switch to real if there's a remainder? For now we take the
8008 middle ground: test, then if divisible, use the faster div
8011 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
8012 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
8016 SCM result
= scm_i_mkbig ();
8017 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
8018 scm_remember_upto_here_1 (x
);
8020 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
8021 return scm_i_normbig (result
);
8026 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
8027 else return scm_i_make_ratio (x
, y
);
8031 else if (SCM_BIGP (y
))
8036 /* It's easily possible for the ratio x/y to fit a double
8037 but one or both x and y be too big to fit a double,
8038 hence the use of mpq_get_d rather than converting and
8041 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8042 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8043 return scm_from_double (mpq_get_d (q
));
8047 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8051 SCM result
= scm_i_mkbig ();
8052 mpz_divexact (SCM_I_BIG_MPZ (result
),
8055 scm_remember_upto_here_2 (x
, y
);
8056 return scm_i_normbig (result
);
8059 return scm_i_make_ratio (x
, y
);
8062 else if (SCM_REALP (y
))
8064 double yy
= SCM_REAL_VALUE (y
);
8065 #ifndef ALLOW_DIVIDE_BY_ZERO
8067 scm_num_overflow (s_divide
);
8070 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8072 else if (SCM_COMPLEXP (y
))
8074 a
= scm_i_big2dbl (x
);
8077 else if (SCM_FRACTIONP (y
))
8078 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8079 SCM_FRACTION_NUMERATOR (y
));
8081 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8083 else if (SCM_REALP (x
))
8085 double rx
= SCM_REAL_VALUE (x
);
8086 if (SCM_I_INUMP (y
))
8088 scm_t_inum yy
= SCM_I_INUM (y
);
8089 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8091 scm_num_overflow (s_divide
);
8094 return scm_from_double (rx
/ (double) yy
);
8096 else if (SCM_BIGP (y
))
8098 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8099 scm_remember_upto_here_1 (y
);
8100 return scm_from_double (rx
/ dby
);
8102 else if (SCM_REALP (y
))
8104 double yy
= SCM_REAL_VALUE (y
);
8105 #ifndef ALLOW_DIVIDE_BY_ZERO
8107 scm_num_overflow (s_divide
);
8110 return scm_from_double (rx
/ yy
);
8112 else if (SCM_COMPLEXP (y
))
8117 else if (SCM_FRACTIONP (y
))
8118 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8120 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8122 else if (SCM_COMPLEXP (x
))
8124 double rx
= SCM_COMPLEX_REAL (x
);
8125 double ix
= SCM_COMPLEX_IMAG (x
);
8126 if (SCM_I_INUMP (y
))
8128 scm_t_inum yy
= SCM_I_INUM (y
);
8129 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8131 scm_num_overflow (s_divide
);
8136 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8139 else if (SCM_BIGP (y
))
8141 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8142 scm_remember_upto_here_1 (y
);
8143 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8145 else if (SCM_REALP (y
))
8147 double yy
= SCM_REAL_VALUE (y
);
8148 #ifndef ALLOW_DIVIDE_BY_ZERO
8150 scm_num_overflow (s_divide
);
8153 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8155 else if (SCM_COMPLEXP (y
))
8157 double ry
= SCM_COMPLEX_REAL (y
);
8158 double iy
= SCM_COMPLEX_IMAG (y
);
8159 if (fabs(ry
) <= fabs(iy
))
8162 double d
= iy
* (1.0 + t
* t
);
8163 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8168 double d
= ry
* (1.0 + t
* t
);
8169 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8172 else if (SCM_FRACTIONP (y
))
8174 double yy
= scm_i_fraction2double (y
);
8175 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8178 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8180 else if (SCM_FRACTIONP (x
))
8182 if (SCM_I_INUMP (y
))
8184 scm_t_inum yy
= SCM_I_INUM (y
);
8185 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8187 scm_num_overflow (s_divide
);
8190 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8191 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8193 else if (SCM_BIGP (y
))
8195 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8196 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8198 else if (SCM_REALP (y
))
8200 double yy
= SCM_REAL_VALUE (y
);
8201 #ifndef ALLOW_DIVIDE_BY_ZERO
8203 scm_num_overflow (s_divide
);
8206 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8208 else if (SCM_COMPLEXP (y
))
8210 a
= scm_i_fraction2double (x
);
8213 else if (SCM_FRACTIONP (y
))
8214 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8215 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8217 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8220 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8224 scm_divide (SCM x
, SCM y
)
8226 return do_divide (x
, y
, 0);
8229 static SCM
scm_divide2real (SCM x
, SCM y
)
8231 return do_divide (x
, y
, 1);
8237 scm_c_truncate (double x
)
8242 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8243 half-way case (ie. when x is an integer plus 0.5) going upwards.
8244 Then half-way cases are identified and adjusted down if the
8245 round-upwards didn't give the desired even integer.
8247 "plus_half == result" identifies a half-way case. If plus_half, which is
8248 x + 0.5, is an integer then x must be an integer plus 0.5.
8250 An odd "result" value is identified with result/2 != floor(result/2).
8251 This is done with plus_half, since that value is ready for use sooner in
8252 a pipelined cpu, and we're already requiring plus_half == result.
8254 Note however that we need to be careful when x is big and already an
8255 integer. In that case "x+0.5" may round to an adjacent integer, causing
8256 us to return such a value, incorrectly. For instance if the hardware is
8257 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8258 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8259 returned. Or if the hardware is in round-upwards mode, then other bigger
8260 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8261 representable value, 2^128+2^76 (or whatever), again incorrect.
8263 These bad roundings of x+0.5 are avoided by testing at the start whether
8264 x is already an integer. If it is then clearly that's the desired result
8265 already. And if it's not then the exponent must be small enough to allow
8266 an 0.5 to be represented, and hence added without a bad rounding. */
8269 scm_c_round (double x
)
8271 double plus_half
, result
;
8276 plus_half
= x
+ 0.5;
8277 result
= floor (plus_half
);
8278 /* Adjust so that the rounding is towards even. */
8279 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8284 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8286 "Round the number @var{x} towards zero.")
8287 #define FUNC_NAME s_scm_truncate_number
8289 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8291 else if (SCM_REALP (x
))
8292 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8293 else if (SCM_FRACTIONP (x
))
8294 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8295 SCM_FRACTION_DENOMINATOR (x
));
8297 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8298 s_scm_truncate_number
);
8302 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8304 "Round the number @var{x} towards the nearest integer. "
8305 "When it is exactly halfway between two integers, "
8306 "round towards the even one.")
8307 #define FUNC_NAME s_scm_round_number
8309 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8311 else if (SCM_REALP (x
))
8312 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8313 else if (SCM_FRACTIONP (x
))
8314 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8315 SCM_FRACTION_DENOMINATOR (x
));
8317 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8318 s_scm_round_number
);
8322 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8324 "Round the number @var{x} towards minus infinity.")
8325 #define FUNC_NAME s_scm_floor
8327 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8329 else if (SCM_REALP (x
))
8330 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8331 else if (SCM_FRACTIONP (x
))
8332 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8333 SCM_FRACTION_DENOMINATOR (x
));
8335 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8339 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8341 "Round the number @var{x} towards infinity.")
8342 #define FUNC_NAME s_scm_ceiling
8344 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8346 else if (SCM_REALP (x
))
8347 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8348 else if (SCM_FRACTIONP (x
))
8349 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8350 SCM_FRACTION_DENOMINATOR (x
));
8352 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8356 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8358 "Return @var{x} raised to the power of @var{y}.")
8359 #define FUNC_NAME s_scm_expt
8361 if (scm_is_integer (y
))
8363 if (scm_is_true (scm_exact_p (y
)))
8364 return scm_integer_expt (x
, y
);
8367 /* Here we handle the case where the exponent is an inexact
8368 integer. We make the exponent exact in order to use
8369 scm_integer_expt, and thus avoid the spurious imaginary
8370 parts that may result from round-off errors in the general
8371 e^(y log x) method below (for example when squaring a large
8372 negative number). In this case, we must return an inexact
8373 result for correctness. We also make the base inexact so
8374 that scm_integer_expt will use fast inexact arithmetic
8375 internally. Note that making the base inexact is not
8376 sufficient to guarantee an inexact result, because
8377 scm_integer_expt will return an exact 1 when the exponent
8378 is 0, even if the base is inexact. */
8379 return scm_exact_to_inexact
8380 (scm_integer_expt (scm_exact_to_inexact (x
),
8381 scm_inexact_to_exact (y
)));
8384 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8386 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8388 else if (scm_is_complex (x
) && scm_is_complex (y
))
8389 return scm_exp (scm_product (scm_log (x
), y
));
8390 else if (scm_is_complex (x
))
8391 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8393 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8397 /* sin/cos/tan/asin/acos/atan
8398 sinh/cosh/tanh/asinh/acosh/atanh
8399 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8400 Written by Jerry D. Hedden, (C) FSF.
8401 See the file `COPYING' for terms applying to this program. */
8403 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8405 "Compute the sine of @var{z}.")
8406 #define FUNC_NAME s_scm_sin
8408 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8409 return z
; /* sin(exact0) = exact0 */
8410 else if (scm_is_real (z
))
8411 return scm_from_double (sin (scm_to_double (z
)));
8412 else if (SCM_COMPLEXP (z
))
8414 x
= SCM_COMPLEX_REAL (z
);
8415 y
= SCM_COMPLEX_IMAG (z
);
8416 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8417 cos (x
) * sinh (y
));
8420 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8424 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8426 "Compute the cosine of @var{z}.")
8427 #define FUNC_NAME s_scm_cos
8429 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8430 return SCM_INUM1
; /* cos(exact0) = exact1 */
8431 else if (scm_is_real (z
))
8432 return scm_from_double (cos (scm_to_double (z
)));
8433 else if (SCM_COMPLEXP (z
))
8435 x
= SCM_COMPLEX_REAL (z
);
8436 y
= SCM_COMPLEX_IMAG (z
);
8437 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8438 -sin (x
) * sinh (y
));
8441 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8445 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8447 "Compute the tangent of @var{z}.")
8448 #define FUNC_NAME s_scm_tan
8450 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8451 return z
; /* tan(exact0) = exact0 */
8452 else if (scm_is_real (z
))
8453 return scm_from_double (tan (scm_to_double (z
)));
8454 else if (SCM_COMPLEXP (z
))
8456 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8457 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8458 w
= cos (x
) + cosh (y
);
8459 #ifndef ALLOW_DIVIDE_BY_ZERO
8461 scm_num_overflow (s_scm_tan
);
8463 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8466 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8470 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8472 "Compute the hyperbolic sine of @var{z}.")
8473 #define FUNC_NAME s_scm_sinh
8475 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8476 return z
; /* sinh(exact0) = exact0 */
8477 else if (scm_is_real (z
))
8478 return scm_from_double (sinh (scm_to_double (z
)));
8479 else if (SCM_COMPLEXP (z
))
8481 x
= SCM_COMPLEX_REAL (z
);
8482 y
= SCM_COMPLEX_IMAG (z
);
8483 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8484 cosh (x
) * sin (y
));
8487 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8491 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8493 "Compute the hyperbolic cosine of @var{z}.")
8494 #define FUNC_NAME s_scm_cosh
8496 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8497 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8498 else if (scm_is_real (z
))
8499 return scm_from_double (cosh (scm_to_double (z
)));
8500 else if (SCM_COMPLEXP (z
))
8502 x
= SCM_COMPLEX_REAL (z
);
8503 y
= SCM_COMPLEX_IMAG (z
);
8504 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8505 sinh (x
) * sin (y
));
8508 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8512 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8514 "Compute the hyperbolic tangent of @var{z}.")
8515 #define FUNC_NAME s_scm_tanh
8517 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8518 return z
; /* tanh(exact0) = exact0 */
8519 else if (scm_is_real (z
))
8520 return scm_from_double (tanh (scm_to_double (z
)));
8521 else if (SCM_COMPLEXP (z
))
8523 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8524 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8525 w
= cosh (x
) + cos (y
);
8526 #ifndef ALLOW_DIVIDE_BY_ZERO
8528 scm_num_overflow (s_scm_tanh
);
8530 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8533 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8537 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8539 "Compute the arc sine of @var{z}.")
8540 #define FUNC_NAME s_scm_asin
8542 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8543 return z
; /* asin(exact0) = exact0 */
8544 else if (scm_is_real (z
))
8546 double w
= scm_to_double (z
);
8547 if (w
>= -1.0 && w
<= 1.0)
8548 return scm_from_double (asin (w
));
8550 return scm_product (scm_c_make_rectangular (0, -1),
8551 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8553 else if (SCM_COMPLEXP (z
))
8555 x
= SCM_COMPLEX_REAL (z
);
8556 y
= SCM_COMPLEX_IMAG (z
);
8557 return scm_product (scm_c_make_rectangular (0, -1),
8558 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8561 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8565 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8567 "Compute the arc cosine of @var{z}.")
8568 #define FUNC_NAME s_scm_acos
8570 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8571 return SCM_INUM0
; /* acos(exact1) = exact0 */
8572 else if (scm_is_real (z
))
8574 double w
= scm_to_double (z
);
8575 if (w
>= -1.0 && w
<= 1.0)
8576 return scm_from_double (acos (w
));
8578 return scm_sum (scm_from_double (acos (0.0)),
8579 scm_product (scm_c_make_rectangular (0, 1),
8580 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8582 else if (SCM_COMPLEXP (z
))
8584 x
= SCM_COMPLEX_REAL (z
);
8585 y
= SCM_COMPLEX_IMAG (z
);
8586 return scm_sum (scm_from_double (acos (0.0)),
8587 scm_product (scm_c_make_rectangular (0, 1),
8588 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8591 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8595 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8597 "With one argument, compute the arc tangent of @var{z}.\n"
8598 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8599 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8600 #define FUNC_NAME s_scm_atan
8604 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8605 return z
; /* atan(exact0) = exact0 */
8606 else if (scm_is_real (z
))
8607 return scm_from_double (atan (scm_to_double (z
)));
8608 else if (SCM_COMPLEXP (z
))
8611 v
= SCM_COMPLEX_REAL (z
);
8612 w
= SCM_COMPLEX_IMAG (z
);
8613 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8614 scm_c_make_rectangular (v
, w
+ 1.0))),
8615 scm_c_make_rectangular (0, 2));
8618 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8620 else if (scm_is_real (z
))
8622 if (scm_is_real (y
))
8623 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8625 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8628 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8632 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8634 "Compute the inverse hyperbolic sine of @var{z}.")
8635 #define FUNC_NAME s_scm_sys_asinh
8637 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8638 return z
; /* asinh(exact0) = exact0 */
8639 else if (scm_is_real (z
))
8640 return scm_from_double (asinh (scm_to_double (z
)));
8641 else if (scm_is_number (z
))
8642 return scm_log (scm_sum (z
,
8643 scm_sqrt (scm_sum (scm_product (z
, z
),
8646 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8650 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8652 "Compute the inverse hyperbolic cosine of @var{z}.")
8653 #define FUNC_NAME s_scm_sys_acosh
8655 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8656 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8657 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8658 return scm_from_double (acosh (scm_to_double (z
)));
8659 else if (scm_is_number (z
))
8660 return scm_log (scm_sum (z
,
8661 scm_sqrt (scm_difference (scm_product (z
, z
),
8664 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8668 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8670 "Compute the inverse hyperbolic tangent of @var{z}.")
8671 #define FUNC_NAME s_scm_sys_atanh
8673 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8674 return z
; /* atanh(exact0) = exact0 */
8675 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8676 return scm_from_double (atanh (scm_to_double (z
)));
8677 else if (scm_is_number (z
))
8678 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8679 scm_difference (SCM_INUM1
, z
))),
8682 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8687 scm_c_make_rectangular (double re
, double im
)
8691 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8693 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8694 SCM_COMPLEX_REAL (z
) = re
;
8695 SCM_COMPLEX_IMAG (z
) = im
;
8699 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8700 (SCM real_part
, SCM imaginary_part
),
8701 "Return a complex number constructed of the given @var{real-part} "
8702 "and @var{imaginary-part} parts.")
8703 #define FUNC_NAME s_scm_make_rectangular
8705 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8706 SCM_ARG1
, FUNC_NAME
, "real");
8707 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8708 SCM_ARG2
, FUNC_NAME
, "real");
8710 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8711 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8714 return scm_c_make_rectangular (scm_to_double (real_part
),
8715 scm_to_double (imaginary_part
));
8720 scm_c_make_polar (double mag
, double ang
)
8724 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8725 use it on Glibc-based systems that have it (it's a GNU extension). See
8726 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8728 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8729 sincos (ang
, &s
, &c
);
8735 /* If s and c are NaNs, this indicates that the angle is a NaN,
8736 infinite, or perhaps simply too large to determine its value
8737 mod 2*pi. However, we know something that the floating-point
8738 implementation doesn't know: We know that s and c are finite.
8739 Therefore, if the magnitude is zero, return a complex zero.
8741 The reason we check for the NaNs instead of using this case
8742 whenever mag == 0.0 is because when the angle is known, we'd
8743 like to return the correct kind of non-real complex zero:
8744 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8745 on which quadrant the angle is in.
8747 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8748 return scm_c_make_rectangular (0.0, 0.0);
8750 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8753 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8755 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8756 #define FUNC_NAME s_scm_make_polar
8758 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8759 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8761 /* If mag is exact0, return exact0 */
8762 if (scm_is_eq (mag
, SCM_INUM0
))
8764 /* Return a real if ang is exact0 */
8765 else if (scm_is_eq (ang
, SCM_INUM0
))
8768 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8773 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8775 "Return the real part of the number @var{z}.")
8776 #define FUNC_NAME s_scm_real_part
8778 if (SCM_COMPLEXP (z
))
8779 return scm_from_double (SCM_COMPLEX_REAL (z
));
8780 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8783 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8788 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8790 "Return the imaginary part of the number @var{z}.")
8791 #define FUNC_NAME s_scm_imag_part
8793 if (SCM_COMPLEXP (z
))
8794 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8795 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8798 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8802 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8804 "Return the numerator of the number @var{z}.")
8805 #define FUNC_NAME s_scm_numerator
8807 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8809 else if (SCM_FRACTIONP (z
))
8810 return SCM_FRACTION_NUMERATOR (z
);
8811 else if (SCM_REALP (z
))
8812 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8814 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8819 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8821 "Return the denominator of the number @var{z}.")
8822 #define FUNC_NAME s_scm_denominator
8824 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8826 else if (SCM_FRACTIONP (z
))
8827 return SCM_FRACTION_DENOMINATOR (z
);
8828 else if (SCM_REALP (z
))
8829 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8831 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
8837 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8839 "Return the magnitude of the number @var{z}. This is the same as\n"
8840 "@code{abs} for real arguments, but also allows complex numbers.")
8841 #define FUNC_NAME s_scm_magnitude
8843 if (SCM_I_INUMP (z
))
8845 scm_t_inum zz
= SCM_I_INUM (z
);
8848 else if (SCM_POSFIXABLE (-zz
))
8849 return SCM_I_MAKINUM (-zz
);
8851 return scm_i_inum2big (-zz
);
8853 else if (SCM_BIGP (z
))
8855 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8856 scm_remember_upto_here_1 (z
);
8858 return scm_i_clonebig (z
, 0);
8862 else if (SCM_REALP (z
))
8863 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8864 else if (SCM_COMPLEXP (z
))
8865 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8866 else if (SCM_FRACTIONP (z
))
8868 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8870 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8871 SCM_FRACTION_DENOMINATOR (z
));
8874 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
8880 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8882 "Return the angle of the complex number @var{z}.")
8883 #define FUNC_NAME s_scm_angle
8885 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8886 flo0 to save allocating a new flonum with scm_from_double each time.
8887 But if atan2 follows the floating point rounding mode, then the value
8888 is not a constant. Maybe it'd be close enough though. */
8889 if (SCM_I_INUMP (z
))
8891 if (SCM_I_INUM (z
) >= 0)
8894 return scm_from_double (atan2 (0.0, -1.0));
8896 else if (SCM_BIGP (z
))
8898 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8899 scm_remember_upto_here_1 (z
);
8901 return scm_from_double (atan2 (0.0, -1.0));
8905 else if (SCM_REALP (z
))
8907 if (SCM_REAL_VALUE (z
) >= 0)
8910 return scm_from_double (atan2 (0.0, -1.0));
8912 else if (SCM_COMPLEXP (z
))
8913 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8914 else if (SCM_FRACTIONP (z
))
8916 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8918 else return scm_from_double (atan2 (0.0, -1.0));
8921 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8926 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8928 "Convert the number @var{z} to its inexact representation.\n")
8929 #define FUNC_NAME s_scm_exact_to_inexact
8931 if (SCM_I_INUMP (z
))
8932 return scm_from_double ((double) SCM_I_INUM (z
));
8933 else if (SCM_BIGP (z
))
8934 return scm_from_double (scm_i_big2dbl (z
));
8935 else if (SCM_FRACTIONP (z
))
8936 return scm_from_double (scm_i_fraction2double (z
));
8937 else if (SCM_INEXACTP (z
))
8940 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
8941 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 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
8963 s_scm_inexact_to_exact
);
8965 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8966 SCM_OUT_OF_RANGE (1, z
);
8973 mpq_set_d (frac
, val
);
8974 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8975 scm_i_mpz2num (mpq_denref (frac
)));
8977 /* When scm_i_make_ratio throws, we leak the memory allocated
8987 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8989 "Returns the @emph{simplest} rational number differing\n"
8990 "from @var{x} by no more than @var{eps}.\n"
8992 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8993 "exact result when both its arguments are exact. Thus, you might need\n"
8994 "to use @code{inexact->exact} on the arguments.\n"
8997 "(rationalize (inexact->exact 1.2) 1/100)\n"
9000 #define FUNC_NAME s_scm_rationalize
9002 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
9003 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
9004 eps
= scm_abs (eps
);
9005 if (scm_is_false (scm_positive_p (eps
)))
9007 /* eps is either zero or a NaN */
9008 if (scm_is_true (scm_nan_p (eps
)))
9010 else if (SCM_INEXACTP (eps
))
9011 return scm_exact_to_inexact (x
);
9015 else if (scm_is_false (scm_finite_p (eps
)))
9017 if (scm_is_true (scm_finite_p (x
)))
9022 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
9024 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
9025 scm_ceiling (scm_difference (x
, eps
)))))
9027 /* There's an integer within range; we want the one closest to zero */
9028 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
9030 /* zero is within range */
9031 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9036 else if (scm_is_true (scm_positive_p (x
)))
9037 return scm_ceiling (scm_difference (x
, eps
));
9039 return scm_floor (scm_sum (x
, eps
));
9043 /* Use continued fractions to find closest ratio. All
9044 arithmetic is done with exact numbers.
9047 SCM ex
= scm_inexact_to_exact (x
);
9048 SCM int_part
= scm_floor (ex
);
9050 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9051 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9055 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9056 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9058 /* We stop after a million iterations just to be absolutely sure
9059 that we don't go into an infinite loop. The process normally
9060 converges after less than a dozen iterations.
9063 while (++i
< 1000000)
9065 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9066 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9067 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9069 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9070 eps
))) /* abs(x-a/b) <= eps */
9072 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9073 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9074 return scm_exact_to_inexact (res
);
9078 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9080 tt
= scm_floor (rx
); /* tt = floor (rx) */
9086 scm_num_overflow (s_scm_rationalize
);
9091 /* conversion functions */
9094 scm_is_integer (SCM val
)
9096 return scm_is_true (scm_integer_p (val
));
9100 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9102 if (SCM_I_INUMP (val
))
9104 scm_t_signed_bits n
= SCM_I_INUM (val
);
9105 return n
>= min
&& n
<= max
;
9107 else if (SCM_BIGP (val
))
9109 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9111 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9113 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9115 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9116 return n
>= min
&& n
<= max
;
9126 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9127 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9130 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9131 SCM_I_BIG_MPZ (val
));
9133 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9145 return n
>= min
&& n
<= max
;
9153 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9155 if (SCM_I_INUMP (val
))
9157 scm_t_signed_bits n
= SCM_I_INUM (val
);
9158 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9160 else if (SCM_BIGP (val
))
9162 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9164 else if (max
<= ULONG_MAX
)
9166 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9168 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9169 return n
>= min
&& n
<= max
;
9179 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9182 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9183 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9186 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9187 SCM_I_BIG_MPZ (val
));
9189 return n
>= min
&& n
<= max
;
9197 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9199 scm_error (scm_out_of_range_key
,
9201 "Value out of range ~S to ~S: ~S",
9202 scm_list_3 (min
, max
, bad_val
),
9203 scm_list_1 (bad_val
));
9206 #define TYPE scm_t_intmax
9207 #define TYPE_MIN min
9208 #define TYPE_MAX max
9209 #define SIZEOF_TYPE 0
9210 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9211 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9212 #include "libguile/conv-integer.i.c"
9214 #define TYPE scm_t_uintmax
9215 #define TYPE_MIN min
9216 #define TYPE_MAX max
9217 #define SIZEOF_TYPE 0
9218 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9219 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9220 #include "libguile/conv-uinteger.i.c"
9222 #define TYPE scm_t_int8
9223 #define TYPE_MIN SCM_T_INT8_MIN
9224 #define TYPE_MAX SCM_T_INT8_MAX
9225 #define SIZEOF_TYPE 1
9226 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9227 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9228 #include "libguile/conv-integer.i.c"
9230 #define TYPE scm_t_uint8
9232 #define TYPE_MAX SCM_T_UINT8_MAX
9233 #define SIZEOF_TYPE 1
9234 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9235 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9236 #include "libguile/conv-uinteger.i.c"
9238 #define TYPE scm_t_int16
9239 #define TYPE_MIN SCM_T_INT16_MIN
9240 #define TYPE_MAX SCM_T_INT16_MAX
9241 #define SIZEOF_TYPE 2
9242 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9243 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9244 #include "libguile/conv-integer.i.c"
9246 #define TYPE scm_t_uint16
9248 #define TYPE_MAX SCM_T_UINT16_MAX
9249 #define SIZEOF_TYPE 2
9250 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9251 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9252 #include "libguile/conv-uinteger.i.c"
9254 #define TYPE scm_t_int32
9255 #define TYPE_MIN SCM_T_INT32_MIN
9256 #define TYPE_MAX SCM_T_INT32_MAX
9257 #define SIZEOF_TYPE 4
9258 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9259 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9260 #include "libguile/conv-integer.i.c"
9262 #define TYPE scm_t_uint32
9264 #define TYPE_MAX SCM_T_UINT32_MAX
9265 #define SIZEOF_TYPE 4
9266 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9267 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9268 #include "libguile/conv-uinteger.i.c"
9270 #define TYPE scm_t_wchar
9271 #define TYPE_MIN (scm_t_int32)-1
9272 #define TYPE_MAX (scm_t_int32)0x10ffff
9273 #define SIZEOF_TYPE 4
9274 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9275 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9276 #include "libguile/conv-integer.i.c"
9278 #define TYPE scm_t_int64
9279 #define TYPE_MIN SCM_T_INT64_MIN
9280 #define TYPE_MAX SCM_T_INT64_MAX
9281 #define SIZEOF_TYPE 8
9282 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9283 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9284 #include "libguile/conv-integer.i.c"
9286 #define TYPE scm_t_uint64
9288 #define TYPE_MAX SCM_T_UINT64_MAX
9289 #define SIZEOF_TYPE 8
9290 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9291 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9292 #include "libguile/conv-uinteger.i.c"
9295 scm_to_mpz (SCM val
, mpz_t rop
)
9297 if (SCM_I_INUMP (val
))
9298 mpz_set_si (rop
, SCM_I_INUM (val
));
9299 else if (SCM_BIGP (val
))
9300 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9302 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9306 scm_from_mpz (mpz_t val
)
9308 return scm_i_mpz2num (val
);
9312 scm_is_real (SCM val
)
9314 return scm_is_true (scm_real_p (val
));
9318 scm_is_rational (SCM val
)
9320 return scm_is_true (scm_rational_p (val
));
9324 scm_to_double (SCM val
)
9326 if (SCM_I_INUMP (val
))
9327 return SCM_I_INUM (val
);
9328 else if (SCM_BIGP (val
))
9329 return scm_i_big2dbl (val
);
9330 else if (SCM_FRACTIONP (val
))
9331 return scm_i_fraction2double (val
);
9332 else if (SCM_REALP (val
))
9333 return SCM_REAL_VALUE (val
);
9335 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9339 scm_from_double (double val
)
9343 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9345 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9346 SCM_REAL_VALUE (z
) = val
;
9352 scm_is_complex (SCM val
)
9354 return scm_is_true (scm_complex_p (val
));
9358 scm_c_real_part (SCM z
)
9360 if (SCM_COMPLEXP (z
))
9361 return SCM_COMPLEX_REAL (z
);
9364 /* Use the scm_real_part to get proper error checking and
9367 return scm_to_double (scm_real_part (z
));
9372 scm_c_imag_part (SCM z
)
9374 if (SCM_COMPLEXP (z
))
9375 return SCM_COMPLEX_IMAG (z
);
9378 /* Use the scm_imag_part to get proper error checking and
9379 dispatching. The result will almost always be 0.0, but not
9382 return scm_to_double (scm_imag_part (z
));
9387 scm_c_magnitude (SCM z
)
9389 return scm_to_double (scm_magnitude (z
));
9395 return scm_to_double (scm_angle (z
));
9399 scm_is_number (SCM z
)
9401 return scm_is_true (scm_number_p (z
));
9405 /* Returns log(x * 2^shift) */
9407 log_of_shifted_double (double x
, long shift
)
9409 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9411 if (x
> 0.0 || double_is_non_negative_zero (x
))
9412 return scm_from_double (ans
);
9414 return scm_c_make_rectangular (ans
, M_PI
);
9417 /* Returns log(n), for exact integer n of integer-length size */
9419 log_of_exact_integer_with_size (SCM n
, long size
)
9421 long shift
= size
- 2 * scm_dblprec
[0];
9424 return log_of_shifted_double
9425 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9428 return log_of_shifted_double (scm_to_double (n
), 0);
9431 /* Returns log(n), for exact integer n */
9433 log_of_exact_integer (SCM n
)
9435 return log_of_exact_integer_with_size
9436 (n
, scm_to_long (scm_integer_length (n
)));
9439 /* Returns log(n/d), for exact non-zero integers n and d */
9441 log_of_fraction (SCM n
, SCM d
)
9443 long n_size
= scm_to_long (scm_integer_length (n
));
9444 long d_size
= scm_to_long (scm_integer_length (d
));
9446 if (abs (n_size
- d_size
) > 1)
9447 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9448 log_of_exact_integer_with_size (d
, d_size
)));
9449 else if (scm_is_false (scm_negative_p (n
)))
9450 return scm_from_double
9451 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9453 return scm_c_make_rectangular
9454 (log1p (scm_to_double (scm_divide2real
9455 (scm_difference (scm_abs (n
), d
),
9461 /* In the following functions we dispatch to the real-arg funcs like log()
9462 when we know the arg is real, instead of just handing everything to
9463 clog() for instance. This is in case clog() doesn't optimize for a
9464 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9465 well use it to go straight to the applicable C func. */
9467 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9469 "Return the natural logarithm of @var{z}.")
9470 #define FUNC_NAME s_scm_log
9472 if (SCM_COMPLEXP (z
))
9474 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9475 && defined (SCM_COMPLEX_VALUE)
9476 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9478 double re
= SCM_COMPLEX_REAL (z
);
9479 double im
= SCM_COMPLEX_IMAG (z
);
9480 return scm_c_make_rectangular (log (hypot (re
, im
)),
9484 else if (SCM_REALP (z
))
9485 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9486 else if (SCM_I_INUMP (z
))
9488 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9489 if (scm_is_eq (z
, SCM_INUM0
))
9490 scm_num_overflow (s_scm_log
);
9492 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9494 else if (SCM_BIGP (z
))
9495 return log_of_exact_integer (z
);
9496 else if (SCM_FRACTIONP (z
))
9497 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9498 SCM_FRACTION_DENOMINATOR (z
));
9500 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
9505 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9507 "Return the base 10 logarithm of @var{z}.")
9508 #define FUNC_NAME s_scm_log10
9510 if (SCM_COMPLEXP (z
))
9512 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9513 clog() and a multiply by M_LOG10E, rather than the fallback
9514 log10+hypot+atan2.) */
9515 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9516 && defined SCM_COMPLEX_VALUE
9517 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9519 double re
= SCM_COMPLEX_REAL (z
);
9520 double im
= SCM_COMPLEX_IMAG (z
);
9521 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9522 M_LOG10E
* atan2 (im
, re
));
9525 else if (SCM_REALP (z
) || 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_log10
);
9532 double re
= scm_to_double (z
);
9533 double l
= log10 (fabs (re
));
9534 if (re
> 0.0 || double_is_non_negative_zero (re
))
9535 return scm_from_double (l
);
9537 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9540 else if (SCM_BIGP (z
))
9541 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9542 else if (SCM_FRACTIONP (z
))
9543 return scm_product (flo_log10e
,
9544 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9545 SCM_FRACTION_DENOMINATOR (z
)));
9547 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9552 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9554 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9555 "base of natural logarithms (2.71828@dots{}).")
9556 #define FUNC_NAME s_scm_exp
9558 if (SCM_COMPLEXP (z
))
9560 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9561 && defined (SCM_COMPLEX_VALUE)
9562 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9564 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9565 SCM_COMPLEX_IMAG (z
));
9568 else if (SCM_NUMBERP (z
))
9570 /* When z is a negative bignum the conversion to double overflows,
9571 giving -infinity, but that's ok, the exp is still 0.0. */
9572 return scm_from_double (exp (scm_to_double (z
)));
9575 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9580 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9582 "Return two exact non-negative integers @var{s} and @var{r}\n"
9583 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9584 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9585 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9588 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9590 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9594 scm_exact_integer_sqrt (k
, &s
, &r
);
9595 return scm_values (scm_list_2 (s
, r
));
9600 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9602 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9604 scm_t_inum kk
= SCM_I_INUM (k
);
9608 if (SCM_LIKELY (kk
> 0))
9613 uu
= (ss
+ kk
/ss
) / 2;
9615 *sp
= SCM_I_MAKINUM (ss
);
9616 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9618 else if (SCM_LIKELY (kk
== 0))
9619 *sp
= *rp
= SCM_INUM0
;
9621 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9622 "exact non-negative integer");
9624 else if (SCM_LIKELY (SCM_BIGP (k
)))
9628 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9629 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9630 "exact non-negative integer");
9633 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9634 scm_remember_upto_here_1 (k
);
9635 *sp
= scm_i_normbig (s
);
9636 *rp
= scm_i_normbig (r
);
9639 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9640 "exact non-negative integer");
9644 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9646 "Return the square root of @var{z}. Of the two possible roots\n"
9647 "(positive and negative), the one with positive real part\n"
9648 "is returned, or if that's zero then a positive imaginary part.\n"
9652 "(sqrt 9.0) @result{} 3.0\n"
9653 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9654 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9655 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9657 #define FUNC_NAME s_scm_sqrt
9659 if (SCM_COMPLEXP (z
))
9661 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9662 && defined SCM_COMPLEX_VALUE
9663 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9665 double re
= SCM_COMPLEX_REAL (z
);
9666 double im
= SCM_COMPLEX_IMAG (z
);
9667 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9668 0.5 * atan2 (im
, re
));
9671 else if (SCM_NUMBERP (z
))
9673 double xx
= scm_to_double (z
);
9675 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9677 return scm_from_double (sqrt (xx
));
9680 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9691 if (scm_install_gmp_memory_functions
)
9692 mp_set_memory_functions (custom_gmp_malloc
,
9696 mpz_init_set_si (z_negative_one
, -1);
9698 /* It may be possible to tune the performance of some algorithms by using
9699 * the following constants to avoid the creation of bignums. Please, before
9700 * using these values, remember the two rules of program optimization:
9701 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9702 scm_c_define ("most-positive-fixnum",
9703 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9704 scm_c_define ("most-negative-fixnum",
9705 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9707 scm_add_feature ("complex");
9708 scm_add_feature ("inexact");
9709 flo0
= scm_from_double (0.0);
9710 flo_log10e
= scm_from_double (M_LOG10E
);
9712 /* determine floating point precision */
9713 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9715 init_dblprec(&scm_dblprec
[i
-2],i
);
9716 init_fx_radix(fx_per_radix
[i
-2],i
);
9719 /* hard code precision for base 10 if the preprocessor tells us to... */
9720 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9723 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9724 #include "libguile/numbers.x"