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 */
118 static SCM exactly_one_half
;
119 static SCM flo_log10e
;
121 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
123 /* FLOBUFLEN is the maximum number of characters neccessary for the
124 * printed or scm_string representation of an inexact number.
126 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
129 #if !defined (HAVE_ASINH)
130 static double asinh (double x
) { return log (x
+ sqrt (x
* x
+ 1)); }
132 #if !defined (HAVE_ACOSH)
133 static double acosh (double x
) { return log (x
+ sqrt (x
* x
- 1)); }
135 #if !defined (HAVE_ATANH)
136 static double atanh (double x
) { return 0.5 * log ((1 + x
) / (1 - x
)); }
139 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
140 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
141 in March 2006), mpz_cmp_d now handles infinities properly. */
143 #define xmpz_cmp_d(z, d) \
144 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
146 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
150 #if defined (GUILE_I)
151 #if defined HAVE_COMPLEX_DOUBLE
153 /* For an SCM object Z which is a complex number (ie. satisfies
154 SCM_COMPLEXP), return its value as a C level "complex double". */
155 #define SCM_COMPLEX_VALUE(z) \
156 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
158 static inline SCM
scm_from_complex_double (complex double z
) SCM_UNUSED
;
160 /* Convert a C "complex double" to an SCM value. */
162 scm_from_complex_double (complex double z
)
164 return scm_c_make_rectangular (creal (z
), cimag (z
));
167 #endif /* HAVE_COMPLEX_DOUBLE */
172 static mpz_t z_negative_one
;
175 /* Clear the `mpz_t' embedded in bignum PTR. */
177 finalize_bignum (GC_PTR ptr
, GC_PTR data
)
181 bignum
= SCM_PACK_POINTER (ptr
);
182 mpz_clear (SCM_I_BIG_MPZ (bignum
));
185 /* Return a new uninitialized bignum. */
190 GC_finalization_proc prev_finalizer
;
191 GC_PTR prev_finalizer_data
;
193 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
194 p
= scm_gc_malloc_pointerless (sizeof (scm_t_bits
) + sizeof (mpz_t
),
198 GC_REGISTER_FINALIZER_NO_ORDER (p
, finalize_bignum
, NULL
,
200 &prev_finalizer_data
);
209 /* Return a newly created bignum. */
210 SCM z
= make_bignum ();
211 mpz_init (SCM_I_BIG_MPZ (z
));
216 scm_i_inum2big (scm_t_inum x
)
218 /* Return a newly created bignum initialized to X. */
219 SCM z
= make_bignum ();
220 #if SIZEOF_VOID_P == SIZEOF_LONG
221 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
223 /* Note that in this case, you'll also have to check all mpz_*_ui and
224 mpz_*_si invocations in Guile. */
225 #error creation of mpz not implemented for this inum size
231 scm_i_long2big (long x
)
233 /* Return a newly created bignum initialized to X. */
234 SCM z
= make_bignum ();
235 mpz_init_set_si (SCM_I_BIG_MPZ (z
), x
);
240 scm_i_ulong2big (unsigned long x
)
242 /* Return a newly created bignum initialized to X. */
243 SCM z
= make_bignum ();
244 mpz_init_set_ui (SCM_I_BIG_MPZ (z
), x
);
249 scm_i_clonebig (SCM src_big
, int same_sign_p
)
251 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
252 SCM z
= make_bignum ();
253 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
255 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
260 scm_i_bigcmp (SCM x
, SCM y
)
262 /* Return neg if x < y, pos if x > y, and 0 if x == y */
263 /* presume we already know x and y are bignums */
264 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
265 scm_remember_upto_here_2 (x
, y
);
270 scm_i_dbl2big (double d
)
272 /* results are only defined if d is an integer */
273 SCM z
= make_bignum ();
274 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
278 /* Convert a integer in double representation to a SCM number. */
281 scm_i_dbl2num (double u
)
283 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
284 powers of 2, so there's no rounding when making "double" values
285 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
286 get rounded on a 64-bit machine, hence the "+1".
288 The use of floor() to force to an integer value ensures we get a
289 "numerically closest" value without depending on how a
290 double->long cast or how mpz_set_d will round. For reference,
291 double->long probably follows the hardware rounding mode,
292 mpz_set_d truncates towards zero. */
294 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
295 representable as a double? */
297 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
298 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
299 return SCM_I_MAKINUM ((scm_t_inum
) u
);
301 return scm_i_dbl2big (u
);
304 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
305 with R5RS exact->inexact.
307 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
308 (ie. truncate towards zero), then adjust to get the closest double by
309 examining the next lower bit and adding 1 (to the absolute value) if
312 Bignums exactly half way between representable doubles are rounded to the
313 next higher absolute value (ie. away from zero). This seems like an
314 adequate interpretation of R5RS "numerically closest", and it's easier
315 and faster than a full "nearest-even" style.
317 The bit test must be done on the absolute value of the mpz_t, which means
318 we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
319 negatives as twos complement.
321 In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
322 following the hardware rounding mode, but applied to the absolute
323 value of the mpz_t operand. This is not what we want so we put the
324 high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
325 (released in March 2006) mpz_get_d now always truncates towards zero.
327 ENHANCE-ME: The temporary init+clear to force the rounding in GMP
328 before 4.2 is a slowdown. It'd be faster to pick out the relevant
329 high bits with mpz_getlimbn. */
332 scm_i_big2dbl (SCM b
)
337 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
341 /* For GMP earlier than 4.2, force truncation towards zero */
343 /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
344 _not_ the number of bits, so this code will break badly on a
345 system with non-binary doubles. */
348 if (bits
> DBL_MANT_DIG
)
350 size_t shift
= bits
- DBL_MANT_DIG
;
351 mpz_init2 (tmp
, DBL_MANT_DIG
);
352 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
353 result
= ldexp (mpz_get_d (tmp
), shift
);
358 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
362 /* GMP 4.2 or later */
363 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
366 if (bits
> DBL_MANT_DIG
)
368 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
369 /* test bit number "pos" in absolute value */
370 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
371 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
373 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
377 scm_remember_upto_here_1 (b
);
382 scm_i_normbig (SCM b
)
384 /* convert a big back to a fixnum if it'll fit */
385 /* presume b is a bignum */
386 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
388 scm_t_inum val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
389 if (SCM_FIXABLE (val
))
390 b
= SCM_I_MAKINUM (val
);
395 static SCM_C_INLINE_KEYWORD SCM
396 scm_i_mpz2num (mpz_t b
)
398 /* convert a mpz number to a SCM number. */
399 if (mpz_fits_slong_p (b
))
401 scm_t_inum val
= mpz_get_si (b
);
402 if (SCM_FIXABLE (val
))
403 return SCM_I_MAKINUM (val
);
407 SCM z
= make_bignum ();
408 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
413 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
414 static SCM
scm_divide2real (SCM x
, SCM y
);
417 scm_i_make_ratio (SCM numerator
, SCM denominator
)
418 #define FUNC_NAME "make-ratio"
420 /* First make sure the arguments are proper.
422 if (SCM_I_INUMP (denominator
))
424 if (scm_is_eq (denominator
, SCM_INUM0
))
425 scm_num_overflow ("make-ratio");
426 if (scm_is_eq (denominator
, SCM_INUM1
))
431 if (!(SCM_BIGP(denominator
)))
432 SCM_WRONG_TYPE_ARG (2, denominator
);
434 if (!SCM_I_INUMP (numerator
) && !SCM_BIGP (numerator
))
435 SCM_WRONG_TYPE_ARG (1, numerator
);
437 /* Then flip signs so that the denominator is positive.
439 if (scm_is_true (scm_negative_p (denominator
)))
441 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
442 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
445 /* Now consider for each of the four fixnum/bignum combinations
446 whether the rational number is really an integer.
448 if (SCM_I_INUMP (numerator
))
450 scm_t_inum x
= SCM_I_INUM (numerator
);
451 if (scm_is_eq (numerator
, SCM_INUM0
))
453 if (SCM_I_INUMP (denominator
))
456 y
= SCM_I_INUM (denominator
);
460 return SCM_I_MAKINUM (x
/ y
);
464 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
465 of that value for the denominator, as a bignum. Apart from
466 that case, abs(bignum) > abs(inum) so inum/bignum is not an
468 if (x
== SCM_MOST_NEGATIVE_FIXNUM
469 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
470 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
471 return SCM_I_MAKINUM(-1);
474 else if (SCM_BIGP (numerator
))
476 if (SCM_I_INUMP (denominator
))
478 scm_t_inum yy
= SCM_I_INUM (denominator
);
479 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
480 return scm_divide (numerator
, denominator
);
484 if (scm_is_eq (numerator
, denominator
))
486 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
487 SCM_I_BIG_MPZ (denominator
)))
488 return scm_divide(numerator
, denominator
);
492 /* No, it's a proper fraction.
495 SCM divisor
= scm_gcd (numerator
, denominator
);
496 if (!(scm_is_eq (divisor
, SCM_INUM1
)))
498 numerator
= scm_divide (numerator
, divisor
);
499 denominator
= scm_divide (denominator
, divisor
);
502 return scm_double_cell (scm_tc16_fraction
,
503 SCM_UNPACK (numerator
),
504 SCM_UNPACK (denominator
), 0);
510 scm_i_fraction2double (SCM z
)
512 return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
513 SCM_FRACTION_DENOMINATOR (z
)));
517 double_is_non_negative_zero (double x
)
519 static double zero
= 0.0;
521 return !memcmp (&x
, &zero
, sizeof(double));
524 SCM_PRIMITIVE_GENERIC (scm_exact_p
, "exact?", 1, 0, 0,
526 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
528 #define FUNC_NAME s_scm_exact_p
530 if (SCM_INEXACTP (x
))
532 else if (SCM_NUMBERP (x
))
535 return scm_wta_dispatch_1 (g_scm_exact_p
, x
, 1, s_scm_exact_p
);
540 scm_is_exact (SCM val
)
542 return scm_is_true (scm_exact_p (val
));
545 SCM_PRIMITIVE_GENERIC (scm_inexact_p
, "inexact?", 1, 0, 0,
547 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
549 #define FUNC_NAME s_scm_inexact_p
551 if (SCM_INEXACTP (x
))
553 else if (SCM_NUMBERP (x
))
556 return scm_wta_dispatch_1 (g_scm_inexact_p
, x
, 1, s_scm_inexact_p
);
561 scm_is_inexact (SCM val
)
563 return scm_is_true (scm_inexact_p (val
));
566 SCM_PRIMITIVE_GENERIC (scm_odd_p
, "odd?", 1, 0, 0,
568 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
570 #define FUNC_NAME s_scm_odd_p
574 scm_t_inum val
= SCM_I_INUM (n
);
575 return scm_from_bool ((val
& 1L) != 0);
577 else if (SCM_BIGP (n
))
579 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
580 scm_remember_upto_here_1 (n
);
581 return scm_from_bool (odd_p
);
583 else if (SCM_REALP (n
))
585 double val
= SCM_REAL_VALUE (n
);
586 if (DOUBLE_IS_FINITE (val
))
588 double rem
= fabs (fmod (val
, 2.0));
595 return scm_wta_dispatch_1 (g_scm_odd_p
, n
, 1, s_scm_odd_p
);
600 SCM_PRIMITIVE_GENERIC (scm_even_p
, "even?", 1, 0, 0,
602 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
604 #define FUNC_NAME s_scm_even_p
608 scm_t_inum val
= SCM_I_INUM (n
);
609 return scm_from_bool ((val
& 1L) == 0);
611 else if (SCM_BIGP (n
))
613 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
614 scm_remember_upto_here_1 (n
);
615 return scm_from_bool (even_p
);
617 else if (SCM_REALP (n
))
619 double val
= SCM_REAL_VALUE (n
);
620 if (DOUBLE_IS_FINITE (val
))
622 double rem
= fabs (fmod (val
, 2.0));
629 return scm_wta_dispatch_1 (g_scm_even_p
, n
, 1, s_scm_even_p
);
633 SCM_PRIMITIVE_GENERIC (scm_finite_p
, "finite?", 1, 0, 0,
635 "Return @code{#t} if the real number @var{x} is neither\n"
636 "infinite nor a NaN, @code{#f} otherwise.")
637 #define FUNC_NAME s_scm_finite_p
640 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
641 else if (scm_is_real (x
))
644 return scm_wta_dispatch_1 (g_scm_finite_p
, x
, 1, s_scm_finite_p
);
648 SCM_PRIMITIVE_GENERIC (scm_inf_p
, "inf?", 1, 0, 0,
650 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
651 "@samp{-inf.0}. Otherwise return @code{#f}.")
652 #define FUNC_NAME s_scm_inf_p
655 return scm_from_bool (isinf (SCM_REAL_VALUE (x
)));
656 else if (scm_is_real (x
))
659 return scm_wta_dispatch_1 (g_scm_inf_p
, x
, 1, s_scm_inf_p
);
663 SCM_PRIMITIVE_GENERIC (scm_nan_p
, "nan?", 1, 0, 0,
665 "Return @code{#t} if the real number @var{x} is a NaN,\n"
666 "or @code{#f} otherwise.")
667 #define FUNC_NAME s_scm_nan_p
670 return scm_from_bool (isnan (SCM_REAL_VALUE (x
)));
671 else if (scm_is_real (x
))
674 return scm_wta_dispatch_1 (g_scm_nan_p
, x
, 1, s_scm_nan_p
);
678 /* Guile's idea of infinity. */
679 static double guile_Inf
;
681 /* Guile's idea of not a number. */
682 static double guile_NaN
;
685 guile_ieee_init (void)
687 /* Some version of gcc on some old version of Linux used to crash when
688 trying to make Inf and NaN. */
691 /* C99 INFINITY, when available.
692 FIXME: The standard allows for INFINITY to be something that overflows
693 at compile time. We ought to have a configure test to check for that
694 before trying to use it. (But in practice we believe this is not a
695 problem on any system guile is likely to target.) */
696 guile_Inf
= INFINITY
;
697 #elif defined HAVE_DINFINITY
699 extern unsigned int DINFINITY
[2];
700 guile_Inf
= (*((double *) (DINFINITY
)));
707 if (guile_Inf
== tmp
)
714 /* C99 NAN, when available */
716 #elif defined HAVE_DQNAN
719 extern unsigned int DQNAN
[2];
720 guile_NaN
= (*((double *)(DQNAN
)));
723 guile_NaN
= guile_Inf
/ guile_Inf
;
727 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
730 #define FUNC_NAME s_scm_inf
732 static int initialized
= 0;
738 return scm_from_double (guile_Inf
);
742 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
745 #define FUNC_NAME s_scm_nan
747 static int initialized
= 0;
753 return scm_from_double (guile_NaN
);
758 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
760 "Return the absolute value of @var{x}.")
761 #define FUNC_NAME s_scm_abs
765 scm_t_inum xx
= SCM_I_INUM (x
);
768 else if (SCM_POSFIXABLE (-xx
))
769 return SCM_I_MAKINUM (-xx
);
771 return scm_i_inum2big (-xx
);
773 else if (SCM_LIKELY (SCM_REALP (x
)))
775 double xx
= SCM_REAL_VALUE (x
);
776 /* If x is a NaN then xx<0 is false so we return x unchanged */
778 return scm_from_double (-xx
);
779 /* Handle signed zeroes properly */
780 else if (SCM_UNLIKELY (xx
== 0.0))
785 else if (SCM_BIGP (x
))
787 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
789 return scm_i_clonebig (x
, 0);
793 else if (SCM_FRACTIONP (x
))
795 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
797 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
798 SCM_FRACTION_DENOMINATOR (x
));
801 return scm_wta_dispatch_1 (g_scm_abs
, x
, 1, s_scm_abs
);
806 SCM_PRIMITIVE_GENERIC (scm_quotient
, "quotient", 2, 0, 0,
808 "Return the quotient of the numbers @var{x} and @var{y}.")
809 #define FUNC_NAME s_scm_quotient
811 if (SCM_LIKELY (scm_is_integer (x
)))
813 if (SCM_LIKELY (scm_is_integer (y
)))
814 return scm_truncate_quotient (x
, y
);
816 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG2
, s_scm_quotient
);
819 return scm_wta_dispatch_2 (g_scm_quotient
, x
, y
, SCM_ARG1
, s_scm_quotient
);
823 SCM_PRIMITIVE_GENERIC (scm_remainder
, "remainder", 2, 0, 0,
825 "Return the remainder of the numbers @var{x} and @var{y}.\n"
827 "(remainder 13 4) @result{} 1\n"
828 "(remainder -13 4) @result{} -1\n"
830 #define FUNC_NAME s_scm_remainder
832 if (SCM_LIKELY (scm_is_integer (x
)))
834 if (SCM_LIKELY (scm_is_integer (y
)))
835 return scm_truncate_remainder (x
, y
);
837 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG2
, s_scm_remainder
);
840 return scm_wta_dispatch_2 (g_scm_remainder
, x
, y
, SCM_ARG1
, s_scm_remainder
);
845 SCM_PRIMITIVE_GENERIC (scm_modulo
, "modulo", 2, 0, 0,
847 "Return the modulo of the numbers @var{x} and @var{y}.\n"
849 "(modulo 13 4) @result{} 1\n"
850 "(modulo -13 4) @result{} 3\n"
852 #define FUNC_NAME s_scm_modulo
854 if (SCM_LIKELY (scm_is_integer (x
)))
856 if (SCM_LIKELY (scm_is_integer (y
)))
857 return scm_floor_remainder (x
, y
);
859 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG2
, s_scm_modulo
);
862 return scm_wta_dispatch_2 (g_scm_modulo
, x
, y
, SCM_ARG1
, s_scm_modulo
);
866 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
867 two-valued functions. It is called from primitive generics that take
868 two arguments and return two values, when the core procedure is
869 unable to handle the given argument types. If there are GOOPS
870 methods for this primitive generic, it dispatches to GOOPS and, if
871 successful, expects two values to be returned, which are placed in
872 *rp1 and *rp2. If there are no GOOPS methods, it throws a
873 wrong-type-arg exception.
875 FIXME: This obviously belongs somewhere else, but until we decide on
876 the right API, it is here as a static function, because it is needed
877 by the *_divide functions below.
880 two_valued_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
,
881 const char *subr
, SCM
*rp1
, SCM
*rp2
)
883 SCM vals
= scm_wta_dispatch_2 (gf
, a1
, a2
, pos
, subr
);
885 scm_i_extract_values_2 (vals
, rp1
, rp2
);
888 SCM_DEFINE (scm_euclidean_quotient
, "euclidean-quotient", 2, 0, 0,
890 "Return the integer @var{q} such that\n"
891 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
892 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
894 "(euclidean-quotient 123 10) @result{} 12\n"
895 "(euclidean-quotient 123 -10) @result{} -12\n"
896 "(euclidean-quotient -123 10) @result{} -13\n"
897 "(euclidean-quotient -123 -10) @result{} 13\n"
898 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
899 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
901 #define FUNC_NAME s_scm_euclidean_quotient
903 if (scm_is_false (scm_negative_p (y
)))
904 return scm_floor_quotient (x
, y
);
906 return scm_ceiling_quotient (x
, y
);
910 SCM_DEFINE (scm_euclidean_remainder
, "euclidean-remainder", 2, 0, 0,
912 "Return the real number @var{r} such that\n"
913 "@math{0 <= @var{r} < abs(@var{y})} and\n"
914 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
915 "for some integer @var{q}.\n"
917 "(euclidean-remainder 123 10) @result{} 3\n"
918 "(euclidean-remainder 123 -10) @result{} 3\n"
919 "(euclidean-remainder -123 10) @result{} 7\n"
920 "(euclidean-remainder -123 -10) @result{} 7\n"
921 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
922 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
924 #define FUNC_NAME s_scm_euclidean_remainder
926 if (scm_is_false (scm_negative_p (y
)))
927 return scm_floor_remainder (x
, y
);
929 return scm_ceiling_remainder (x
, y
);
933 SCM_DEFINE (scm_i_euclidean_divide
, "euclidean/", 2, 0, 0,
935 "Return the integer @var{q} and the real number @var{r}\n"
936 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
937 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
939 "(euclidean/ 123 10) @result{} 12 and 3\n"
940 "(euclidean/ 123 -10) @result{} -12 and 3\n"
941 "(euclidean/ -123 10) @result{} -13 and 7\n"
942 "(euclidean/ -123 -10) @result{} 13 and 7\n"
943 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
944 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
946 #define FUNC_NAME s_scm_i_euclidean_divide
948 if (scm_is_false (scm_negative_p (y
)))
949 return scm_i_floor_divide (x
, y
);
951 return scm_i_ceiling_divide (x
, y
);
956 scm_euclidean_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
958 if (scm_is_false (scm_negative_p (y
)))
959 return scm_floor_divide (x
, y
, qp
, rp
);
961 return scm_ceiling_divide (x
, y
, qp
, rp
);
964 static SCM
scm_i_inexact_floor_quotient (double x
, double y
);
965 static SCM
scm_i_exact_rational_floor_quotient (SCM x
, SCM y
);
967 SCM_PRIMITIVE_GENERIC (scm_floor_quotient
, "floor-quotient", 2, 0, 0,
969 "Return the floor of @math{@var{x} / @var{y}}.\n"
971 "(floor-quotient 123 10) @result{} 12\n"
972 "(floor-quotient 123 -10) @result{} -13\n"
973 "(floor-quotient -123 10) @result{} -13\n"
974 "(floor-quotient -123 -10) @result{} 12\n"
975 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
976 "(floor-quotient 16/3 -10/7) @result{} -4\n"
978 #define FUNC_NAME s_scm_floor_quotient
980 if (SCM_LIKELY (SCM_I_INUMP (x
)))
982 scm_t_inum xx
= SCM_I_INUM (x
);
983 if (SCM_LIKELY (SCM_I_INUMP (y
)))
985 scm_t_inum yy
= SCM_I_INUM (y
);
988 if (SCM_LIKELY (yy
> 0))
990 if (SCM_UNLIKELY (xx
< 0))
993 else if (SCM_UNLIKELY (yy
== 0))
994 scm_num_overflow (s_scm_floor_quotient
);
998 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
999 return SCM_I_MAKINUM (qq
);
1001 return scm_i_inum2big (qq
);
1003 else if (SCM_BIGP (y
))
1005 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1006 scm_remember_upto_here_1 (y
);
1008 return SCM_I_MAKINUM ((xx
< 0) ? -1 : 0);
1010 return SCM_I_MAKINUM ((xx
> 0) ? -1 : 0);
1012 else if (SCM_REALP (y
))
1013 return scm_i_inexact_floor_quotient (xx
, SCM_REAL_VALUE (y
));
1014 else if (SCM_FRACTIONP (y
))
1015 return scm_i_exact_rational_floor_quotient (x
, y
);
1017 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1018 s_scm_floor_quotient
);
1020 else if (SCM_BIGP (x
))
1022 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1024 scm_t_inum yy
= SCM_I_INUM (y
);
1025 if (SCM_UNLIKELY (yy
== 0))
1026 scm_num_overflow (s_scm_floor_quotient
);
1027 else if (SCM_UNLIKELY (yy
== 1))
1031 SCM q
= scm_i_mkbig ();
1033 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1036 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1037 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1039 scm_remember_upto_here_1 (x
);
1040 return scm_i_normbig (q
);
1043 else if (SCM_BIGP (y
))
1045 SCM q
= scm_i_mkbig ();
1046 mpz_fdiv_q (SCM_I_BIG_MPZ (q
),
1049 scm_remember_upto_here_2 (x
, y
);
1050 return scm_i_normbig (q
);
1052 else if (SCM_REALP (y
))
1053 return scm_i_inexact_floor_quotient
1054 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1055 else if (SCM_FRACTIONP (y
))
1056 return scm_i_exact_rational_floor_quotient (x
, y
);
1058 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1059 s_scm_floor_quotient
);
1061 else if (SCM_REALP (x
))
1063 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1064 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1065 return scm_i_inexact_floor_quotient
1066 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1068 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1069 s_scm_floor_quotient
);
1071 else if (SCM_FRACTIONP (x
))
1074 return scm_i_inexact_floor_quotient
1075 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1076 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1077 return scm_i_exact_rational_floor_quotient (x
, y
);
1079 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG2
,
1080 s_scm_floor_quotient
);
1083 return scm_wta_dispatch_2 (g_scm_floor_quotient
, x
, y
, SCM_ARG1
,
1084 s_scm_floor_quotient
);
1089 scm_i_inexact_floor_quotient (double x
, double y
)
1091 if (SCM_UNLIKELY (y
== 0))
1092 scm_num_overflow (s_scm_floor_quotient
); /* or return a NaN? */
1094 return scm_from_double (floor (x
/ y
));
1098 scm_i_exact_rational_floor_quotient (SCM x
, SCM y
)
1100 return scm_floor_quotient
1101 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1102 scm_product (scm_numerator (y
), scm_denominator (x
)));
1105 static SCM
scm_i_inexact_floor_remainder (double x
, double y
);
1106 static SCM
scm_i_exact_rational_floor_remainder (SCM x
, SCM y
);
1108 SCM_PRIMITIVE_GENERIC (scm_floor_remainder
, "floor-remainder", 2, 0, 0,
1110 "Return the real number @var{r} such that\n"
1111 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1112 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1114 "(floor-remainder 123 10) @result{} 3\n"
1115 "(floor-remainder 123 -10) @result{} -7\n"
1116 "(floor-remainder -123 10) @result{} 7\n"
1117 "(floor-remainder -123 -10) @result{} -3\n"
1118 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1119 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1121 #define FUNC_NAME s_scm_floor_remainder
1123 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1125 scm_t_inum xx
= SCM_I_INUM (x
);
1126 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1128 scm_t_inum yy
= SCM_I_INUM (y
);
1129 if (SCM_UNLIKELY (yy
== 0))
1130 scm_num_overflow (s_scm_floor_remainder
);
1133 scm_t_inum rr
= xx
% yy
;
1134 int needs_adjustment
;
1136 if (SCM_LIKELY (yy
> 0))
1137 needs_adjustment
= (rr
< 0);
1139 needs_adjustment
= (rr
> 0);
1141 if (needs_adjustment
)
1143 return SCM_I_MAKINUM (rr
);
1146 else if (SCM_BIGP (y
))
1148 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1149 scm_remember_upto_here_1 (y
);
1154 SCM r
= scm_i_mkbig ();
1155 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1156 scm_remember_upto_here_1 (y
);
1157 return scm_i_normbig (r
);
1166 SCM r
= scm_i_mkbig ();
1167 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1168 scm_remember_upto_here_1 (y
);
1169 return scm_i_normbig (r
);
1172 else if (SCM_REALP (y
))
1173 return scm_i_inexact_floor_remainder (xx
, SCM_REAL_VALUE (y
));
1174 else if (SCM_FRACTIONP (y
))
1175 return scm_i_exact_rational_floor_remainder (x
, y
);
1177 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1178 s_scm_floor_remainder
);
1180 else if (SCM_BIGP (x
))
1182 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1184 scm_t_inum yy
= SCM_I_INUM (y
);
1185 if (SCM_UNLIKELY (yy
== 0))
1186 scm_num_overflow (s_scm_floor_remainder
);
1191 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1193 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1194 scm_remember_upto_here_1 (x
);
1195 return SCM_I_MAKINUM (rr
);
1198 else if (SCM_BIGP (y
))
1200 SCM r
= scm_i_mkbig ();
1201 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
1204 scm_remember_upto_here_2 (x
, y
);
1205 return scm_i_normbig (r
);
1207 else if (SCM_REALP (y
))
1208 return scm_i_inexact_floor_remainder
1209 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1210 else if (SCM_FRACTIONP (y
))
1211 return scm_i_exact_rational_floor_remainder (x
, y
);
1213 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1214 s_scm_floor_remainder
);
1216 else if (SCM_REALP (x
))
1218 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1219 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1220 return scm_i_inexact_floor_remainder
1221 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1223 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1224 s_scm_floor_remainder
);
1226 else if (SCM_FRACTIONP (x
))
1229 return scm_i_inexact_floor_remainder
1230 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1231 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1232 return scm_i_exact_rational_floor_remainder (x
, y
);
1234 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG2
,
1235 s_scm_floor_remainder
);
1238 return scm_wta_dispatch_2 (g_scm_floor_remainder
, x
, y
, SCM_ARG1
,
1239 s_scm_floor_remainder
);
1244 scm_i_inexact_floor_remainder (double x
, double y
)
1246 /* Although it would be more efficient to use fmod here, we can't
1247 because it would in some cases produce results inconsistent with
1248 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1249 close). In particular, when x is very close to a multiple of y,
1250 then r might be either 0.0 or y, but those two cases must
1251 correspond to different choices of q. If r = 0.0 then q must be
1252 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1253 and remainder chooses the other, it would be bad. */
1254 if (SCM_UNLIKELY (y
== 0))
1255 scm_num_overflow (s_scm_floor_remainder
); /* or return a NaN? */
1257 return scm_from_double (x
- y
* floor (x
/ y
));
1261 scm_i_exact_rational_floor_remainder (SCM x
, SCM y
)
1263 SCM xd
= scm_denominator (x
);
1264 SCM yd
= scm_denominator (y
);
1265 SCM r1
= scm_floor_remainder (scm_product (scm_numerator (x
), yd
),
1266 scm_product (scm_numerator (y
), xd
));
1267 return scm_divide (r1
, scm_product (xd
, yd
));
1271 static void scm_i_inexact_floor_divide (double x
, double y
,
1273 static void scm_i_exact_rational_floor_divide (SCM x
, SCM y
,
1276 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide
, "floor/", 2, 0, 0,
1278 "Return the integer @var{q} and the real number @var{r}\n"
1279 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1280 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1282 "(floor/ 123 10) @result{} 12 and 3\n"
1283 "(floor/ 123 -10) @result{} -13 and -7\n"
1284 "(floor/ -123 10) @result{} -13 and 7\n"
1285 "(floor/ -123 -10) @result{} 12 and -3\n"
1286 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1287 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1289 #define FUNC_NAME s_scm_i_floor_divide
1293 scm_floor_divide(x
, y
, &q
, &r
);
1294 return scm_values (scm_list_2 (q
, r
));
1298 #define s_scm_floor_divide s_scm_i_floor_divide
1299 #define g_scm_floor_divide g_scm_i_floor_divide
1302 scm_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1304 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1306 scm_t_inum xx
= SCM_I_INUM (x
);
1307 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1309 scm_t_inum yy
= SCM_I_INUM (y
);
1310 if (SCM_UNLIKELY (yy
== 0))
1311 scm_num_overflow (s_scm_floor_divide
);
1314 scm_t_inum qq
= xx
/ yy
;
1315 scm_t_inum rr
= xx
% yy
;
1316 int needs_adjustment
;
1318 if (SCM_LIKELY (yy
> 0))
1319 needs_adjustment
= (rr
< 0);
1321 needs_adjustment
= (rr
> 0);
1323 if (needs_adjustment
)
1329 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1330 *qp
= SCM_I_MAKINUM (qq
);
1332 *qp
= scm_i_inum2big (qq
);
1333 *rp
= SCM_I_MAKINUM (rr
);
1337 else if (SCM_BIGP (y
))
1339 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1340 scm_remember_upto_here_1 (y
);
1345 SCM r
= scm_i_mkbig ();
1346 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1347 scm_remember_upto_here_1 (y
);
1348 *qp
= SCM_I_MAKINUM (-1);
1349 *rp
= scm_i_normbig (r
);
1364 SCM r
= scm_i_mkbig ();
1365 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1366 scm_remember_upto_here_1 (y
);
1367 *qp
= SCM_I_MAKINUM (-1);
1368 *rp
= scm_i_normbig (r
);
1372 else if (SCM_REALP (y
))
1373 return scm_i_inexact_floor_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1374 else if (SCM_FRACTIONP (y
))
1375 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1377 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1378 s_scm_floor_divide
, qp
, rp
);
1380 else if (SCM_BIGP (x
))
1382 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1384 scm_t_inum yy
= SCM_I_INUM (y
);
1385 if (SCM_UNLIKELY (yy
== 0))
1386 scm_num_overflow (s_scm_floor_divide
);
1389 SCM q
= scm_i_mkbig ();
1390 SCM r
= scm_i_mkbig ();
1392 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1393 SCM_I_BIG_MPZ (x
), yy
);
1396 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1397 SCM_I_BIG_MPZ (x
), -yy
);
1398 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1400 scm_remember_upto_here_1 (x
);
1401 *qp
= scm_i_normbig (q
);
1402 *rp
= scm_i_normbig (r
);
1406 else if (SCM_BIGP (y
))
1408 SCM q
= scm_i_mkbig ();
1409 SCM r
= scm_i_mkbig ();
1410 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1411 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1412 scm_remember_upto_here_2 (x
, y
);
1413 *qp
= scm_i_normbig (q
);
1414 *rp
= scm_i_normbig (r
);
1417 else if (SCM_REALP (y
))
1418 return scm_i_inexact_floor_divide
1419 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1420 else if (SCM_FRACTIONP (y
))
1421 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1423 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1424 s_scm_floor_divide
, qp
, rp
);
1426 else if (SCM_REALP (x
))
1428 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1429 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1430 return scm_i_inexact_floor_divide
1431 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1433 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1434 s_scm_floor_divide
, qp
, rp
);
1436 else if (SCM_FRACTIONP (x
))
1439 return scm_i_inexact_floor_divide
1440 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1441 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1442 return scm_i_exact_rational_floor_divide (x
, y
, qp
, rp
);
1444 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG2
,
1445 s_scm_floor_divide
, qp
, rp
);
1448 return two_valued_wta_dispatch_2 (g_scm_floor_divide
, x
, y
, SCM_ARG1
,
1449 s_scm_floor_divide
, qp
, rp
);
1453 scm_i_inexact_floor_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
1455 if (SCM_UNLIKELY (y
== 0))
1456 scm_num_overflow (s_scm_floor_divide
); /* or return a NaN? */
1459 double q
= floor (x
/ y
);
1460 double r
= x
- q
* y
;
1461 *qp
= scm_from_double (q
);
1462 *rp
= scm_from_double (r
);
1467 scm_i_exact_rational_floor_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1470 SCM xd
= scm_denominator (x
);
1471 SCM yd
= scm_denominator (y
);
1473 scm_floor_divide (scm_product (scm_numerator (x
), yd
),
1474 scm_product (scm_numerator (y
), xd
),
1476 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
1479 static SCM
scm_i_inexact_ceiling_quotient (double x
, double y
);
1480 static SCM
scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
);
1482 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient
, "ceiling-quotient", 2, 0, 0,
1484 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1486 "(ceiling-quotient 123 10) @result{} 13\n"
1487 "(ceiling-quotient 123 -10) @result{} -12\n"
1488 "(ceiling-quotient -123 10) @result{} -12\n"
1489 "(ceiling-quotient -123 -10) @result{} 13\n"
1490 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1491 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1493 #define FUNC_NAME s_scm_ceiling_quotient
1495 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1497 scm_t_inum xx
= SCM_I_INUM (x
);
1498 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1500 scm_t_inum yy
= SCM_I_INUM (y
);
1501 if (SCM_UNLIKELY (yy
== 0))
1502 scm_num_overflow (s_scm_ceiling_quotient
);
1505 scm_t_inum xx1
= xx
;
1507 if (SCM_LIKELY (yy
> 0))
1509 if (SCM_LIKELY (xx
>= 0))
1515 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1516 return SCM_I_MAKINUM (qq
);
1518 return scm_i_inum2big (qq
);
1521 else if (SCM_BIGP (y
))
1523 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1524 scm_remember_upto_here_1 (y
);
1525 if (SCM_LIKELY (sign
> 0))
1527 if (SCM_LIKELY (xx
> 0))
1529 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1530 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1531 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1533 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1534 scm_remember_upto_here_1 (y
);
1535 return SCM_I_MAKINUM (-1);
1545 else if (SCM_REALP (y
))
1546 return scm_i_inexact_ceiling_quotient (xx
, SCM_REAL_VALUE (y
));
1547 else if (SCM_FRACTIONP (y
))
1548 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1550 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1551 s_scm_ceiling_quotient
);
1553 else if (SCM_BIGP (x
))
1555 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1557 scm_t_inum yy
= SCM_I_INUM (y
);
1558 if (SCM_UNLIKELY (yy
== 0))
1559 scm_num_overflow (s_scm_ceiling_quotient
);
1560 else if (SCM_UNLIKELY (yy
== 1))
1564 SCM q
= scm_i_mkbig ();
1566 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
1569 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
1570 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1572 scm_remember_upto_here_1 (x
);
1573 return scm_i_normbig (q
);
1576 else if (SCM_BIGP (y
))
1578 SCM q
= scm_i_mkbig ();
1579 mpz_cdiv_q (SCM_I_BIG_MPZ (q
),
1582 scm_remember_upto_here_2 (x
, y
);
1583 return scm_i_normbig (q
);
1585 else if (SCM_REALP (y
))
1586 return scm_i_inexact_ceiling_quotient
1587 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1588 else if (SCM_FRACTIONP (y
))
1589 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1591 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1592 s_scm_ceiling_quotient
);
1594 else if (SCM_REALP (x
))
1596 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1597 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1598 return scm_i_inexact_ceiling_quotient
1599 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1601 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1602 s_scm_ceiling_quotient
);
1604 else if (SCM_FRACTIONP (x
))
1607 return scm_i_inexact_ceiling_quotient
1608 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1609 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1610 return scm_i_exact_rational_ceiling_quotient (x
, y
);
1612 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG2
,
1613 s_scm_ceiling_quotient
);
1616 return scm_wta_dispatch_2 (g_scm_ceiling_quotient
, x
, y
, SCM_ARG1
,
1617 s_scm_ceiling_quotient
);
1622 scm_i_inexact_ceiling_quotient (double x
, double y
)
1624 if (SCM_UNLIKELY (y
== 0))
1625 scm_num_overflow (s_scm_ceiling_quotient
); /* or return a NaN? */
1627 return scm_from_double (ceil (x
/ y
));
1631 scm_i_exact_rational_ceiling_quotient (SCM x
, SCM y
)
1633 return scm_ceiling_quotient
1634 (scm_product (scm_numerator (x
), scm_denominator (y
)),
1635 scm_product (scm_numerator (y
), scm_denominator (x
)));
1638 static SCM
scm_i_inexact_ceiling_remainder (double x
, double y
);
1639 static SCM
scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
);
1641 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder
, "ceiling-remainder", 2, 0, 0,
1643 "Return the real number @var{r} such that\n"
1644 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1645 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1647 "(ceiling-remainder 123 10) @result{} -7\n"
1648 "(ceiling-remainder 123 -10) @result{} 3\n"
1649 "(ceiling-remainder -123 10) @result{} -3\n"
1650 "(ceiling-remainder -123 -10) @result{} 7\n"
1651 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1652 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1654 #define FUNC_NAME s_scm_ceiling_remainder
1656 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1658 scm_t_inum xx
= SCM_I_INUM (x
);
1659 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1661 scm_t_inum yy
= SCM_I_INUM (y
);
1662 if (SCM_UNLIKELY (yy
== 0))
1663 scm_num_overflow (s_scm_ceiling_remainder
);
1666 scm_t_inum rr
= xx
% yy
;
1667 int needs_adjustment
;
1669 if (SCM_LIKELY (yy
> 0))
1670 needs_adjustment
= (rr
> 0);
1672 needs_adjustment
= (rr
< 0);
1674 if (needs_adjustment
)
1676 return SCM_I_MAKINUM (rr
);
1679 else if (SCM_BIGP (y
))
1681 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1682 scm_remember_upto_here_1 (y
);
1683 if (SCM_LIKELY (sign
> 0))
1685 if (SCM_LIKELY (xx
> 0))
1687 SCM r
= scm_i_mkbig ();
1688 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1689 scm_remember_upto_here_1 (y
);
1690 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1691 return scm_i_normbig (r
);
1693 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1694 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1695 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1697 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1698 scm_remember_upto_here_1 (y
);
1708 SCM r
= scm_i_mkbig ();
1709 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1710 scm_remember_upto_here_1 (y
);
1711 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1712 return scm_i_normbig (r
);
1715 else if (SCM_REALP (y
))
1716 return scm_i_inexact_ceiling_remainder (xx
, SCM_REAL_VALUE (y
));
1717 else if (SCM_FRACTIONP (y
))
1718 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1720 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1721 s_scm_ceiling_remainder
);
1723 else if (SCM_BIGP (x
))
1725 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1727 scm_t_inum yy
= SCM_I_INUM (y
);
1728 if (SCM_UNLIKELY (yy
== 0))
1729 scm_num_overflow (s_scm_ceiling_remainder
);
1734 rr
= -mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
1736 rr
= mpz_fdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
1737 scm_remember_upto_here_1 (x
);
1738 return SCM_I_MAKINUM (rr
);
1741 else if (SCM_BIGP (y
))
1743 SCM r
= scm_i_mkbig ();
1744 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
1747 scm_remember_upto_here_2 (x
, y
);
1748 return scm_i_normbig (r
);
1750 else if (SCM_REALP (y
))
1751 return scm_i_inexact_ceiling_remainder
1752 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
1753 else if (SCM_FRACTIONP (y
))
1754 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1756 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1757 s_scm_ceiling_remainder
);
1759 else if (SCM_REALP (x
))
1761 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1762 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1763 return scm_i_inexact_ceiling_remainder
1764 (SCM_REAL_VALUE (x
), scm_to_double (y
));
1766 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1767 s_scm_ceiling_remainder
);
1769 else if (SCM_FRACTIONP (x
))
1772 return scm_i_inexact_ceiling_remainder
1773 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
1774 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1775 return scm_i_exact_rational_ceiling_remainder (x
, y
);
1777 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG2
,
1778 s_scm_ceiling_remainder
);
1781 return scm_wta_dispatch_2 (g_scm_ceiling_remainder
, x
, y
, SCM_ARG1
,
1782 s_scm_ceiling_remainder
);
1787 scm_i_inexact_ceiling_remainder (double x
, double y
)
1789 /* Although it would be more efficient to use fmod here, we can't
1790 because it would in some cases produce results inconsistent with
1791 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
1792 close). In particular, when x is very close to a multiple of y,
1793 then r might be either 0.0 or -y, but those two cases must
1794 correspond to different choices of q. If r = 0.0 then q must be
1795 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
1796 and remainder chooses the other, it would be bad. */
1797 if (SCM_UNLIKELY (y
== 0))
1798 scm_num_overflow (s_scm_ceiling_remainder
); /* or return a NaN? */
1800 return scm_from_double (x
- y
* ceil (x
/ y
));
1804 scm_i_exact_rational_ceiling_remainder (SCM x
, SCM y
)
1806 SCM xd
= scm_denominator (x
);
1807 SCM yd
= scm_denominator (y
);
1808 SCM r1
= scm_ceiling_remainder (scm_product (scm_numerator (x
), yd
),
1809 scm_product (scm_numerator (y
), xd
));
1810 return scm_divide (r1
, scm_product (xd
, yd
));
1813 static void scm_i_inexact_ceiling_divide (double x
, double y
,
1815 static void scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
,
1818 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide
, "ceiling/", 2, 0, 0,
1820 "Return the integer @var{q} and the real number @var{r}\n"
1821 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1822 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1824 "(ceiling/ 123 10) @result{} 13 and -7\n"
1825 "(ceiling/ 123 -10) @result{} -12 and 3\n"
1826 "(ceiling/ -123 10) @result{} -12 and -3\n"
1827 "(ceiling/ -123 -10) @result{} 13 and 7\n"
1828 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1829 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
1831 #define FUNC_NAME s_scm_i_ceiling_divide
1835 scm_ceiling_divide(x
, y
, &q
, &r
);
1836 return scm_values (scm_list_2 (q
, r
));
1840 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
1841 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
1844 scm_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
1846 if (SCM_LIKELY (SCM_I_INUMP (x
)))
1848 scm_t_inum xx
= SCM_I_INUM (x
);
1849 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1851 scm_t_inum yy
= SCM_I_INUM (y
);
1852 if (SCM_UNLIKELY (yy
== 0))
1853 scm_num_overflow (s_scm_ceiling_divide
);
1856 scm_t_inum qq
= xx
/ yy
;
1857 scm_t_inum rr
= xx
% yy
;
1858 int needs_adjustment
;
1860 if (SCM_LIKELY (yy
> 0))
1861 needs_adjustment
= (rr
> 0);
1863 needs_adjustment
= (rr
< 0);
1865 if (needs_adjustment
)
1870 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
1871 *qp
= SCM_I_MAKINUM (qq
);
1873 *qp
= scm_i_inum2big (qq
);
1874 *rp
= SCM_I_MAKINUM (rr
);
1878 else if (SCM_BIGP (y
))
1880 int sign
= mpz_sgn (SCM_I_BIG_MPZ (y
));
1881 scm_remember_upto_here_1 (y
);
1882 if (SCM_LIKELY (sign
> 0))
1884 if (SCM_LIKELY (xx
> 0))
1886 SCM r
= scm_i_mkbig ();
1887 mpz_sub_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), xx
);
1888 scm_remember_upto_here_1 (y
);
1889 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1891 *rp
= scm_i_normbig (r
);
1893 else if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
1894 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
1895 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
1897 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1898 scm_remember_upto_here_1 (y
);
1899 *qp
= SCM_I_MAKINUM (-1);
1915 SCM r
= scm_i_mkbig ();
1916 mpz_add_ui (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
), -xx
);
1917 scm_remember_upto_here_1 (y
);
1918 mpz_neg (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
));
1920 *rp
= scm_i_normbig (r
);
1924 else if (SCM_REALP (y
))
1925 return scm_i_inexact_ceiling_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
1926 else if (SCM_FRACTIONP (y
))
1927 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1929 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1930 s_scm_ceiling_divide
, qp
, rp
);
1932 else if (SCM_BIGP (x
))
1934 if (SCM_LIKELY (SCM_I_INUMP (y
)))
1936 scm_t_inum yy
= SCM_I_INUM (y
);
1937 if (SCM_UNLIKELY (yy
== 0))
1938 scm_num_overflow (s_scm_ceiling_divide
);
1941 SCM q
= scm_i_mkbig ();
1942 SCM r
= scm_i_mkbig ();
1944 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1945 SCM_I_BIG_MPZ (x
), yy
);
1948 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1949 SCM_I_BIG_MPZ (x
), -yy
);
1950 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
1952 scm_remember_upto_here_1 (x
);
1953 *qp
= scm_i_normbig (q
);
1954 *rp
= scm_i_normbig (r
);
1958 else if (SCM_BIGP (y
))
1960 SCM q
= scm_i_mkbig ();
1961 SCM r
= scm_i_mkbig ();
1962 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
1963 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
1964 scm_remember_upto_here_2 (x
, y
);
1965 *qp
= scm_i_normbig (q
);
1966 *rp
= scm_i_normbig (r
);
1969 else if (SCM_REALP (y
))
1970 return scm_i_inexact_ceiling_divide
1971 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1972 else if (SCM_FRACTIONP (y
))
1973 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1975 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1976 s_scm_ceiling_divide
, qp
, rp
);
1978 else if (SCM_REALP (x
))
1980 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
1981 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1982 return scm_i_inexact_ceiling_divide
1983 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
1985 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1986 s_scm_ceiling_divide
, qp
, rp
);
1988 else if (SCM_FRACTIONP (x
))
1991 return scm_i_inexact_ceiling_divide
1992 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
1993 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
1994 return scm_i_exact_rational_ceiling_divide (x
, y
, qp
, rp
);
1996 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG2
,
1997 s_scm_ceiling_divide
, qp
, rp
);
2000 return two_valued_wta_dispatch_2 (g_scm_ceiling_divide
, x
, y
, SCM_ARG1
,
2001 s_scm_ceiling_divide
, qp
, rp
);
2005 scm_i_inexact_ceiling_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2007 if (SCM_UNLIKELY (y
== 0))
2008 scm_num_overflow (s_scm_ceiling_divide
); /* or return a NaN? */
2011 double q
= ceil (x
/ y
);
2012 double r
= x
- q
* y
;
2013 *qp
= scm_from_double (q
);
2014 *rp
= scm_from_double (r
);
2019 scm_i_exact_rational_ceiling_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2022 SCM xd
= scm_denominator (x
);
2023 SCM yd
= scm_denominator (y
);
2025 scm_ceiling_divide (scm_product (scm_numerator (x
), yd
),
2026 scm_product (scm_numerator (y
), xd
),
2028 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2031 static SCM
scm_i_inexact_truncate_quotient (double x
, double y
);
2032 static SCM
scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
);
2034 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient
, "truncate-quotient", 2, 0, 0,
2036 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2038 "(truncate-quotient 123 10) @result{} 12\n"
2039 "(truncate-quotient 123 -10) @result{} -12\n"
2040 "(truncate-quotient -123 10) @result{} -12\n"
2041 "(truncate-quotient -123 -10) @result{} 12\n"
2042 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2043 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2045 #define FUNC_NAME s_scm_truncate_quotient
2047 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2049 scm_t_inum xx
= SCM_I_INUM (x
);
2050 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2052 scm_t_inum yy
= SCM_I_INUM (y
);
2053 if (SCM_UNLIKELY (yy
== 0))
2054 scm_num_overflow (s_scm_truncate_quotient
);
2057 scm_t_inum qq
= xx
/ yy
;
2058 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2059 return SCM_I_MAKINUM (qq
);
2061 return scm_i_inum2big (qq
);
2064 else if (SCM_BIGP (y
))
2066 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2067 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2068 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2070 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2071 scm_remember_upto_here_1 (y
);
2072 return SCM_I_MAKINUM (-1);
2077 else if (SCM_REALP (y
))
2078 return scm_i_inexact_truncate_quotient (xx
, SCM_REAL_VALUE (y
));
2079 else if (SCM_FRACTIONP (y
))
2080 return scm_i_exact_rational_truncate_quotient (x
, y
);
2082 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2083 s_scm_truncate_quotient
);
2085 else if (SCM_BIGP (x
))
2087 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2089 scm_t_inum yy
= SCM_I_INUM (y
);
2090 if (SCM_UNLIKELY (yy
== 0))
2091 scm_num_overflow (s_scm_truncate_quotient
);
2092 else if (SCM_UNLIKELY (yy
== 1))
2096 SCM q
= scm_i_mkbig ();
2098 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), yy
);
2101 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (x
), -yy
);
2102 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2104 scm_remember_upto_here_1 (x
);
2105 return scm_i_normbig (q
);
2108 else if (SCM_BIGP (y
))
2110 SCM q
= scm_i_mkbig ();
2111 mpz_tdiv_q (SCM_I_BIG_MPZ (q
),
2114 scm_remember_upto_here_2 (x
, y
);
2115 return scm_i_normbig (q
);
2117 else if (SCM_REALP (y
))
2118 return scm_i_inexact_truncate_quotient
2119 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2120 else if (SCM_FRACTIONP (y
))
2121 return scm_i_exact_rational_truncate_quotient (x
, y
);
2123 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2124 s_scm_truncate_quotient
);
2126 else if (SCM_REALP (x
))
2128 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2129 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2130 return scm_i_inexact_truncate_quotient
2131 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2133 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2134 s_scm_truncate_quotient
);
2136 else if (SCM_FRACTIONP (x
))
2139 return scm_i_inexact_truncate_quotient
2140 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2141 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2142 return scm_i_exact_rational_truncate_quotient (x
, y
);
2144 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG2
,
2145 s_scm_truncate_quotient
);
2148 return scm_wta_dispatch_2 (g_scm_truncate_quotient
, x
, y
, SCM_ARG1
,
2149 s_scm_truncate_quotient
);
2154 scm_i_inexact_truncate_quotient (double x
, double y
)
2156 if (SCM_UNLIKELY (y
== 0))
2157 scm_num_overflow (s_scm_truncate_quotient
); /* or return a NaN? */
2159 return scm_from_double (trunc (x
/ y
));
2163 scm_i_exact_rational_truncate_quotient (SCM x
, SCM y
)
2165 return scm_truncate_quotient
2166 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2167 scm_product (scm_numerator (y
), scm_denominator (x
)));
2170 static SCM
scm_i_inexact_truncate_remainder (double x
, double y
);
2171 static SCM
scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
);
2173 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder
, "truncate-remainder", 2, 0, 0,
2175 "Return the real number @var{r} such that\n"
2176 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2177 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2179 "(truncate-remainder 123 10) @result{} 3\n"
2180 "(truncate-remainder 123 -10) @result{} 3\n"
2181 "(truncate-remainder -123 10) @result{} -3\n"
2182 "(truncate-remainder -123 -10) @result{} -3\n"
2183 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2184 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2186 #define FUNC_NAME s_scm_truncate_remainder
2188 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2190 scm_t_inum xx
= SCM_I_INUM (x
);
2191 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2193 scm_t_inum yy
= SCM_I_INUM (y
);
2194 if (SCM_UNLIKELY (yy
== 0))
2195 scm_num_overflow (s_scm_truncate_remainder
);
2197 return SCM_I_MAKINUM (xx
% yy
);
2199 else if (SCM_BIGP (y
))
2201 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2202 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2203 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2205 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2206 scm_remember_upto_here_1 (y
);
2212 else if (SCM_REALP (y
))
2213 return scm_i_inexact_truncate_remainder (xx
, SCM_REAL_VALUE (y
));
2214 else if (SCM_FRACTIONP (y
))
2215 return scm_i_exact_rational_truncate_remainder (x
, y
);
2217 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2218 s_scm_truncate_remainder
);
2220 else if (SCM_BIGP (x
))
2222 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2224 scm_t_inum yy
= SCM_I_INUM (y
);
2225 if (SCM_UNLIKELY (yy
== 0))
2226 scm_num_overflow (s_scm_truncate_remainder
);
2229 scm_t_inum rr
= (mpz_tdiv_ui (SCM_I_BIG_MPZ (x
),
2230 (yy
> 0) ? yy
: -yy
)
2231 * mpz_sgn (SCM_I_BIG_MPZ (x
)));
2232 scm_remember_upto_here_1 (x
);
2233 return SCM_I_MAKINUM (rr
);
2236 else if (SCM_BIGP (y
))
2238 SCM r
= scm_i_mkbig ();
2239 mpz_tdiv_r (SCM_I_BIG_MPZ (r
),
2242 scm_remember_upto_here_2 (x
, y
);
2243 return scm_i_normbig (r
);
2245 else if (SCM_REALP (y
))
2246 return scm_i_inexact_truncate_remainder
2247 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2248 else if (SCM_FRACTIONP (y
))
2249 return scm_i_exact_rational_truncate_remainder (x
, y
);
2251 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2252 s_scm_truncate_remainder
);
2254 else if (SCM_REALP (x
))
2256 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2257 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2258 return scm_i_inexact_truncate_remainder
2259 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2261 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2262 s_scm_truncate_remainder
);
2264 else if (SCM_FRACTIONP (x
))
2267 return scm_i_inexact_truncate_remainder
2268 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2269 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2270 return scm_i_exact_rational_truncate_remainder (x
, y
);
2272 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG2
,
2273 s_scm_truncate_remainder
);
2276 return scm_wta_dispatch_2 (g_scm_truncate_remainder
, x
, y
, SCM_ARG1
,
2277 s_scm_truncate_remainder
);
2282 scm_i_inexact_truncate_remainder (double x
, double y
)
2284 /* Although it would be more efficient to use fmod here, we can't
2285 because it would in some cases produce results inconsistent with
2286 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2287 close). In particular, when x is very close to a multiple of y,
2288 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2289 correspond to different choices of q. If quotient chooses one and
2290 remainder chooses the other, it would be bad. */
2291 if (SCM_UNLIKELY (y
== 0))
2292 scm_num_overflow (s_scm_truncate_remainder
); /* or return a NaN? */
2294 return scm_from_double (x
- y
* trunc (x
/ y
));
2298 scm_i_exact_rational_truncate_remainder (SCM x
, SCM y
)
2300 SCM xd
= scm_denominator (x
);
2301 SCM yd
= scm_denominator (y
);
2302 SCM r1
= scm_truncate_remainder (scm_product (scm_numerator (x
), yd
),
2303 scm_product (scm_numerator (y
), xd
));
2304 return scm_divide (r1
, scm_product (xd
, yd
));
2308 static void scm_i_inexact_truncate_divide (double x
, double y
,
2310 static void scm_i_exact_rational_truncate_divide (SCM x
, SCM y
,
2313 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide
, "truncate/", 2, 0, 0,
2315 "Return the integer @var{q} and the real number @var{r}\n"
2316 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2317 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2319 "(truncate/ 123 10) @result{} 12 and 3\n"
2320 "(truncate/ 123 -10) @result{} -12 and 3\n"
2321 "(truncate/ -123 10) @result{} -12 and -3\n"
2322 "(truncate/ -123 -10) @result{} 12 and -3\n"
2323 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2324 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2326 #define FUNC_NAME s_scm_i_truncate_divide
2330 scm_truncate_divide(x
, y
, &q
, &r
);
2331 return scm_values (scm_list_2 (q
, r
));
2335 #define s_scm_truncate_divide s_scm_i_truncate_divide
2336 #define g_scm_truncate_divide g_scm_i_truncate_divide
2339 scm_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2341 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2343 scm_t_inum xx
= SCM_I_INUM (x
);
2344 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2346 scm_t_inum yy
= SCM_I_INUM (y
);
2347 if (SCM_UNLIKELY (yy
== 0))
2348 scm_num_overflow (s_scm_truncate_divide
);
2351 scm_t_inum qq
= xx
/ yy
;
2352 scm_t_inum rr
= xx
% yy
;
2353 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2354 *qp
= SCM_I_MAKINUM (qq
);
2356 *qp
= scm_i_inum2big (qq
);
2357 *rp
= SCM_I_MAKINUM (rr
);
2361 else if (SCM_BIGP (y
))
2363 if (SCM_UNLIKELY (xx
== SCM_MOST_NEGATIVE_FIXNUM
)
2364 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
2365 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
2367 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2368 scm_remember_upto_here_1 (y
);
2369 *qp
= SCM_I_MAKINUM (-1);
2379 else if (SCM_REALP (y
))
2380 return scm_i_inexact_truncate_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
2381 else if (SCM_FRACTIONP (y
))
2382 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2384 return two_valued_wta_dispatch_2
2385 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2386 s_scm_truncate_divide
, qp
, rp
);
2388 else if (SCM_BIGP (x
))
2390 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2392 scm_t_inum yy
= SCM_I_INUM (y
);
2393 if (SCM_UNLIKELY (yy
== 0))
2394 scm_num_overflow (s_scm_truncate_divide
);
2397 SCM q
= scm_i_mkbig ();
2400 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2401 SCM_I_BIG_MPZ (x
), yy
);
2404 rr
= mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q
),
2405 SCM_I_BIG_MPZ (x
), -yy
);
2406 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2408 rr
*= mpz_sgn (SCM_I_BIG_MPZ (x
));
2409 scm_remember_upto_here_1 (x
);
2410 *qp
= scm_i_normbig (q
);
2411 *rp
= SCM_I_MAKINUM (rr
);
2415 else if (SCM_BIGP (y
))
2417 SCM q
= scm_i_mkbig ();
2418 SCM r
= scm_i_mkbig ();
2419 mpz_tdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2420 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2421 scm_remember_upto_here_2 (x
, y
);
2422 *qp
= scm_i_normbig (q
);
2423 *rp
= scm_i_normbig (r
);
2425 else if (SCM_REALP (y
))
2426 return scm_i_inexact_truncate_divide
2427 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2428 else if (SCM_FRACTIONP (y
))
2429 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2431 return two_valued_wta_dispatch_2
2432 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2433 s_scm_truncate_divide
, qp
, rp
);
2435 else if (SCM_REALP (x
))
2437 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2438 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2439 return scm_i_inexact_truncate_divide
2440 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
2442 return two_valued_wta_dispatch_2
2443 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2444 s_scm_truncate_divide
, qp
, rp
);
2446 else if (SCM_FRACTIONP (x
))
2449 return scm_i_inexact_truncate_divide
2450 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
2451 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2452 return scm_i_exact_rational_truncate_divide (x
, y
, qp
, rp
);
2454 return two_valued_wta_dispatch_2
2455 (g_scm_truncate_divide
, x
, y
, SCM_ARG2
,
2456 s_scm_truncate_divide
, qp
, rp
);
2459 return two_valued_wta_dispatch_2 (g_scm_truncate_divide
, x
, y
, SCM_ARG1
,
2460 s_scm_truncate_divide
, qp
, rp
);
2464 scm_i_inexact_truncate_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
2466 if (SCM_UNLIKELY (y
== 0))
2467 scm_num_overflow (s_scm_truncate_divide
); /* or return a NaN? */
2470 double q
= trunc (x
/ y
);
2471 double r
= x
- q
* y
;
2472 *qp
= scm_from_double (q
);
2473 *rp
= scm_from_double (r
);
2478 scm_i_exact_rational_truncate_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2481 SCM xd
= scm_denominator (x
);
2482 SCM yd
= scm_denominator (y
);
2484 scm_truncate_divide (scm_product (scm_numerator (x
), yd
),
2485 scm_product (scm_numerator (y
), xd
),
2487 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
2490 static SCM
scm_i_inexact_centered_quotient (double x
, double y
);
2491 static SCM
scm_i_bigint_centered_quotient (SCM x
, SCM y
);
2492 static SCM
scm_i_exact_rational_centered_quotient (SCM x
, SCM y
);
2494 SCM_PRIMITIVE_GENERIC (scm_centered_quotient
, "centered-quotient", 2, 0, 0,
2496 "Return the integer @var{q} such that\n"
2497 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2498 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2500 "(centered-quotient 123 10) @result{} 12\n"
2501 "(centered-quotient 123 -10) @result{} -12\n"
2502 "(centered-quotient -123 10) @result{} -12\n"
2503 "(centered-quotient -123 -10) @result{} 12\n"
2504 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2505 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2507 #define FUNC_NAME s_scm_centered_quotient
2509 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2511 scm_t_inum xx
= SCM_I_INUM (x
);
2512 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2514 scm_t_inum yy
= SCM_I_INUM (y
);
2515 if (SCM_UNLIKELY (yy
== 0))
2516 scm_num_overflow (s_scm_centered_quotient
);
2519 scm_t_inum qq
= xx
/ yy
;
2520 scm_t_inum rr
= xx
% yy
;
2521 if (SCM_LIKELY (xx
> 0))
2523 if (SCM_LIKELY (yy
> 0))
2525 if (rr
>= (yy
+ 1) / 2)
2530 if (rr
>= (1 - yy
) / 2)
2536 if (SCM_LIKELY (yy
> 0))
2547 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2548 return SCM_I_MAKINUM (qq
);
2550 return scm_i_inum2big (qq
);
2553 else if (SCM_BIGP (y
))
2555 /* Pass a denormalized bignum version of x (even though it
2556 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2557 return scm_i_bigint_centered_quotient (scm_i_long2big (xx
), y
);
2559 else if (SCM_REALP (y
))
2560 return scm_i_inexact_centered_quotient (xx
, SCM_REAL_VALUE (y
));
2561 else if (SCM_FRACTIONP (y
))
2562 return scm_i_exact_rational_centered_quotient (x
, y
);
2564 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2565 s_scm_centered_quotient
);
2567 else if (SCM_BIGP (x
))
2569 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2571 scm_t_inum yy
= SCM_I_INUM (y
);
2572 if (SCM_UNLIKELY (yy
== 0))
2573 scm_num_overflow (s_scm_centered_quotient
);
2574 else if (SCM_UNLIKELY (yy
== 1))
2578 SCM q
= scm_i_mkbig ();
2580 /* Arrange for rr to initially be non-positive,
2581 because that simplifies the test to see
2582 if it is within the needed bounds. */
2585 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2586 SCM_I_BIG_MPZ (x
), yy
);
2587 scm_remember_upto_here_1 (x
);
2589 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2590 SCM_I_BIG_MPZ (q
), 1);
2594 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
2595 SCM_I_BIG_MPZ (x
), -yy
);
2596 scm_remember_upto_here_1 (x
);
2597 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
2599 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2600 SCM_I_BIG_MPZ (q
), 1);
2602 return scm_i_normbig (q
);
2605 else if (SCM_BIGP (y
))
2606 return scm_i_bigint_centered_quotient (x
, y
);
2607 else if (SCM_REALP (y
))
2608 return scm_i_inexact_centered_quotient
2609 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2610 else if (SCM_FRACTIONP (y
))
2611 return scm_i_exact_rational_centered_quotient (x
, y
);
2613 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2614 s_scm_centered_quotient
);
2616 else if (SCM_REALP (x
))
2618 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2619 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2620 return scm_i_inexact_centered_quotient
2621 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2623 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2624 s_scm_centered_quotient
);
2626 else if (SCM_FRACTIONP (x
))
2629 return scm_i_inexact_centered_quotient
2630 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2631 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2632 return scm_i_exact_rational_centered_quotient (x
, y
);
2634 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG2
,
2635 s_scm_centered_quotient
);
2638 return scm_wta_dispatch_2 (g_scm_centered_quotient
, x
, y
, SCM_ARG1
,
2639 s_scm_centered_quotient
);
2644 scm_i_inexact_centered_quotient (double x
, double y
)
2646 if (SCM_LIKELY (y
> 0))
2647 return scm_from_double (floor (x
/y
+ 0.5));
2648 else if (SCM_LIKELY (y
< 0))
2649 return scm_from_double (ceil (x
/y
- 0.5));
2651 scm_num_overflow (s_scm_centered_quotient
); /* or return a NaN? */
2656 /* Assumes that both x and y are bigints, though
2657 x might be able to fit into a fixnum. */
2659 scm_i_bigint_centered_quotient (SCM x
, SCM y
)
2663 /* Note that x might be small enough to fit into a
2664 fixnum, so we must not let it escape into the wild */
2668 /* min_r will eventually become -abs(y)/2 */
2669 min_r
= scm_i_mkbig ();
2670 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2671 SCM_I_BIG_MPZ (y
), 1);
2673 /* Arrange for rr to initially be non-positive,
2674 because that simplifies the test to see
2675 if it is within the needed bounds. */
2676 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2678 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2679 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2680 scm_remember_upto_here_2 (x
, y
);
2681 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2682 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2683 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
2684 SCM_I_BIG_MPZ (q
), 1);
2688 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
2689 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2690 scm_remember_upto_here_2 (x
, y
);
2691 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2692 mpz_add_ui (SCM_I_BIG_MPZ (q
),
2693 SCM_I_BIG_MPZ (q
), 1);
2695 scm_remember_upto_here_2 (r
, min_r
);
2696 return scm_i_normbig (q
);
2700 scm_i_exact_rational_centered_quotient (SCM x
, SCM y
)
2702 return scm_centered_quotient
2703 (scm_product (scm_numerator (x
), scm_denominator (y
)),
2704 scm_product (scm_numerator (y
), scm_denominator (x
)));
2707 static SCM
scm_i_inexact_centered_remainder (double x
, double y
);
2708 static SCM
scm_i_bigint_centered_remainder (SCM x
, SCM y
);
2709 static SCM
scm_i_exact_rational_centered_remainder (SCM x
, SCM y
);
2711 SCM_PRIMITIVE_GENERIC (scm_centered_remainder
, "centered-remainder", 2, 0, 0,
2713 "Return the real number @var{r} such that\n"
2714 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2715 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2716 "for some integer @var{q}.\n"
2718 "(centered-remainder 123 10) @result{} 3\n"
2719 "(centered-remainder 123 -10) @result{} 3\n"
2720 "(centered-remainder -123 10) @result{} -3\n"
2721 "(centered-remainder -123 -10) @result{} -3\n"
2722 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2723 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2725 #define FUNC_NAME s_scm_centered_remainder
2727 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2729 scm_t_inum xx
= SCM_I_INUM (x
);
2730 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2732 scm_t_inum yy
= SCM_I_INUM (y
);
2733 if (SCM_UNLIKELY (yy
== 0))
2734 scm_num_overflow (s_scm_centered_remainder
);
2737 scm_t_inum rr
= xx
% yy
;
2738 if (SCM_LIKELY (xx
> 0))
2740 if (SCM_LIKELY (yy
> 0))
2742 if (rr
>= (yy
+ 1) / 2)
2747 if (rr
>= (1 - yy
) / 2)
2753 if (SCM_LIKELY (yy
> 0))
2764 return SCM_I_MAKINUM (rr
);
2767 else if (SCM_BIGP (y
))
2769 /* Pass a denormalized bignum version of x (even though it
2770 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2771 return scm_i_bigint_centered_remainder (scm_i_long2big (xx
), y
);
2773 else if (SCM_REALP (y
))
2774 return scm_i_inexact_centered_remainder (xx
, SCM_REAL_VALUE (y
));
2775 else if (SCM_FRACTIONP (y
))
2776 return scm_i_exact_rational_centered_remainder (x
, y
);
2778 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2779 s_scm_centered_remainder
);
2781 else if (SCM_BIGP (x
))
2783 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2785 scm_t_inum yy
= SCM_I_INUM (y
);
2786 if (SCM_UNLIKELY (yy
== 0))
2787 scm_num_overflow (s_scm_centered_remainder
);
2791 /* Arrange for rr to initially be non-positive,
2792 because that simplifies the test to see
2793 if it is within the needed bounds. */
2796 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), yy
);
2797 scm_remember_upto_here_1 (x
);
2803 rr
= - mpz_cdiv_ui (SCM_I_BIG_MPZ (x
), -yy
);
2804 scm_remember_upto_here_1 (x
);
2808 return SCM_I_MAKINUM (rr
);
2811 else if (SCM_BIGP (y
))
2812 return scm_i_bigint_centered_remainder (x
, y
);
2813 else if (SCM_REALP (y
))
2814 return scm_i_inexact_centered_remainder
2815 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
2816 else if (SCM_FRACTIONP (y
))
2817 return scm_i_exact_rational_centered_remainder (x
, y
);
2819 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2820 s_scm_centered_remainder
);
2822 else if (SCM_REALP (x
))
2824 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
2825 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2826 return scm_i_inexact_centered_remainder
2827 (SCM_REAL_VALUE (x
), scm_to_double (y
));
2829 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2830 s_scm_centered_remainder
);
2832 else if (SCM_FRACTIONP (x
))
2835 return scm_i_inexact_centered_remainder
2836 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
2837 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
2838 return scm_i_exact_rational_centered_remainder (x
, y
);
2840 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG2
,
2841 s_scm_centered_remainder
);
2844 return scm_wta_dispatch_2 (g_scm_centered_remainder
, x
, y
, SCM_ARG1
,
2845 s_scm_centered_remainder
);
2850 scm_i_inexact_centered_remainder (double x
, double y
)
2854 /* Although it would be more efficient to use fmod here, we can't
2855 because it would in some cases produce results inconsistent with
2856 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
2857 close). In particular, when x-y/2 is very close to a multiple of
2858 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
2859 two cases must correspond to different choices of q. If quotient
2860 chooses one and remainder chooses the other, it would be bad. */
2861 if (SCM_LIKELY (y
> 0))
2862 q
= floor (x
/y
+ 0.5);
2863 else if (SCM_LIKELY (y
< 0))
2864 q
= ceil (x
/y
- 0.5);
2866 scm_num_overflow (s_scm_centered_remainder
); /* or return a NaN? */
2869 return scm_from_double (x
- q
* y
);
2872 /* Assumes that both x and y are bigints, though
2873 x might be able to fit into a fixnum. */
2875 scm_i_bigint_centered_remainder (SCM x
, SCM y
)
2879 /* Note that x might be small enough to fit into a
2880 fixnum, so we must not let it escape into the wild */
2883 /* min_r will eventually become -abs(y)/2 */
2884 min_r
= scm_i_mkbig ();
2885 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
2886 SCM_I_BIG_MPZ (y
), 1);
2888 /* Arrange for rr to initially be non-positive,
2889 because that simplifies the test to see
2890 if it is within the needed bounds. */
2891 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
2893 mpz_cdiv_r (SCM_I_BIG_MPZ (r
),
2894 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2895 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
2896 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2897 mpz_add (SCM_I_BIG_MPZ (r
),
2903 mpz_fdiv_r (SCM_I_BIG_MPZ (r
),
2904 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2905 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
2906 mpz_sub (SCM_I_BIG_MPZ (r
),
2910 scm_remember_upto_here_2 (x
, y
);
2911 return scm_i_normbig (r
);
2915 scm_i_exact_rational_centered_remainder (SCM x
, SCM y
)
2917 SCM xd
= scm_denominator (x
);
2918 SCM yd
= scm_denominator (y
);
2919 SCM r1
= scm_centered_remainder (scm_product (scm_numerator (x
), yd
),
2920 scm_product (scm_numerator (y
), xd
));
2921 return scm_divide (r1
, scm_product (xd
, yd
));
2925 static void scm_i_inexact_centered_divide (double x
, double y
,
2927 static void scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
2928 static void scm_i_exact_rational_centered_divide (SCM x
, SCM y
,
2931 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide
, "centered/", 2, 0, 0,
2933 "Return the integer @var{q} and the real number @var{r}\n"
2934 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2935 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2937 "(centered/ 123 10) @result{} 12 and 3\n"
2938 "(centered/ 123 -10) @result{} -12 and 3\n"
2939 "(centered/ -123 10) @result{} -12 and -3\n"
2940 "(centered/ -123 -10) @result{} 12 and -3\n"
2941 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2942 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
2944 #define FUNC_NAME s_scm_i_centered_divide
2948 scm_centered_divide(x
, y
, &q
, &r
);
2949 return scm_values (scm_list_2 (q
, r
));
2953 #define s_scm_centered_divide s_scm_i_centered_divide
2954 #define g_scm_centered_divide g_scm_i_centered_divide
2957 scm_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
2959 if (SCM_LIKELY (SCM_I_INUMP (x
)))
2961 scm_t_inum xx
= SCM_I_INUM (x
);
2962 if (SCM_LIKELY (SCM_I_INUMP (y
)))
2964 scm_t_inum yy
= SCM_I_INUM (y
);
2965 if (SCM_UNLIKELY (yy
== 0))
2966 scm_num_overflow (s_scm_centered_divide
);
2969 scm_t_inum qq
= xx
/ yy
;
2970 scm_t_inum rr
= xx
% yy
;
2971 if (SCM_LIKELY (xx
> 0))
2973 if (SCM_LIKELY (yy
> 0))
2975 if (rr
>= (yy
+ 1) / 2)
2980 if (rr
>= (1 - yy
) / 2)
2986 if (SCM_LIKELY (yy
> 0))
2997 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
2998 *qp
= SCM_I_MAKINUM (qq
);
3000 *qp
= scm_i_inum2big (qq
);
3001 *rp
= SCM_I_MAKINUM (rr
);
3005 else if (SCM_BIGP (y
))
3007 /* Pass a denormalized bignum version of x (even though it
3008 can fit in a fixnum) to scm_i_bigint_centered_divide */
3009 return scm_i_bigint_centered_divide (scm_i_long2big (xx
), y
, qp
, rp
);
3011 else if (SCM_REALP (y
))
3012 return scm_i_inexact_centered_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3013 else if (SCM_FRACTIONP (y
))
3014 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3016 return two_valued_wta_dispatch_2
3017 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3018 s_scm_centered_divide
, qp
, rp
);
3020 else if (SCM_BIGP (x
))
3022 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3024 scm_t_inum yy
= SCM_I_INUM (y
);
3025 if (SCM_UNLIKELY (yy
== 0))
3026 scm_num_overflow (s_scm_centered_divide
);
3029 SCM q
= scm_i_mkbig ();
3031 /* Arrange for rr to initially be non-positive,
3032 because that simplifies the test to see
3033 if it is within the needed bounds. */
3036 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3037 SCM_I_BIG_MPZ (x
), yy
);
3038 scm_remember_upto_here_1 (x
);
3041 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3042 SCM_I_BIG_MPZ (q
), 1);
3048 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3049 SCM_I_BIG_MPZ (x
), -yy
);
3050 scm_remember_upto_here_1 (x
);
3051 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3054 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3055 SCM_I_BIG_MPZ (q
), 1);
3059 *qp
= scm_i_normbig (q
);
3060 *rp
= SCM_I_MAKINUM (rr
);
3064 else if (SCM_BIGP (y
))
3065 return scm_i_bigint_centered_divide (x
, y
, qp
, rp
);
3066 else if (SCM_REALP (y
))
3067 return scm_i_inexact_centered_divide
3068 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3069 else if (SCM_FRACTIONP (y
))
3070 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3072 return two_valued_wta_dispatch_2
3073 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3074 s_scm_centered_divide
, qp
, rp
);
3076 else if (SCM_REALP (x
))
3078 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3079 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3080 return scm_i_inexact_centered_divide
3081 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3083 return two_valued_wta_dispatch_2
3084 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3085 s_scm_centered_divide
, qp
, rp
);
3087 else if (SCM_FRACTIONP (x
))
3090 return scm_i_inexact_centered_divide
3091 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3092 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3093 return scm_i_exact_rational_centered_divide (x
, y
, qp
, rp
);
3095 return two_valued_wta_dispatch_2
3096 (g_scm_centered_divide
, x
, y
, SCM_ARG2
,
3097 s_scm_centered_divide
, qp
, rp
);
3100 return two_valued_wta_dispatch_2 (g_scm_centered_divide
, x
, y
, SCM_ARG1
,
3101 s_scm_centered_divide
, qp
, rp
);
3105 scm_i_inexact_centered_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3109 if (SCM_LIKELY (y
> 0))
3110 q
= floor (x
/y
+ 0.5);
3111 else if (SCM_LIKELY (y
< 0))
3112 q
= ceil (x
/y
- 0.5);
3114 scm_num_overflow (s_scm_centered_divide
); /* or return a NaN? */
3118 *qp
= scm_from_double (q
);
3119 *rp
= scm_from_double (r
);
3122 /* Assumes that both x and y are bigints, though
3123 x might be able to fit into a fixnum. */
3125 scm_i_bigint_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3129 /* Note that x might be small enough to fit into a
3130 fixnum, so we must not let it escape into the wild */
3134 /* min_r will eventually become -abs(y/2) */
3135 min_r
= scm_i_mkbig ();
3136 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r
),
3137 SCM_I_BIG_MPZ (y
), 1);
3139 /* Arrange for rr to initially be non-positive,
3140 because that simplifies the test to see
3141 if it is within the needed bounds. */
3142 if (mpz_sgn (SCM_I_BIG_MPZ (y
)) > 0)
3144 mpz_cdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3145 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3146 mpz_neg (SCM_I_BIG_MPZ (min_r
), SCM_I_BIG_MPZ (min_r
));
3147 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3149 mpz_sub_ui (SCM_I_BIG_MPZ (q
),
3150 SCM_I_BIG_MPZ (q
), 1);
3151 mpz_add (SCM_I_BIG_MPZ (r
),
3158 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3159 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3160 if (mpz_cmp (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (min_r
)) < 0)
3162 mpz_add_ui (SCM_I_BIG_MPZ (q
),
3163 SCM_I_BIG_MPZ (q
), 1);
3164 mpz_sub (SCM_I_BIG_MPZ (r
),
3169 scm_remember_upto_here_2 (x
, y
);
3170 *qp
= scm_i_normbig (q
);
3171 *rp
= scm_i_normbig (r
);
3175 scm_i_exact_rational_centered_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3178 SCM xd
= scm_denominator (x
);
3179 SCM yd
= scm_denominator (y
);
3181 scm_centered_divide (scm_product (scm_numerator (x
), yd
),
3182 scm_product (scm_numerator (y
), xd
),
3184 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3187 static SCM
scm_i_inexact_round_quotient (double x
, double y
);
3188 static SCM
scm_i_bigint_round_quotient (SCM x
, SCM y
);
3189 static SCM
scm_i_exact_rational_round_quotient (SCM x
, SCM y
);
3191 SCM_PRIMITIVE_GENERIC (scm_round_quotient
, "round-quotient", 2, 0, 0,
3193 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3194 "with ties going to the nearest even integer.\n"
3196 "(round-quotient 123 10) @result{} 12\n"
3197 "(round-quotient 123 -10) @result{} -12\n"
3198 "(round-quotient -123 10) @result{} -12\n"
3199 "(round-quotient -123 -10) @result{} 12\n"
3200 "(round-quotient 125 10) @result{} 12\n"
3201 "(round-quotient 127 10) @result{} 13\n"
3202 "(round-quotient 135 10) @result{} 14\n"
3203 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3204 "(round-quotient 16/3 -10/7) @result{} -4\n"
3206 #define FUNC_NAME s_scm_round_quotient
3208 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3210 scm_t_inum xx
= SCM_I_INUM (x
);
3211 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3213 scm_t_inum yy
= SCM_I_INUM (y
);
3214 if (SCM_UNLIKELY (yy
== 0))
3215 scm_num_overflow (s_scm_round_quotient
);
3218 scm_t_inum qq
= xx
/ yy
;
3219 scm_t_inum rr
= xx
% yy
;
3221 scm_t_inum r2
= 2 * rr
;
3223 if (SCM_LIKELY (yy
< 0))
3243 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3244 return SCM_I_MAKINUM (qq
);
3246 return scm_i_inum2big (qq
);
3249 else if (SCM_BIGP (y
))
3251 /* Pass a denormalized bignum version of x (even though it
3252 can fit in a fixnum) to scm_i_bigint_round_quotient */
3253 return scm_i_bigint_round_quotient (scm_i_long2big (xx
), y
);
3255 else if (SCM_REALP (y
))
3256 return scm_i_inexact_round_quotient (xx
, SCM_REAL_VALUE (y
));
3257 else if (SCM_FRACTIONP (y
))
3258 return scm_i_exact_rational_round_quotient (x
, y
);
3260 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3261 s_scm_round_quotient
);
3263 else if (SCM_BIGP (x
))
3265 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3267 scm_t_inum yy
= SCM_I_INUM (y
);
3268 if (SCM_UNLIKELY (yy
== 0))
3269 scm_num_overflow (s_scm_round_quotient
);
3270 else if (SCM_UNLIKELY (yy
== 1))
3274 SCM q
= scm_i_mkbig ();
3276 int needs_adjustment
;
3280 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3281 SCM_I_BIG_MPZ (x
), yy
);
3282 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3283 needs_adjustment
= (2*rr
>= yy
);
3285 needs_adjustment
= (2*rr
> yy
);
3289 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3290 SCM_I_BIG_MPZ (x
), -yy
);
3291 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3292 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3293 needs_adjustment
= (2*rr
<= yy
);
3295 needs_adjustment
= (2*rr
< yy
);
3297 scm_remember_upto_here_1 (x
);
3298 if (needs_adjustment
)
3299 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3300 return scm_i_normbig (q
);
3303 else if (SCM_BIGP (y
))
3304 return scm_i_bigint_round_quotient (x
, y
);
3305 else if (SCM_REALP (y
))
3306 return scm_i_inexact_round_quotient
3307 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3308 else if (SCM_FRACTIONP (y
))
3309 return scm_i_exact_rational_round_quotient (x
, y
);
3311 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3312 s_scm_round_quotient
);
3314 else if (SCM_REALP (x
))
3316 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3317 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3318 return scm_i_inexact_round_quotient
3319 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3321 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3322 s_scm_round_quotient
);
3324 else if (SCM_FRACTIONP (x
))
3327 return scm_i_inexact_round_quotient
3328 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3329 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3330 return scm_i_exact_rational_round_quotient (x
, y
);
3332 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG2
,
3333 s_scm_round_quotient
);
3336 return scm_wta_dispatch_2 (g_scm_round_quotient
, x
, y
, SCM_ARG1
,
3337 s_scm_round_quotient
);
3342 scm_i_inexact_round_quotient (double x
, double y
)
3344 if (SCM_UNLIKELY (y
== 0))
3345 scm_num_overflow (s_scm_round_quotient
); /* or return a NaN? */
3347 return scm_from_double (scm_c_round (x
/ y
));
3350 /* Assumes that both x and y are bigints, though
3351 x might be able to fit into a fixnum. */
3353 scm_i_bigint_round_quotient (SCM x
, SCM y
)
3356 int cmp
, needs_adjustment
;
3358 /* Note that x might be small enough to fit into a
3359 fixnum, so we must not let it escape into the wild */
3362 r2
= scm_i_mkbig ();
3364 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3365 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3366 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3367 scm_remember_upto_here_2 (x
, r
);
3369 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3370 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3371 needs_adjustment
= (cmp
>= 0);
3373 needs_adjustment
= (cmp
> 0);
3374 scm_remember_upto_here_2 (r2
, y
);
3376 if (needs_adjustment
)
3377 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3379 return scm_i_normbig (q
);
3383 scm_i_exact_rational_round_quotient (SCM x
, SCM y
)
3385 return scm_round_quotient
3386 (scm_product (scm_numerator (x
), scm_denominator (y
)),
3387 scm_product (scm_numerator (y
), scm_denominator (x
)));
3390 static SCM
scm_i_inexact_round_remainder (double x
, double y
);
3391 static SCM
scm_i_bigint_round_remainder (SCM x
, SCM y
);
3392 static SCM
scm_i_exact_rational_round_remainder (SCM x
, SCM y
);
3394 SCM_PRIMITIVE_GENERIC (scm_round_remainder
, "round-remainder", 2, 0, 0,
3396 "Return the real number @var{r} such that\n"
3397 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3398 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3399 "nearest integer, with ties going to the nearest\n"
3402 "(round-remainder 123 10) @result{} 3\n"
3403 "(round-remainder 123 -10) @result{} 3\n"
3404 "(round-remainder -123 10) @result{} -3\n"
3405 "(round-remainder -123 -10) @result{} -3\n"
3406 "(round-remainder 125 10) @result{} 5\n"
3407 "(round-remainder 127 10) @result{} -3\n"
3408 "(round-remainder 135 10) @result{} -5\n"
3409 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3410 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3412 #define FUNC_NAME s_scm_round_remainder
3414 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3416 scm_t_inum xx
= SCM_I_INUM (x
);
3417 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3419 scm_t_inum yy
= SCM_I_INUM (y
);
3420 if (SCM_UNLIKELY (yy
== 0))
3421 scm_num_overflow (s_scm_round_remainder
);
3424 scm_t_inum qq
= xx
/ yy
;
3425 scm_t_inum rr
= xx
% yy
;
3427 scm_t_inum r2
= 2 * rr
;
3429 if (SCM_LIKELY (yy
< 0))
3449 return SCM_I_MAKINUM (rr
);
3452 else if (SCM_BIGP (y
))
3454 /* Pass a denormalized bignum version of x (even though it
3455 can fit in a fixnum) to scm_i_bigint_round_remainder */
3456 return scm_i_bigint_round_remainder
3457 (scm_i_long2big (xx
), y
);
3459 else if (SCM_REALP (y
))
3460 return scm_i_inexact_round_remainder (xx
, SCM_REAL_VALUE (y
));
3461 else if (SCM_FRACTIONP (y
))
3462 return scm_i_exact_rational_round_remainder (x
, y
);
3464 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3465 s_scm_round_remainder
);
3467 else if (SCM_BIGP (x
))
3469 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3471 scm_t_inum yy
= SCM_I_INUM (y
);
3472 if (SCM_UNLIKELY (yy
== 0))
3473 scm_num_overflow (s_scm_round_remainder
);
3476 SCM q
= scm_i_mkbig ();
3478 int needs_adjustment
;
3482 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3483 SCM_I_BIG_MPZ (x
), yy
);
3484 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3485 needs_adjustment
= (2*rr
>= yy
);
3487 needs_adjustment
= (2*rr
> yy
);
3491 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3492 SCM_I_BIG_MPZ (x
), -yy
);
3493 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3494 needs_adjustment
= (2*rr
<= yy
);
3496 needs_adjustment
= (2*rr
< yy
);
3498 scm_remember_upto_here_2 (x
, q
);
3499 if (needs_adjustment
)
3501 return SCM_I_MAKINUM (rr
);
3504 else if (SCM_BIGP (y
))
3505 return scm_i_bigint_round_remainder (x
, y
);
3506 else if (SCM_REALP (y
))
3507 return scm_i_inexact_round_remainder
3508 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
));
3509 else if (SCM_FRACTIONP (y
))
3510 return scm_i_exact_rational_round_remainder (x
, y
);
3512 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3513 s_scm_round_remainder
);
3515 else if (SCM_REALP (x
))
3517 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3518 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3519 return scm_i_inexact_round_remainder
3520 (SCM_REAL_VALUE (x
), scm_to_double (y
));
3522 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3523 s_scm_round_remainder
);
3525 else if (SCM_FRACTIONP (x
))
3528 return scm_i_inexact_round_remainder
3529 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
));
3530 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3531 return scm_i_exact_rational_round_remainder (x
, y
);
3533 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG2
,
3534 s_scm_round_remainder
);
3537 return scm_wta_dispatch_2 (g_scm_round_remainder
, x
, y
, SCM_ARG1
,
3538 s_scm_round_remainder
);
3543 scm_i_inexact_round_remainder (double x
, double y
)
3545 /* Although it would be more efficient to use fmod here, we can't
3546 because it would in some cases produce results inconsistent with
3547 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3548 close). In particular, when x-y/2 is very close to a multiple of
3549 y, then r might be either -abs(y/2) or abs(y/2), but those two
3550 cases must correspond to different choices of q. If quotient
3551 chooses one and remainder chooses the other, it would be bad. */
3553 if (SCM_UNLIKELY (y
== 0))
3554 scm_num_overflow (s_scm_round_remainder
); /* or return a NaN? */
3557 double q
= scm_c_round (x
/ y
);
3558 return scm_from_double (x
- q
* y
);
3562 /* Assumes that both x and y are bigints, though
3563 x might be able to fit into a fixnum. */
3565 scm_i_bigint_round_remainder (SCM x
, SCM y
)
3568 int cmp
, needs_adjustment
;
3570 /* Note that x might be small enough to fit into a
3571 fixnum, so we must not let it escape into the wild */
3574 r2
= scm_i_mkbig ();
3576 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3577 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3578 scm_remember_upto_here_1 (x
);
3579 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3581 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3582 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3583 needs_adjustment
= (cmp
>= 0);
3585 needs_adjustment
= (cmp
> 0);
3586 scm_remember_upto_here_2 (q
, r2
);
3588 if (needs_adjustment
)
3589 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3591 scm_remember_upto_here_1 (y
);
3592 return scm_i_normbig (r
);
3596 scm_i_exact_rational_round_remainder (SCM x
, SCM y
)
3598 SCM xd
= scm_denominator (x
);
3599 SCM yd
= scm_denominator (y
);
3600 SCM r1
= scm_round_remainder (scm_product (scm_numerator (x
), yd
),
3601 scm_product (scm_numerator (y
), xd
));
3602 return scm_divide (r1
, scm_product (xd
, yd
));
3606 static void scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
);
3607 static void scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3608 static void scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
);
3610 SCM_PRIMITIVE_GENERIC (scm_i_round_divide
, "round/", 2, 0, 0,
3612 "Return the integer @var{q} and the real number @var{r}\n"
3613 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3614 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3615 "nearest integer, with ties going to the nearest even integer.\n"
3617 "(round/ 123 10) @result{} 12 and 3\n"
3618 "(round/ 123 -10) @result{} -12 and 3\n"
3619 "(round/ -123 10) @result{} -12 and -3\n"
3620 "(round/ -123 -10) @result{} 12 and -3\n"
3621 "(round/ 125 10) @result{} 12 and 5\n"
3622 "(round/ 127 10) @result{} 13 and -3\n"
3623 "(round/ 135 10) @result{} 14 and -5\n"
3624 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3625 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3627 #define FUNC_NAME s_scm_i_round_divide
3631 scm_round_divide(x
, y
, &q
, &r
);
3632 return scm_values (scm_list_2 (q
, r
));
3636 #define s_scm_round_divide s_scm_i_round_divide
3637 #define g_scm_round_divide g_scm_i_round_divide
3640 scm_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3642 if (SCM_LIKELY (SCM_I_INUMP (x
)))
3644 scm_t_inum xx
= SCM_I_INUM (x
);
3645 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3647 scm_t_inum yy
= SCM_I_INUM (y
);
3648 if (SCM_UNLIKELY (yy
== 0))
3649 scm_num_overflow (s_scm_round_divide
);
3652 scm_t_inum qq
= xx
/ yy
;
3653 scm_t_inum rr
= xx
% yy
;
3655 scm_t_inum r2
= 2 * rr
;
3657 if (SCM_LIKELY (yy
< 0))
3677 if (SCM_LIKELY (SCM_FIXABLE (qq
)))
3678 *qp
= SCM_I_MAKINUM (qq
);
3680 *qp
= scm_i_inum2big (qq
);
3681 *rp
= SCM_I_MAKINUM (rr
);
3685 else if (SCM_BIGP (y
))
3687 /* Pass a denormalized bignum version of x (even though it
3688 can fit in a fixnum) to scm_i_bigint_round_divide */
3689 return scm_i_bigint_round_divide
3690 (scm_i_long2big (SCM_I_INUM (x
)), y
, qp
, rp
);
3692 else if (SCM_REALP (y
))
3693 return scm_i_inexact_round_divide (xx
, SCM_REAL_VALUE (y
), qp
, rp
);
3694 else if (SCM_FRACTIONP (y
))
3695 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3697 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3698 s_scm_round_divide
, qp
, rp
);
3700 else if (SCM_BIGP (x
))
3702 if (SCM_LIKELY (SCM_I_INUMP (y
)))
3704 scm_t_inum yy
= SCM_I_INUM (y
);
3705 if (SCM_UNLIKELY (yy
== 0))
3706 scm_num_overflow (s_scm_round_divide
);
3709 SCM q
= scm_i_mkbig ();
3711 int needs_adjustment
;
3715 rr
= mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q
),
3716 SCM_I_BIG_MPZ (x
), yy
);
3717 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3718 needs_adjustment
= (2*rr
>= yy
);
3720 needs_adjustment
= (2*rr
> yy
);
3724 rr
= - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q
),
3725 SCM_I_BIG_MPZ (x
), -yy
);
3726 mpz_neg (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
));
3727 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3728 needs_adjustment
= (2*rr
<= yy
);
3730 needs_adjustment
= (2*rr
< yy
);
3732 scm_remember_upto_here_1 (x
);
3733 if (needs_adjustment
)
3735 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3738 *qp
= scm_i_normbig (q
);
3739 *rp
= SCM_I_MAKINUM (rr
);
3743 else if (SCM_BIGP (y
))
3744 return scm_i_bigint_round_divide (x
, y
, qp
, rp
);
3745 else if (SCM_REALP (y
))
3746 return scm_i_inexact_round_divide
3747 (scm_i_big2dbl (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3748 else if (SCM_FRACTIONP (y
))
3749 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3751 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3752 s_scm_round_divide
, qp
, rp
);
3754 else if (SCM_REALP (x
))
3756 if (SCM_REALP (y
) || SCM_I_INUMP (y
) ||
3757 SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3758 return scm_i_inexact_round_divide
3759 (SCM_REAL_VALUE (x
), scm_to_double (y
), qp
, rp
);
3761 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3762 s_scm_round_divide
, qp
, rp
);
3764 else if (SCM_FRACTIONP (x
))
3767 return scm_i_inexact_round_divide
3768 (scm_i_fraction2double (x
), SCM_REAL_VALUE (y
), qp
, rp
);
3769 else if (SCM_I_INUMP (y
) || SCM_BIGP (y
) || SCM_FRACTIONP (y
))
3770 return scm_i_exact_rational_round_divide (x
, y
, qp
, rp
);
3772 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG2
,
3773 s_scm_round_divide
, qp
, rp
);
3776 return two_valued_wta_dispatch_2 (g_scm_round_divide
, x
, y
, SCM_ARG1
,
3777 s_scm_round_divide
, qp
, rp
);
3781 scm_i_inexact_round_divide (double x
, double y
, SCM
*qp
, SCM
*rp
)
3783 if (SCM_UNLIKELY (y
== 0))
3784 scm_num_overflow (s_scm_round_divide
); /* or return a NaN? */
3787 double q
= scm_c_round (x
/ y
);
3788 double r
= x
- q
* y
;
3789 *qp
= scm_from_double (q
);
3790 *rp
= scm_from_double (r
);
3794 /* Assumes that both x and y are bigints, though
3795 x might be able to fit into a fixnum. */
3797 scm_i_bigint_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3800 int cmp
, needs_adjustment
;
3802 /* Note that x might be small enough to fit into a
3803 fixnum, so we must not let it escape into the wild */
3806 r2
= scm_i_mkbig ();
3808 mpz_fdiv_qr (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (r
),
3809 SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3810 scm_remember_upto_here_1 (x
);
3811 mpz_mul_2exp (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (r
), 1); /* r2 = 2*r */
3813 cmp
= mpz_cmpabs (SCM_I_BIG_MPZ (r2
), SCM_I_BIG_MPZ (y
));
3814 if (mpz_odd_p (SCM_I_BIG_MPZ (q
)))
3815 needs_adjustment
= (cmp
>= 0);
3817 needs_adjustment
= (cmp
> 0);
3819 if (needs_adjustment
)
3821 mpz_add_ui (SCM_I_BIG_MPZ (q
), SCM_I_BIG_MPZ (q
), 1);
3822 mpz_sub (SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (y
));
3825 scm_remember_upto_here_2 (r2
, y
);
3826 *qp
= scm_i_normbig (q
);
3827 *rp
= scm_i_normbig (r
);
3831 scm_i_exact_rational_round_divide (SCM x
, SCM y
, SCM
*qp
, SCM
*rp
)
3834 SCM xd
= scm_denominator (x
);
3835 SCM yd
= scm_denominator (y
);
3837 scm_round_divide (scm_product (scm_numerator (x
), yd
),
3838 scm_product (scm_numerator (y
), xd
),
3840 *rp
= scm_divide (r1
, scm_product (xd
, yd
));
3844 SCM_PRIMITIVE_GENERIC (scm_i_gcd
, "gcd", 0, 2, 1,
3845 (SCM x
, SCM y
, SCM rest
),
3846 "Return the greatest common divisor of all parameter values.\n"
3847 "If called without arguments, 0 is returned.")
3848 #define FUNC_NAME s_scm_i_gcd
3850 while (!scm_is_null (rest
))
3851 { x
= scm_gcd (x
, y
);
3853 rest
= scm_cdr (rest
);
3855 return scm_gcd (x
, y
);
3859 #define s_gcd s_scm_i_gcd
3860 #define g_gcd g_scm_i_gcd
3863 scm_gcd (SCM x
, SCM y
)
3866 return SCM_UNBNDP (x
) ? SCM_INUM0
: scm_abs (x
);
3868 if (SCM_I_INUMP (x
))
3870 if (SCM_I_INUMP (y
))
3872 scm_t_inum xx
= SCM_I_INUM (x
);
3873 scm_t_inum yy
= SCM_I_INUM (y
);
3874 scm_t_inum u
= xx
< 0 ? -xx
: xx
;
3875 scm_t_inum v
= yy
< 0 ? -yy
: yy
;
3885 /* Determine a common factor 2^k */
3886 while (!(1 & (u
| v
)))
3892 /* Now, any factor 2^n can be eliminated */
3912 return (SCM_POSFIXABLE (result
)
3913 ? SCM_I_MAKINUM (result
)
3914 : scm_i_inum2big (result
));
3916 else if (SCM_BIGP (y
))
3922 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3924 else if (SCM_BIGP (x
))
3926 if (SCM_I_INUMP (y
))
3931 yy
= SCM_I_INUM (y
);
3936 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
3937 scm_remember_upto_here_1 (x
);
3938 return (SCM_POSFIXABLE (result
)
3939 ? SCM_I_MAKINUM (result
)
3940 : scm_from_unsigned_integer (result
));
3942 else if (SCM_BIGP (y
))
3944 SCM result
= scm_i_mkbig ();
3945 mpz_gcd (SCM_I_BIG_MPZ (result
),
3948 scm_remember_upto_here_2 (x
, y
);
3949 return scm_i_normbig (result
);
3952 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
3955 return scm_wta_dispatch_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
3958 SCM_PRIMITIVE_GENERIC (scm_i_lcm
, "lcm", 0, 2, 1,
3959 (SCM x
, SCM y
, SCM rest
),
3960 "Return the least common multiple of the arguments.\n"
3961 "If called without arguments, 1 is returned.")
3962 #define FUNC_NAME s_scm_i_lcm
3964 while (!scm_is_null (rest
))
3965 { x
= scm_lcm (x
, y
);
3967 rest
= scm_cdr (rest
);
3969 return scm_lcm (x
, y
);
3973 #define s_lcm s_scm_i_lcm
3974 #define g_lcm g_scm_i_lcm
3977 scm_lcm (SCM n1
, SCM n2
)
3979 if (SCM_UNBNDP (n2
))
3981 if (SCM_UNBNDP (n1
))
3982 return SCM_I_MAKINUM (1L);
3983 n2
= SCM_I_MAKINUM (1L);
3986 if (SCM_UNLIKELY (!(SCM_I_INUMP (n1
) || SCM_BIGP (n1
))))
3987 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
3989 if (SCM_UNLIKELY (!(SCM_I_INUMP (n2
) || SCM_BIGP (n2
))))
3990 return scm_wta_dispatch_2 (g_lcm
, n1
, n2
, SCM_ARG2
, s_lcm
);
3992 if (SCM_I_INUMP (n1
))
3994 if (SCM_I_INUMP (n2
))
3996 SCM d
= scm_gcd (n1
, n2
);
3997 if (scm_is_eq (d
, SCM_INUM0
))
4000 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
4004 /* inum n1, big n2 */
4007 SCM result
= scm_i_mkbig ();
4008 scm_t_inum nn1
= SCM_I_INUM (n1
);
4009 if (nn1
== 0) return SCM_INUM0
;
4010 if (nn1
< 0) nn1
= - nn1
;
4011 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
4012 scm_remember_upto_here_1 (n2
);
4020 if (SCM_I_INUMP (n2
))
4027 SCM result
= scm_i_mkbig ();
4028 mpz_lcm(SCM_I_BIG_MPZ (result
),
4030 SCM_I_BIG_MPZ (n2
));
4031 scm_remember_upto_here_2(n1
, n2
);
4032 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4038 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4043 + + + x (map digit:logand X Y)
4044 + - + x (map digit:logand X (lognot (+ -1 Y)))
4045 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4046 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4051 + + + (map digit:logior X Y)
4052 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4053 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4054 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4059 + + + (map digit:logxor X Y)
4060 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4061 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4062 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4067 + + (any digit:logand X Y)
4068 + - (any digit:logand X (lognot (+ -1 Y)))
4069 - + (any digit:logand (lognot (+ -1 X)) Y)
4074 SCM_DEFINE (scm_i_logand
, "logand", 0, 2, 1,
4075 (SCM x
, SCM y
, SCM rest
),
4076 "Return the bitwise AND of the integer arguments.\n\n"
4078 "(logand) @result{} -1\n"
4079 "(logand 7) @result{} 7\n"
4080 "(logand #b111 #b011 #b001) @result{} 1\n"
4082 #define FUNC_NAME s_scm_i_logand
4084 while (!scm_is_null (rest
))
4085 { x
= scm_logand (x
, y
);
4087 rest
= scm_cdr (rest
);
4089 return scm_logand (x
, y
);
4093 #define s_scm_logand s_scm_i_logand
4095 SCM
scm_logand (SCM n1
, SCM n2
)
4096 #define FUNC_NAME s_scm_logand
4100 if (SCM_UNBNDP (n2
))
4102 if (SCM_UNBNDP (n1
))
4103 return SCM_I_MAKINUM (-1);
4104 else if (!SCM_NUMBERP (n1
))
4105 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4106 else if (SCM_NUMBERP (n1
))
4109 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4112 if (SCM_I_INUMP (n1
))
4114 nn1
= SCM_I_INUM (n1
);
4115 if (SCM_I_INUMP (n2
))
4117 scm_t_inum nn2
= SCM_I_INUM (n2
);
4118 return SCM_I_MAKINUM (nn1
& nn2
);
4120 else if SCM_BIGP (n2
)
4126 SCM result_z
= scm_i_mkbig ();
4128 mpz_init_set_si (nn1_z
, nn1
);
4129 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4130 scm_remember_upto_here_1 (n2
);
4132 return scm_i_normbig (result_z
);
4136 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4138 else if (SCM_BIGP (n1
))
4140 if (SCM_I_INUMP (n2
))
4143 nn1
= SCM_I_INUM (n1
);
4146 else if (SCM_BIGP (n2
))
4148 SCM result_z
= scm_i_mkbig ();
4149 mpz_and (SCM_I_BIG_MPZ (result_z
),
4151 SCM_I_BIG_MPZ (n2
));
4152 scm_remember_upto_here_2 (n1
, n2
);
4153 return scm_i_normbig (result_z
);
4156 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4159 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4164 SCM_DEFINE (scm_i_logior
, "logior", 0, 2, 1,
4165 (SCM x
, SCM y
, SCM rest
),
4166 "Return the bitwise OR of the integer arguments.\n\n"
4168 "(logior) @result{} 0\n"
4169 "(logior 7) @result{} 7\n"
4170 "(logior #b000 #b001 #b011) @result{} 3\n"
4172 #define FUNC_NAME s_scm_i_logior
4174 while (!scm_is_null (rest
))
4175 { x
= scm_logior (x
, y
);
4177 rest
= scm_cdr (rest
);
4179 return scm_logior (x
, y
);
4183 #define s_scm_logior s_scm_i_logior
4185 SCM
scm_logior (SCM n1
, SCM n2
)
4186 #define FUNC_NAME s_scm_logior
4190 if (SCM_UNBNDP (n2
))
4192 if (SCM_UNBNDP (n1
))
4194 else if (SCM_NUMBERP (n1
))
4197 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4200 if (SCM_I_INUMP (n1
))
4202 nn1
= SCM_I_INUM (n1
);
4203 if (SCM_I_INUMP (n2
))
4205 long nn2
= SCM_I_INUM (n2
);
4206 return SCM_I_MAKINUM (nn1
| nn2
);
4208 else if (SCM_BIGP (n2
))
4214 SCM result_z
= scm_i_mkbig ();
4216 mpz_init_set_si (nn1_z
, nn1
);
4217 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4218 scm_remember_upto_here_1 (n2
);
4220 return scm_i_normbig (result_z
);
4224 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4226 else if (SCM_BIGP (n1
))
4228 if (SCM_I_INUMP (n2
))
4231 nn1
= SCM_I_INUM (n1
);
4234 else if (SCM_BIGP (n2
))
4236 SCM result_z
= scm_i_mkbig ();
4237 mpz_ior (SCM_I_BIG_MPZ (result_z
),
4239 SCM_I_BIG_MPZ (n2
));
4240 scm_remember_upto_here_2 (n1
, n2
);
4241 return scm_i_normbig (result_z
);
4244 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4247 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4252 SCM_DEFINE (scm_i_logxor
, "logxor", 0, 2, 1,
4253 (SCM x
, SCM y
, SCM rest
),
4254 "Return the bitwise XOR of the integer arguments. A bit is\n"
4255 "set in the result if it is set in an odd number of arguments.\n"
4257 "(logxor) @result{} 0\n"
4258 "(logxor 7) @result{} 7\n"
4259 "(logxor #b000 #b001 #b011) @result{} 2\n"
4260 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4262 #define FUNC_NAME s_scm_i_logxor
4264 while (!scm_is_null (rest
))
4265 { x
= scm_logxor (x
, y
);
4267 rest
= scm_cdr (rest
);
4269 return scm_logxor (x
, y
);
4273 #define s_scm_logxor s_scm_i_logxor
4275 SCM
scm_logxor (SCM n1
, SCM n2
)
4276 #define FUNC_NAME s_scm_logxor
4280 if (SCM_UNBNDP (n2
))
4282 if (SCM_UNBNDP (n1
))
4284 else if (SCM_NUMBERP (n1
))
4287 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4290 if (SCM_I_INUMP (n1
))
4292 nn1
= SCM_I_INUM (n1
);
4293 if (SCM_I_INUMP (n2
))
4295 scm_t_inum nn2
= SCM_I_INUM (n2
);
4296 return SCM_I_MAKINUM (nn1
^ nn2
);
4298 else if (SCM_BIGP (n2
))
4302 SCM result_z
= scm_i_mkbig ();
4304 mpz_init_set_si (nn1_z
, nn1
);
4305 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
4306 scm_remember_upto_here_1 (n2
);
4308 return scm_i_normbig (result_z
);
4312 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4314 else if (SCM_BIGP (n1
))
4316 if (SCM_I_INUMP (n2
))
4319 nn1
= SCM_I_INUM (n1
);
4322 else if (SCM_BIGP (n2
))
4324 SCM result_z
= scm_i_mkbig ();
4325 mpz_xor (SCM_I_BIG_MPZ (result_z
),
4327 SCM_I_BIG_MPZ (n2
));
4328 scm_remember_upto_here_2 (n1
, n2
);
4329 return scm_i_normbig (result_z
);
4332 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
4335 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
4340 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
4342 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4343 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4344 "without actually calculating the @code{logand}, just testing\n"
4348 "(logtest #b0100 #b1011) @result{} #f\n"
4349 "(logtest #b0100 #b0111) @result{} #t\n"
4351 #define FUNC_NAME s_scm_logtest
4355 if (SCM_I_INUMP (j
))
4357 nj
= SCM_I_INUM (j
);
4358 if (SCM_I_INUMP (k
))
4360 scm_t_inum nk
= SCM_I_INUM (k
);
4361 return scm_from_bool (nj
& nk
);
4363 else if (SCM_BIGP (k
))
4371 mpz_init_set_si (nj_z
, nj
);
4372 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
4373 scm_remember_upto_here_1 (k
);
4374 result
= scm_from_bool (mpz_sgn (nj_z
) != 0);
4380 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4382 else if (SCM_BIGP (j
))
4384 if (SCM_I_INUMP (k
))
4387 nj
= SCM_I_INUM (j
);
4390 else if (SCM_BIGP (k
))
4394 mpz_init (result_z
);
4398 scm_remember_upto_here_2 (j
, k
);
4399 result
= scm_from_bool (mpz_sgn (result_z
) != 0);
4400 mpz_clear (result_z
);
4404 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
4407 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
4412 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
4414 "Test whether bit number @var{index} in @var{j} is set.\n"
4415 "@var{index} starts from 0 for the least significant bit.\n"
4418 "(logbit? 0 #b1101) @result{} #t\n"
4419 "(logbit? 1 #b1101) @result{} #f\n"
4420 "(logbit? 2 #b1101) @result{} #t\n"
4421 "(logbit? 3 #b1101) @result{} #t\n"
4422 "(logbit? 4 #b1101) @result{} #f\n"
4424 #define FUNC_NAME s_scm_logbit_p
4426 unsigned long int iindex
;
4427 iindex
= scm_to_ulong (index
);
4429 if (SCM_I_INUMP (j
))
4431 /* bits above what's in an inum follow the sign bit */
4432 iindex
= min (iindex
, SCM_LONG_BIT
- 1);
4433 return scm_from_bool ((1L << iindex
) & SCM_I_INUM (j
));
4435 else if (SCM_BIGP (j
))
4437 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
4438 scm_remember_upto_here_1 (j
);
4439 return scm_from_bool (val
);
4442 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
4447 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
4449 "Return the integer which is the ones-complement of the integer\n"
4453 "(number->string (lognot #b10000000) 2)\n"
4454 " @result{} \"-10000001\"\n"
4455 "(number->string (lognot #b0) 2)\n"
4456 " @result{} \"-1\"\n"
4458 #define FUNC_NAME s_scm_lognot
4460 if (SCM_I_INUMP (n
)) {
4461 /* No overflow here, just need to toggle all the bits making up the inum.
4462 Enhancement: No need to strip the tag and add it back, could just xor
4463 a block of 1 bits, if that worked with the various debug versions of
4465 return SCM_I_MAKINUM (~ SCM_I_INUM (n
));
4467 } else if (SCM_BIGP (n
)) {
4468 SCM result
= scm_i_mkbig ();
4469 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
4470 scm_remember_upto_here_1 (n
);
4474 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4479 /* returns 0 if IN is not an integer. OUT must already be
4482 coerce_to_big (SCM in
, mpz_t out
)
4485 mpz_set (out
, SCM_I_BIG_MPZ (in
));
4486 else if (SCM_I_INUMP (in
))
4487 mpz_set_si (out
, SCM_I_INUM (in
));
4494 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
4495 (SCM n
, SCM k
, SCM m
),
4496 "Return @var{n} raised to the integer exponent\n"
4497 "@var{k}, modulo @var{m}.\n"
4500 "(modulo-expt 2 3 5)\n"
4503 #define FUNC_NAME s_scm_modulo_expt
4509 /* There are two classes of error we might encounter --
4510 1) Math errors, which we'll report by calling scm_num_overflow,
4512 2) wrong-type errors, which of course we'll report by calling
4514 We don't report those errors immediately, however; instead we do
4515 some cleanup first. These variables tell us which error (if
4516 any) we should report after cleaning up.
4518 int report_overflow
= 0;
4520 int position_of_wrong_type
= 0;
4521 SCM value_of_wrong_type
= SCM_INUM0
;
4523 SCM result
= SCM_UNDEFINED
;
4529 if (scm_is_eq (m
, SCM_INUM0
))
4531 report_overflow
= 1;
4535 if (!coerce_to_big (n
, n_tmp
))
4537 value_of_wrong_type
= n
;
4538 position_of_wrong_type
= 1;
4542 if (!coerce_to_big (k
, k_tmp
))
4544 value_of_wrong_type
= k
;
4545 position_of_wrong_type
= 2;
4549 if (!coerce_to_big (m
, m_tmp
))
4551 value_of_wrong_type
= m
;
4552 position_of_wrong_type
= 3;
4556 /* if the exponent K is negative, and we simply call mpz_powm, we
4557 will get a divide-by-zero exception when an inverse 1/n mod m
4558 doesn't exist (or is not unique). Since exceptions are hard to
4559 handle, we'll attempt the inversion "by hand" -- that way, we get
4560 a simple failure code, which is easy to handle. */
4562 if (-1 == mpz_sgn (k_tmp
))
4564 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
4566 report_overflow
= 1;
4569 mpz_neg (k_tmp
, k_tmp
);
4572 result
= scm_i_mkbig ();
4573 mpz_powm (SCM_I_BIG_MPZ (result
),
4578 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
4579 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
4586 if (report_overflow
)
4587 scm_num_overflow (FUNC_NAME
);
4589 if (position_of_wrong_type
)
4590 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
4591 value_of_wrong_type
);
4593 return scm_i_normbig (result
);
4597 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
4599 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4600 "exact integer, @var{n} can be any number.\n"
4602 "Negative @var{k} is supported, and results in\n"
4603 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4604 "@math{@var{n}^0} is 1, as usual, and that\n"
4605 "includes @math{0^0} is 1.\n"
4608 "(integer-expt 2 5) @result{} 32\n"
4609 "(integer-expt -3 3) @result{} -27\n"
4610 "(integer-expt 5 -3) @result{} 1/125\n"
4611 "(integer-expt 0 0) @result{} 1\n"
4613 #define FUNC_NAME s_scm_integer_expt
4616 SCM z_i2
= SCM_BOOL_F
;
4618 SCM acc
= SCM_I_MAKINUM (1L);
4620 /* Specifically refrain from checking the type of the first argument.
4621 This allows us to exponentiate any object that can be multiplied.
4622 If we must raise to a negative power, we must also be able to
4623 take its reciprocal. */
4624 if (!SCM_LIKELY (SCM_I_INUMP (k
)) && !SCM_LIKELY (SCM_BIGP (k
)))
4625 SCM_WRONG_TYPE_ARG (2, k
);
4627 if (SCM_UNLIKELY (scm_is_eq (k
, SCM_INUM0
)))
4628 return SCM_INUM1
; /* n^(exact0) is exact 1, regardless of n */
4629 else if (SCM_UNLIKELY (scm_is_eq (n
, SCM_I_MAKINUM (-1L))))
4630 return scm_is_false (scm_even_p (k
)) ? n
: SCM_INUM1
;
4631 /* The next check is necessary only because R6RS specifies different
4632 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4633 we simply skip this case and move on. */
4634 else if (SCM_NUMBERP (n
) && scm_is_true (scm_zero_p (n
)))
4636 /* k cannot be 0 at this point, because we
4637 have already checked for that case above */
4638 if (scm_is_true (scm_positive_p (k
)))
4640 else /* return NaN for (0 ^ k) for negative k per R6RS */
4644 if (SCM_I_INUMP (k
))
4645 i2
= SCM_I_INUM (k
);
4646 else if (SCM_BIGP (k
))
4648 z_i2
= scm_i_clonebig (k
, 1);
4649 scm_remember_upto_here_1 (k
);
4653 SCM_WRONG_TYPE_ARG (2, k
);
4657 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
4659 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
4660 n
= scm_divide (n
, SCM_UNDEFINED
);
4664 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
4668 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
4670 return scm_product (acc
, n
);
4672 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
4673 acc
= scm_product (acc
, n
);
4674 n
= scm_product (n
, n
);
4675 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
4683 n
= scm_divide (n
, SCM_UNDEFINED
);
4690 return scm_product (acc
, n
);
4692 acc
= scm_product (acc
, n
);
4693 n
= scm_product (n
, n
);
4700 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
4702 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
4703 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
4705 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
4706 "@var{cnt} is negative it's a division, rounded towards negative\n"
4707 "infinity. (Note that this is not the same rounding as\n"
4708 "@code{quotient} does.)\n"
4710 "With @var{n} viewed as an infinite precision twos complement,\n"
4711 "@code{ash} means a left shift introducing zero bits, or a right\n"
4712 "shift dropping bits.\n"
4715 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
4716 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
4718 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
4719 "(ash -23 -2) @result{} -6\n"
4721 #define FUNC_NAME s_scm_ash
4724 bits_to_shift
= scm_to_long (cnt
);
4726 if (SCM_I_INUMP (n
))
4728 scm_t_inum nn
= SCM_I_INUM (n
);
4730 if (bits_to_shift
> 0)
4732 /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
4733 overflow a non-zero fixnum. For smaller shifts we check the
4734 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4735 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4736 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
4742 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
4744 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
4747 return SCM_I_MAKINUM (nn
<< bits_to_shift
);
4751 SCM result
= scm_i_inum2big (nn
);
4752 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4759 bits_to_shift
= -bits_to_shift
;
4760 if (bits_to_shift
>= SCM_LONG_BIT
)
4761 return (nn
>= 0 ? SCM_INUM0
: SCM_I_MAKINUM(-1));
4763 return SCM_I_MAKINUM (SCM_SRS (nn
, bits_to_shift
));
4767 else if (SCM_BIGP (n
))
4771 if (bits_to_shift
== 0)
4774 result
= scm_i_mkbig ();
4775 if (bits_to_shift
>= 0)
4777 mpz_mul_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4783 /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
4784 we have to allocate a bignum even if the result is going to be a
4786 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
),
4788 return scm_i_normbig (result
);
4794 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4800 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
4801 (SCM n
, SCM start
, SCM end
),
4802 "Return the integer composed of the @var{start} (inclusive)\n"
4803 "through @var{end} (exclusive) bits of @var{n}. The\n"
4804 "@var{start}th bit becomes the 0-th bit in the result.\n"
4807 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
4808 " @result{} \"1010\"\n"
4809 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
4810 " @result{} \"10110\"\n"
4812 #define FUNC_NAME s_scm_bit_extract
4814 unsigned long int istart
, iend
, bits
;
4815 istart
= scm_to_ulong (start
);
4816 iend
= scm_to_ulong (end
);
4817 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
4819 /* how many bits to keep */
4820 bits
= iend
- istart
;
4822 if (SCM_I_INUMP (n
))
4824 scm_t_inum in
= SCM_I_INUM (n
);
4826 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
4827 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
4828 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
4830 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
4832 /* Since we emulate two's complement encoded numbers, this
4833 * special case requires us to produce a result that has
4834 * more bits than can be stored in a fixnum.
4836 SCM result
= scm_i_inum2big (in
);
4837 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
4842 /* mask down to requisite bits */
4843 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
4844 return SCM_I_MAKINUM (in
& ((1L << bits
) - 1));
4846 else if (SCM_BIGP (n
))
4851 result
= SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
4855 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
4856 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
4857 such bits into a ulong. */
4858 result
= scm_i_mkbig ();
4859 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
4860 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
4861 result
= scm_i_normbig (result
);
4863 scm_remember_upto_here_1 (n
);
4867 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4872 static const char scm_logtab
[] = {
4873 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
4876 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
4878 "Return the number of bits in integer @var{n}. If integer is\n"
4879 "positive, the 1-bits in its binary representation are counted.\n"
4880 "If negative, the 0-bits in its two's-complement binary\n"
4881 "representation are counted. If 0, 0 is returned.\n"
4884 "(logcount #b10101010)\n"
4891 #define FUNC_NAME s_scm_logcount
4893 if (SCM_I_INUMP (n
))
4895 unsigned long c
= 0;
4896 scm_t_inum nn
= SCM_I_INUM (n
);
4901 c
+= scm_logtab
[15 & nn
];
4904 return SCM_I_MAKINUM (c
);
4906 else if (SCM_BIGP (n
))
4908 unsigned long count
;
4909 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
4910 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
4912 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
4913 scm_remember_upto_here_1 (n
);
4914 return SCM_I_MAKINUM (count
);
4917 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4922 static const char scm_ilentab
[] = {
4923 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
4927 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
4929 "Return the number of bits necessary to represent @var{n}.\n"
4932 "(integer-length #b10101010)\n"
4934 "(integer-length 0)\n"
4936 "(integer-length #b1111)\n"
4939 #define FUNC_NAME s_scm_integer_length
4941 if (SCM_I_INUMP (n
))
4943 unsigned long c
= 0;
4945 scm_t_inum nn
= SCM_I_INUM (n
);
4951 l
= scm_ilentab
[15 & nn
];
4954 return SCM_I_MAKINUM (c
- 4 + l
);
4956 else if (SCM_BIGP (n
))
4958 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
4959 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
4960 1 too big, so check for that and adjust. */
4961 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
4962 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
4963 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
4964 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
4966 scm_remember_upto_here_1 (n
);
4967 return SCM_I_MAKINUM (size
);
4970 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
4974 /*** NUMBERS -> STRINGS ***/
4975 #define SCM_MAX_DBL_PREC 60
4976 #define SCM_MAX_DBL_RADIX 36
4978 /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
4979 static int scm_dblprec
[SCM_MAX_DBL_RADIX
- 1];
4980 static double fx_per_radix
[SCM_MAX_DBL_RADIX
- 1][SCM_MAX_DBL_PREC
];
4983 void init_dblprec(int *prec
, int radix
) {
4984 /* determine floating point precision by adding successively
4985 smaller increments to 1.0 until it is considered == 1.0 */
4986 double f
= ((double)1.0)/radix
;
4987 double fsum
= 1.0 + f
;
4992 if (++(*prec
) > SCM_MAX_DBL_PREC
)
5004 void init_fx_radix(double *fx_list
, int radix
)
5006 /* initialize a per-radix list of tolerances. When added
5007 to a number < 1.0, we can determine if we should raund
5008 up and quit converting a number to a string. */
5012 for( i
= 2 ; i
< SCM_MAX_DBL_PREC
; ++i
)
5013 fx_list
[i
] = (fx_list
[i
-1] / radix
);
5016 /* use this array as a way to generate a single digit */
5017 static const char number_chars
[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5020 idbl2str (double f
, char *a
, int radix
)
5022 int efmt
, dpt
, d
, i
, wp
;
5024 #ifdef DBL_MIN_10_EXP
5027 #endif /* DBL_MIN_10_EXP */
5032 radix
> SCM_MAX_DBL_RADIX
)
5034 /* revert to existing behavior */
5038 wp
= scm_dblprec
[radix
-2];
5039 fx
= fx_per_radix
[radix
-2];
5043 #ifdef HAVE_COPYSIGN
5044 double sgn
= copysign (1.0, f
);
5049 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
5055 strcpy (a
, "-inf.0");
5057 strcpy (a
, "+inf.0");
5062 strcpy (a
, "+nan.0");
5072 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
5073 make-uniform-vector, from causing infinite loops. */
5074 /* just do the checking...if it passes, we do the conversion for our
5075 radix again below */
5082 if (exp_cpy
-- < DBL_MIN_10_EXP
)
5090 while (f_cpy
> 10.0)
5093 if (exp_cpy
++ > DBL_MAX_10_EXP
)
5114 if (f
+ fx
[wp
] >= radix
)
5120 efmt
= (exp
< -3) || (exp
> wp
+ 2);
5141 a
[ch
++] = number_chars
[d
];
5144 if (f
+ fx
[wp
] >= 1.0)
5146 a
[ch
- 1] = number_chars
[d
+1];
5157 if ((dpt
> 4) && (exp
> 6))
5159 d
= (a
[0] == '-' ? 2 : 1);
5160 for (i
= ch
++; i
> d
; i
--)
5172 if (a
[ch
- 1] == '.')
5173 a
[ch
++] = '0'; /* trailing zero */
5182 for (i
= radix
; i
<= exp
; i
*= radix
);
5183 for (i
/= radix
; i
; i
/= radix
)
5185 a
[ch
++] = number_chars
[exp
/ i
];
5194 icmplx2str (double real
, double imag
, char *str
, int radix
)
5199 i
= idbl2str (real
, str
, radix
);
5200 #ifdef HAVE_COPYSIGN
5201 sgn
= copysign (1.0, imag
);
5205 /* Don't output a '+' for negative numbers or for Inf and
5206 NaN. They will provide their own sign. */
5207 if (sgn
>= 0 && DOUBLE_IS_FINITE (imag
))
5209 i
+= idbl2str (imag
, &str
[i
], radix
);
5215 iflo2str (SCM flt
, char *str
, int radix
)
5218 if (SCM_REALP (flt
))
5219 i
= idbl2str (SCM_REAL_VALUE (flt
), str
, radix
);
5221 i
= icmplx2str (SCM_COMPLEX_REAL (flt
), SCM_COMPLEX_IMAG (flt
),
5226 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5227 characters in the result.
5229 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5231 scm_iint2str (scm_t_intmax num
, int rad
, char *p
)
5236 return scm_iuint2str (-num
, rad
, p
) + 1;
5239 return scm_iuint2str (num
, rad
, p
);
5242 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5243 characters in the result.
5245 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5247 scm_iuint2str (scm_t_uintmax num
, int rad
, char *p
)
5251 scm_t_uintmax n
= num
;
5253 if (rad
< 2 || rad
> 36)
5254 scm_out_of_range ("scm_iuint2str", scm_from_int (rad
));
5256 for (n
/= rad
; n
> 0; n
/= rad
)
5266 p
[i
] = number_chars
[d
];
5271 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
5273 "Return a string holding the external representation of the\n"
5274 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5275 "inexact, a radix of 10 will be used.")
5276 #define FUNC_NAME s_scm_number_to_string
5280 if (SCM_UNBNDP (radix
))
5283 base
= scm_to_signed_integer (radix
, 2, 36);
5285 if (SCM_I_INUMP (n
))
5287 char num_buf
[SCM_INTBUFLEN
];
5288 size_t length
= scm_iint2str (SCM_I_INUM (n
), base
, num_buf
);
5289 return scm_from_locale_stringn (num_buf
, length
);
5291 else if (SCM_BIGP (n
))
5293 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
5294 scm_remember_upto_here_1 (n
);
5295 return scm_take_locale_string (str
);
5297 else if (SCM_FRACTIONP (n
))
5299 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
5300 scm_from_locale_string ("/"),
5301 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
5303 else if (SCM_INEXACTP (n
))
5305 char num_buf
[FLOBUFLEN
];
5306 return scm_from_locale_stringn (num_buf
, iflo2str (n
, num_buf
, base
));
5309 SCM_WRONG_TYPE_ARG (1, n
);
5314 /* These print routines used to be stubbed here so that scm_repl.c
5315 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5318 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5320 char num_buf
[FLOBUFLEN
];
5321 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5326 scm_i_print_double (double val
, SCM port
)
5328 char num_buf
[FLOBUFLEN
];
5329 scm_lfwrite_unlocked (num_buf
, idbl2str (val
, num_buf
, 10), port
);
5333 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5336 char num_buf
[FLOBUFLEN
];
5337 scm_lfwrite_unlocked (num_buf
, iflo2str (sexp
, num_buf
, 10), port
);
5342 scm_i_print_complex (double real
, double imag
, SCM port
)
5344 char num_buf
[FLOBUFLEN
];
5345 scm_lfwrite_unlocked (num_buf
, icmplx2str (real
, imag
, num_buf
, 10), port
);
5349 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5352 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
5353 scm_display (str
, port
);
5354 scm_remember_upto_here_1 (str
);
5359 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
5361 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
5362 scm_remember_upto_here_1 (exp
);
5363 scm_lfwrite_unlocked (str
, (size_t) strlen (str
), port
);
5367 /*** END nums->strs ***/
5370 /*** STRINGS -> NUMBERS ***/
5372 /* The following functions implement the conversion from strings to numbers.
5373 * The implementation somehow follows the grammar for numbers as it is given
5374 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5375 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5376 * points should be noted about the implementation:
5378 * * Each function keeps a local index variable 'idx' that points at the
5379 * current position within the parsed string. The global index is only
5380 * updated if the function could parse the corresponding syntactic unit
5383 * * Similarly, the functions keep track of indicators of inexactness ('#',
5384 * '.' or exponents) using local variables ('hash_seen', 'x').
5386 * * Sequences of digits are parsed into temporary variables holding fixnums.
5387 * Only if these fixnums would overflow, the result variables are updated
5388 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5389 * the temporary variables holding the fixnums are cleared, and the process
5390 * starts over again. If for example fixnums were able to store five decimal
5391 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5392 * and the result was computed as 12345 * 100000 + 67890. In other words,
5393 * only every five digits two bignum operations were performed.
5395 * Notes on the handling of exactness specifiers:
5397 * When parsing non-real complex numbers, we apply exactness specifiers on
5398 * per-component basis, as is done in PLT Scheme. For complex numbers
5399 * written in rectangular form, exactness specifiers are applied to the
5400 * real and imaginary parts before calling scm_make_rectangular. For
5401 * complex numbers written in polar form, exactness specifiers are applied
5402 * to the magnitude and angle before calling scm_make_polar.
5404 * There are two kinds of exactness specifiers: forced and implicit. A
5405 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5406 * the entire number, and applies to both components of a complex number.
5407 * "#e" causes each component to be made exact, and "#i" causes each
5408 * component to be made inexact. If no forced exactness specifier is
5409 * present, then the exactness of each component is determined
5410 * independently by the presence or absence of a decimal point or hash mark
5411 * within that component. If a decimal point or hash mark is present, the
5412 * component is made inexact, otherwise it is made exact.
5414 * After the exactness specifiers have been applied to each component, they
5415 * are passed to either scm_make_rectangular or scm_make_polar to produce
5416 * the final result. Note that this will result in a real number if the
5417 * imaginary part, magnitude, or angle is an exact 0.
5419 * For example, (string->number "#i5.0+0i") does the equivalent of:
5421 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5424 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
5426 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5428 /* Caller is responsible for checking that the return value is in range
5429 for the given radix, which should be <= 36. */
5431 char_decimal_value (scm_t_uint32 c
)
5433 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5434 that's certainly above any valid decimal, so we take advantage of
5435 that to elide some tests. */
5436 unsigned int d
= (unsigned int) uc_decimal_value (c
);
5438 /* If that failed, try extended hexadecimals, then. Only accept ascii
5443 if (c
>= (scm_t_uint32
) 'a')
5444 d
= c
- (scm_t_uint32
)'a' + 10U;
5449 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5450 in base RADIX. Upon success, return the unsigned integer and update
5451 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5453 mem2uinteger (SCM mem
, unsigned int *p_idx
,
5454 unsigned int radix
, enum t_exactness
*p_exactness
)
5456 unsigned int idx
= *p_idx
;
5457 unsigned int hash_seen
= 0;
5458 scm_t_bits shift
= 1;
5460 unsigned int digit_value
;
5463 size_t len
= scm_i_string_length (mem
);
5468 c
= scm_i_string_ref (mem
, idx
);
5469 digit_value
= char_decimal_value (c
);
5470 if (digit_value
>= radix
)
5474 result
= SCM_I_MAKINUM (digit_value
);
5477 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5487 digit_value
= char_decimal_value (c
);
5488 /* This check catches non-decimals in addition to out-of-range
5490 if (digit_value
>= radix
)
5495 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
5497 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5499 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5506 shift
= shift
* radix
;
5507 add
= add
* radix
+ digit_value
;
5512 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5514 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5518 *p_exactness
= INEXACT
;
5524 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5525 * covers the parts of the rules that start at a potential point. The value
5526 * of the digits up to the point have been parsed by the caller and are given
5527 * in variable result. The content of *p_exactness indicates, whether a hash
5528 * has already been seen in the digits before the point.
5531 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5534 mem2decimal_from_point (SCM result
, SCM mem
,
5535 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
5537 unsigned int idx
= *p_idx
;
5538 enum t_exactness x
= *p_exactness
;
5539 size_t len
= scm_i_string_length (mem
);
5544 if (scm_i_string_ref (mem
, idx
) == '.')
5546 scm_t_bits shift
= 1;
5548 unsigned int digit_value
;
5549 SCM big_shift
= SCM_INUM1
;
5554 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5555 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5560 digit_value
= DIGIT2UINT (c
);
5571 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
5573 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5574 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5576 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5584 add
= add
* 10 + digit_value
;
5590 big_shift
= scm_product (big_shift
, SCM_I_MAKINUM (shift
));
5591 result
= scm_product (result
, SCM_I_MAKINUM (shift
));
5592 result
= scm_sum (result
, SCM_I_MAKINUM (add
));
5595 result
= scm_divide (result
, big_shift
);
5597 /* We've seen a decimal point, thus the value is implicitly inexact. */
5609 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
5611 switch (scm_i_string_ref (mem
, idx
))
5623 c
= scm_i_string_ref (mem
, idx
);
5631 c
= scm_i_string_ref (mem
, idx
);
5640 c
= scm_i_string_ref (mem
, idx
);
5645 if (!uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5649 exponent
= DIGIT2UINT (c
);
5652 scm_t_wchar c
= scm_i_string_ref (mem
, idx
);
5653 if (uc_is_property_decimal_digit ((scm_t_uint32
) c
))
5656 if (exponent
<= SCM_MAXEXP
)
5657 exponent
= exponent
* 10 + DIGIT2UINT (c
);
5663 if (exponent
> SCM_MAXEXP
)
5665 size_t exp_len
= idx
- start
;
5666 SCM exp_string
= scm_i_substring_copy (mem
, start
, start
+ exp_len
);
5667 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
5668 scm_out_of_range ("string->number", exp_num
);
5671 e
= scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent
));
5673 result
= scm_product (result
, e
);
5675 result
= scm_divide (result
, e
);
5677 /* We've seen an exponent, thus the value is implicitly inexact. */
5695 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
5698 mem2ureal (SCM mem
, unsigned int *p_idx
,
5699 unsigned int radix
, enum t_exactness forced_x
)
5701 unsigned int idx
= *p_idx
;
5703 size_t len
= scm_i_string_length (mem
);
5705 /* Start off believing that the number will be exact. This changes
5706 to INEXACT if we see a decimal point or a hash. */
5707 enum t_exactness implicit_x
= EXACT
;
5712 if (idx
+5 <= len
&& !scm_i_string_strcmp (mem
, idx
, "inf.0"))
5718 if (idx
+4 < len
&& !scm_i_string_strcmp (mem
, idx
, "nan."))
5720 /* Cobble up the fractional part. We might want to set the
5721 NaN's mantissa from it. */
5723 if (!scm_is_eq (mem2uinteger (mem
, &idx
, 10, &implicit_x
), SCM_INUM0
))
5725 #if SCM_ENABLE_DEPRECATED == 1
5726 scm_c_issue_deprecation_warning
5727 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
5737 if (scm_i_string_ref (mem
, idx
) == '.')
5741 else if (idx
+ 1 == len
)
5743 else if (!uc_is_property_decimal_digit ((scm_t_uint32
) scm_i_string_ref (mem
, idx
+1)))
5746 result
= mem2decimal_from_point (SCM_INUM0
, mem
,
5747 p_idx
, &implicit_x
);
5753 uinteger
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5754 if (scm_is_false (uinteger
))
5759 else if (scm_i_string_ref (mem
, idx
) == '/')
5767 divisor
= mem2uinteger (mem
, &idx
, radix
, &implicit_x
);
5768 if (scm_is_false (divisor
))
5771 /* both are int/big here, I assume */
5772 result
= scm_i_make_ratio (uinteger
, divisor
);
5774 else if (radix
== 10)
5776 result
= mem2decimal_from_point (uinteger
, mem
, &idx
, &implicit_x
);
5777 if (scm_is_false (result
))
5789 if (SCM_INEXACTP (result
))
5790 return scm_inexact_to_exact (result
);
5794 if (SCM_INEXACTP (result
))
5797 return scm_exact_to_inexact (result
);
5799 if (implicit_x
== INEXACT
)
5801 if (SCM_INEXACTP (result
))
5804 return scm_exact_to_inexact (result
);
5810 /* We should never get here */
5811 scm_syserror ("mem2ureal");
5815 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
5818 mem2complex (SCM mem
, unsigned int idx
,
5819 unsigned int radix
, enum t_exactness forced_x
)
5824 size_t len
= scm_i_string_length (mem
);
5829 c
= scm_i_string_ref (mem
, idx
);
5844 ureal
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5845 if (scm_is_false (ureal
))
5847 /* input must be either +i or -i */
5852 if (scm_i_string_ref (mem
, idx
) == 'i'
5853 || scm_i_string_ref (mem
, idx
) == 'I')
5859 return scm_make_rectangular (SCM_INUM0
, SCM_I_MAKINUM (sign
));
5866 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5867 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
5872 c
= scm_i_string_ref (mem
, idx
);
5876 /* either +<ureal>i or -<ureal>i */
5883 return scm_make_rectangular (SCM_INUM0
, ureal
);
5886 /* polar input: <real>@<real>. */
5897 c
= scm_i_string_ref (mem
, idx
);
5915 angle
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5916 if (scm_is_false (angle
))
5921 if (sign
== -1 && scm_is_false (scm_nan_p (ureal
)))
5922 angle
= scm_difference (angle
, SCM_UNDEFINED
);
5924 result
= scm_make_polar (ureal
, angle
);
5929 /* expecting input matching <real>[+-]<ureal>?i */
5936 int sign
= (c
== '+') ? 1 : -1;
5937 SCM imag
= mem2ureal (mem
, &idx
, radix
, forced_x
);
5939 if (scm_is_false (imag
))
5940 imag
= SCM_I_MAKINUM (sign
);
5941 else if (sign
== -1 && scm_is_false (scm_nan_p (imag
)))
5942 imag
= scm_difference (imag
, SCM_UNDEFINED
);
5946 if (scm_i_string_ref (mem
, idx
) != 'i'
5947 && scm_i_string_ref (mem
, idx
) != 'I')
5954 return scm_make_rectangular (ureal
, imag
);
5963 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
5965 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
5968 scm_i_string_to_number (SCM mem
, unsigned int default_radix
)
5970 unsigned int idx
= 0;
5971 unsigned int radix
= NO_RADIX
;
5972 enum t_exactness forced_x
= NO_EXACTNESS
;
5973 size_t len
= scm_i_string_length (mem
);
5975 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
5976 while (idx
+ 2 < len
&& scm_i_string_ref (mem
, idx
) == '#')
5978 switch (scm_i_string_ref (mem
, idx
+ 1))
5981 if (radix
!= NO_RADIX
)
5986 if (radix
!= NO_RADIX
)
5991 if (forced_x
!= NO_EXACTNESS
)
5996 if (forced_x
!= NO_EXACTNESS
)
6001 if (radix
!= NO_RADIX
)
6006 if (radix
!= NO_RADIX
)
6016 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6017 if (radix
== NO_RADIX
)
6018 radix
= default_radix
;
6020 return mem2complex (mem
, idx
, radix
, forced_x
);
6024 scm_c_locale_stringn_to_number (const char* mem
, size_t len
,
6025 unsigned int default_radix
)
6027 SCM str
= scm_from_locale_stringn (mem
, len
);
6029 return scm_i_string_to_number (str
, default_radix
);
6033 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
6034 (SCM string
, SCM radix
),
6035 "Return a number of the maximally precise representation\n"
6036 "expressed by the given @var{string}. @var{radix} must be an\n"
6037 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6038 "is a default radix that may be overridden by an explicit radix\n"
6039 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6040 "supplied, then the default radix is 10. If string is not a\n"
6041 "syntactically valid notation for a number, then\n"
6042 "@code{string->number} returns @code{#f}.")
6043 #define FUNC_NAME s_scm_string_to_number
6047 SCM_VALIDATE_STRING (1, string
);
6049 if (SCM_UNBNDP (radix
))
6052 base
= scm_to_unsigned_integer (radix
, 2, INT_MAX
);
6054 answer
= scm_i_string_to_number (string
, base
);
6055 scm_remember_upto_here_1 (string
);
6061 /*** END strs->nums ***/
6064 SCM_DEFINE (scm_number_p
, "number?", 1, 0, 0,
6066 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6068 #define FUNC_NAME s_scm_number_p
6070 return scm_from_bool (SCM_NUMBERP (x
));
6074 SCM_DEFINE (scm_complex_p
, "complex?", 1, 0, 0,
6076 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6077 "otherwise. Note that the sets of real, rational and integer\n"
6078 "values form subsets of the set of complex numbers, i. e. the\n"
6079 "predicate will also be fulfilled if @var{x} is a real,\n"
6080 "rational or integer number.")
6081 #define FUNC_NAME s_scm_complex_p
6083 /* all numbers are complex. */
6084 return scm_number_p (x
);
6088 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
6090 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6091 "otherwise. Note that the set of integer values forms a subset of\n"
6092 "the set of real numbers, i. e. the predicate will also be\n"
6093 "fulfilled if @var{x} is an integer number.")
6094 #define FUNC_NAME s_scm_real_p
6096 return scm_from_bool
6097 (SCM_I_INUMP (x
) || SCM_REALP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
));
6101 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
6103 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6104 "otherwise. Note that the set of integer values forms a subset of\n"
6105 "the set of rational numbers, i. e. the predicate will also be\n"
6106 "fulfilled if @var{x} is an integer number.")
6107 #define FUNC_NAME s_scm_rational_p
6109 if (SCM_I_INUMP (x
) || SCM_BIGP (x
) || SCM_FRACTIONP (x
))
6111 else if (SCM_REALP (x
))
6112 /* due to their limited precision, finite floating point numbers are
6113 rational as well. (finite means neither infinity nor a NaN) */
6114 return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x
)));
6120 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
6122 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
6124 #define FUNC_NAME s_scm_integer_p
6126 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
6128 else if (SCM_REALP (x
))
6130 double val
= SCM_REAL_VALUE (x
);
6131 return scm_from_bool (!isinf (val
) && (val
== floor (val
)));
6139 SCM
scm_i_num_eq_p (SCM
, SCM
, SCM
);
6140 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p
, "=", 0, 2, 1,
6141 (SCM x
, SCM y
, SCM rest
),
6142 "Return @code{#t} if all parameters are numerically equal.")
6143 #define FUNC_NAME s_scm_i_num_eq_p
6145 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6147 while (!scm_is_null (rest
))
6149 if (scm_is_false (scm_num_eq_p (x
, y
)))
6153 rest
= scm_cdr (rest
);
6155 return scm_num_eq_p (x
, y
);
6159 scm_num_eq_p (SCM x
, SCM y
)
6162 if (SCM_I_INUMP (x
))
6164 scm_t_signed_bits xx
= SCM_I_INUM (x
);
6165 if (SCM_I_INUMP (y
))
6167 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6168 return scm_from_bool (xx
== yy
);
6170 else if (SCM_BIGP (y
))
6172 else if (SCM_REALP (y
))
6174 /* On a 32-bit system an inum fits a double, we can cast the inum
6175 to a double and compare.
6177 But on a 64-bit system an inum is bigger than a double and
6178 casting it to a double (call that dxx) will round. dxx is at
6179 worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
6180 an integer and fits a long. So we cast yy to a long and
6181 compare with plain xx.
6183 An alternative (for any size system actually) would be to check
6184 yy is an integer (with floor) and is in range of an inum
6185 (compare against appropriate powers of 2) then test
6186 xx==(scm_t_signed_bits)yy. It's just a matter of which
6187 casts/comparisons might be fastest or easiest for the cpu. */
6189 double yy
= SCM_REAL_VALUE (y
);
6190 return scm_from_bool ((double) xx
== yy
6191 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6192 || xx
== (scm_t_signed_bits
) yy
));
6194 else if (SCM_COMPLEXP (y
))
6195 return scm_from_bool (((double) xx
== SCM_COMPLEX_REAL (y
))
6196 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6197 else if (SCM_FRACTIONP (y
))
6200 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6203 else if (SCM_BIGP (x
))
6205 if (SCM_I_INUMP (y
))
6207 else if (SCM_BIGP (y
))
6209 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6210 scm_remember_upto_here_2 (x
, y
);
6211 return scm_from_bool (0 == cmp
);
6213 else if (SCM_REALP (y
))
6216 if (isnan (SCM_REAL_VALUE (y
)))
6218 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6219 scm_remember_upto_here_1 (x
);
6220 return scm_from_bool (0 == cmp
);
6222 else if (SCM_COMPLEXP (y
))
6225 if (0.0 != SCM_COMPLEX_IMAG (y
))
6227 if (isnan (SCM_COMPLEX_REAL (y
)))
6229 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
6230 scm_remember_upto_here_1 (x
);
6231 return scm_from_bool (0 == cmp
);
6233 else if (SCM_FRACTIONP (y
))
6236 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6239 else if (SCM_REALP (x
))
6241 double xx
= SCM_REAL_VALUE (x
);
6242 if (SCM_I_INUMP (y
))
6244 /* see comments with inum/real above */
6245 scm_t_signed_bits yy
= SCM_I_INUM (y
);
6246 return scm_from_bool (xx
== (double) yy
6247 && (DBL_MANT_DIG
>= SCM_I_FIXNUM_BIT
-1
6248 || (scm_t_signed_bits
) xx
== yy
));
6250 else if (SCM_BIGP (y
))
6253 if (isnan (SCM_REAL_VALUE (x
)))
6255 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6256 scm_remember_upto_here_1 (y
);
6257 return scm_from_bool (0 == cmp
);
6259 else if (SCM_REALP (y
))
6260 return scm_from_bool (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
6261 else if (SCM_COMPLEXP (y
))
6262 return scm_from_bool ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
6263 && (0.0 == SCM_COMPLEX_IMAG (y
)));
6264 else if (SCM_FRACTIONP (y
))
6266 double xx
= SCM_REAL_VALUE (x
);
6270 return scm_from_bool (xx
< 0.0);
6271 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6275 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6278 else if (SCM_COMPLEXP (x
))
6280 if (SCM_I_INUMP (y
))
6281 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == (double) SCM_I_INUM (y
))
6282 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6283 else if (SCM_BIGP (y
))
6286 if (0.0 != SCM_COMPLEX_IMAG (x
))
6288 if (isnan (SCM_COMPLEX_REAL (x
)))
6290 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
6291 scm_remember_upto_here_1 (y
);
6292 return scm_from_bool (0 == cmp
);
6294 else if (SCM_REALP (y
))
6295 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
6296 && (SCM_COMPLEX_IMAG (x
) == 0.0));
6297 else if (SCM_COMPLEXP (y
))
6298 return scm_from_bool ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
6299 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
6300 else if (SCM_FRACTIONP (y
))
6303 if (SCM_COMPLEX_IMAG (x
) != 0.0)
6305 xx
= SCM_COMPLEX_REAL (x
);
6309 return scm_from_bool (xx
< 0.0);
6310 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6314 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6317 else if (SCM_FRACTIONP (x
))
6319 if (SCM_I_INUMP (y
))
6321 else if (SCM_BIGP (y
))
6323 else if (SCM_REALP (y
))
6325 double yy
= SCM_REAL_VALUE (y
);
6329 return scm_from_bool (0.0 < yy
);
6330 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6333 else if (SCM_COMPLEXP (y
))
6336 if (SCM_COMPLEX_IMAG (y
) != 0.0)
6338 yy
= SCM_COMPLEX_REAL (y
);
6342 return scm_from_bool (0.0 < yy
);
6343 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6346 else if (SCM_FRACTIONP (y
))
6347 return scm_i_fraction_equalp (x
, y
);
6349 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARGn
,
6353 return scm_wta_dispatch_2 (g_scm_i_num_eq_p
, x
, y
, SCM_ARG1
,
6358 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6359 done are good for inums, but for bignums an answer can almost always be
6360 had by just examining a few high bits of the operands, as done by GMP in
6361 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6362 of the float exponent to take into account. */
6364 SCM_INTERNAL SCM
scm_i_num_less_p (SCM
, SCM
, SCM
);
6365 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p
, "<", 0, 2, 1,
6366 (SCM x
, SCM y
, SCM rest
),
6367 "Return @code{#t} if the list of parameters is monotonically\n"
6369 #define FUNC_NAME s_scm_i_num_less_p
6371 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6373 while (!scm_is_null (rest
))
6375 if (scm_is_false (scm_less_p (x
, y
)))
6379 rest
= scm_cdr (rest
);
6381 return scm_less_p (x
, y
);
6385 scm_less_p (SCM x
, SCM y
)
6388 if (SCM_I_INUMP (x
))
6390 scm_t_inum xx
= SCM_I_INUM (x
);
6391 if (SCM_I_INUMP (y
))
6393 scm_t_inum yy
= SCM_I_INUM (y
);
6394 return scm_from_bool (xx
< yy
);
6396 else if (SCM_BIGP (y
))
6398 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6399 scm_remember_upto_here_1 (y
);
6400 return scm_from_bool (sgn
> 0);
6402 else if (SCM_REALP (y
))
6403 return scm_from_bool ((double) xx
< SCM_REAL_VALUE (y
));
6404 else if (SCM_FRACTIONP (y
))
6406 /* "x < a/b" becomes "x*b < a" */
6408 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
6409 y
= SCM_FRACTION_NUMERATOR (y
);
6413 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6414 s_scm_i_num_less_p
);
6416 else if (SCM_BIGP (x
))
6418 if (SCM_I_INUMP (y
))
6420 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6421 scm_remember_upto_here_1 (x
);
6422 return scm_from_bool (sgn
< 0);
6424 else if (SCM_BIGP (y
))
6426 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6427 scm_remember_upto_here_2 (x
, y
);
6428 return scm_from_bool (cmp
< 0);
6430 else if (SCM_REALP (y
))
6433 if (isnan (SCM_REAL_VALUE (y
)))
6435 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
6436 scm_remember_upto_here_1 (x
);
6437 return scm_from_bool (cmp
< 0);
6439 else if (SCM_FRACTIONP (y
))
6442 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6443 s_scm_i_num_less_p
);
6445 else if (SCM_REALP (x
))
6447 if (SCM_I_INUMP (y
))
6448 return scm_from_bool (SCM_REAL_VALUE (x
) < (double) SCM_I_INUM (y
));
6449 else if (SCM_BIGP (y
))
6452 if (isnan (SCM_REAL_VALUE (x
)))
6454 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
6455 scm_remember_upto_here_1 (y
);
6456 return scm_from_bool (cmp
> 0);
6458 else if (SCM_REALP (y
))
6459 return scm_from_bool (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
6460 else if (SCM_FRACTIONP (y
))
6462 double xx
= SCM_REAL_VALUE (x
);
6466 return scm_from_bool (xx
< 0.0);
6467 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
6471 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6472 s_scm_i_num_less_p
);
6474 else if (SCM_FRACTIONP (x
))
6476 if (SCM_I_INUMP (y
) || SCM_BIGP (y
))
6478 /* "a/b < y" becomes "a < y*b" */
6479 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
6480 x
= SCM_FRACTION_NUMERATOR (x
);
6483 else if (SCM_REALP (y
))
6485 double yy
= SCM_REAL_VALUE (y
);
6489 return scm_from_bool (0.0 < yy
);
6490 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
6493 else if (SCM_FRACTIONP (y
))
6495 /* "a/b < c/d" becomes "a*d < c*b" */
6496 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
6497 SCM_FRACTION_DENOMINATOR (y
));
6498 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
6499 SCM_FRACTION_DENOMINATOR (x
));
6505 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARGn
,
6506 s_scm_i_num_less_p
);
6509 return scm_wta_dispatch_2 (g_scm_i_num_less_p
, x
, y
, SCM_ARG1
,
6510 s_scm_i_num_less_p
);
6514 SCM
scm_i_num_gr_p (SCM
, SCM
, SCM
);
6515 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p
, ">", 0, 2, 1,
6516 (SCM x
, SCM y
, SCM rest
),
6517 "Return @code{#t} if the list of parameters is monotonically\n"
6519 #define FUNC_NAME s_scm_i_num_gr_p
6521 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6523 while (!scm_is_null (rest
))
6525 if (scm_is_false (scm_gr_p (x
, y
)))
6529 rest
= scm_cdr (rest
);
6531 return scm_gr_p (x
, y
);
6534 #define FUNC_NAME s_scm_i_num_gr_p
6536 scm_gr_p (SCM x
, SCM y
)
6538 if (!SCM_NUMBERP (x
))
6539 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6540 else if (!SCM_NUMBERP (y
))
6541 return scm_wta_dispatch_2 (g_scm_i_num_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6543 return scm_less_p (y
, x
);
6548 SCM
scm_i_num_leq_p (SCM
, SCM
, SCM
);
6549 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p
, "<=", 0, 2, 1,
6550 (SCM x
, SCM y
, SCM rest
),
6551 "Return @code{#t} if the list of parameters is monotonically\n"
6553 #define FUNC_NAME s_scm_i_num_leq_p
6555 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6557 while (!scm_is_null (rest
))
6559 if (scm_is_false (scm_leq_p (x
, y
)))
6563 rest
= scm_cdr (rest
);
6565 return scm_leq_p (x
, y
);
6568 #define FUNC_NAME s_scm_i_num_leq_p
6570 scm_leq_p (SCM x
, SCM y
)
6572 if (!SCM_NUMBERP (x
))
6573 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6574 else if (!SCM_NUMBERP (y
))
6575 return scm_wta_dispatch_2 (g_scm_i_num_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6576 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6579 return scm_not (scm_less_p (y
, x
));
6584 SCM
scm_i_num_geq_p (SCM
, SCM
, SCM
);
6585 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p
, ">=", 0, 2, 1,
6586 (SCM x
, SCM y
, SCM rest
),
6587 "Return @code{#t} if the list of parameters is monotonically\n"
6589 #define FUNC_NAME s_scm_i_num_geq_p
6591 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
6593 while (!scm_is_null (rest
))
6595 if (scm_is_false (scm_geq_p (x
, y
)))
6599 rest
= scm_cdr (rest
);
6601 return scm_geq_p (x
, y
);
6604 #define FUNC_NAME s_scm_i_num_geq_p
6606 scm_geq_p (SCM x
, SCM y
)
6608 if (!SCM_NUMBERP (x
))
6609 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
6610 else if (!SCM_NUMBERP (y
))
6611 return scm_wta_dispatch_2 (g_scm_i_num_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
6612 else if (scm_is_true (scm_nan_p (x
)) || scm_is_true (scm_nan_p (y
)))
6615 return scm_not (scm_less_p (x
, y
));
6620 SCM_PRIMITIVE_GENERIC (scm_zero_p
, "zero?", 1, 0, 0,
6622 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
6624 #define FUNC_NAME s_scm_zero_p
6626 if (SCM_I_INUMP (z
))
6627 return scm_from_bool (scm_is_eq (z
, SCM_INUM0
));
6628 else if (SCM_BIGP (z
))
6630 else if (SCM_REALP (z
))
6631 return scm_from_bool (SCM_REAL_VALUE (z
) == 0.0);
6632 else if (SCM_COMPLEXP (z
))
6633 return scm_from_bool (SCM_COMPLEX_REAL (z
) == 0.0
6634 && SCM_COMPLEX_IMAG (z
) == 0.0);
6635 else if (SCM_FRACTIONP (z
))
6638 return scm_wta_dispatch_1 (g_scm_zero_p
, z
, SCM_ARG1
, s_scm_zero_p
);
6643 SCM_PRIMITIVE_GENERIC (scm_positive_p
, "positive?", 1, 0, 0,
6645 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
6647 #define FUNC_NAME s_scm_positive_p
6649 if (SCM_I_INUMP (x
))
6650 return scm_from_bool (SCM_I_INUM (x
) > 0);
6651 else if (SCM_BIGP (x
))
6653 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6654 scm_remember_upto_here_1 (x
);
6655 return scm_from_bool (sgn
> 0);
6657 else if (SCM_REALP (x
))
6658 return scm_from_bool(SCM_REAL_VALUE (x
) > 0.0);
6659 else if (SCM_FRACTIONP (x
))
6660 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
6662 return scm_wta_dispatch_1 (g_scm_positive_p
, x
, SCM_ARG1
, s_scm_positive_p
);
6667 SCM_PRIMITIVE_GENERIC (scm_negative_p
, "negative?", 1, 0, 0,
6669 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
6671 #define FUNC_NAME s_scm_negative_p
6673 if (SCM_I_INUMP (x
))
6674 return scm_from_bool (SCM_I_INUM (x
) < 0);
6675 else if (SCM_BIGP (x
))
6677 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6678 scm_remember_upto_here_1 (x
);
6679 return scm_from_bool (sgn
< 0);
6681 else if (SCM_REALP (x
))
6682 return scm_from_bool(SCM_REAL_VALUE (x
) < 0.0);
6683 else if (SCM_FRACTIONP (x
))
6684 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
6686 return scm_wta_dispatch_1 (g_scm_negative_p
, x
, SCM_ARG1
, s_scm_negative_p
);
6691 /* scm_min and scm_max return an inexact when either argument is inexact, as
6692 required by r5rs. On that basis, for exact/inexact combinations the
6693 exact is converted to inexact to compare and possibly return. This is
6694 unlike scm_less_p above which takes some trouble to preserve all bits in
6695 its test, such trouble is not required for min and max. */
6697 SCM_PRIMITIVE_GENERIC (scm_i_max
, "max", 0, 2, 1,
6698 (SCM x
, SCM y
, SCM rest
),
6699 "Return the maximum of all parameter values.")
6700 #define FUNC_NAME s_scm_i_max
6702 while (!scm_is_null (rest
))
6703 { x
= scm_max (x
, y
);
6705 rest
= scm_cdr (rest
);
6707 return scm_max (x
, y
);
6711 #define s_max s_scm_i_max
6712 #define g_max g_scm_i_max
6715 scm_max (SCM x
, SCM y
)
6720 return scm_wta_dispatch_0 (g_max
, s_max
);
6721 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6724 return scm_wta_dispatch_1 (g_max
, x
, SCM_ARG1
, s_max
);
6727 if (SCM_I_INUMP (x
))
6729 scm_t_inum xx
= SCM_I_INUM (x
);
6730 if (SCM_I_INUMP (y
))
6732 scm_t_inum yy
= SCM_I_INUM (y
);
6733 return (xx
< yy
) ? y
: x
;
6735 else if (SCM_BIGP (y
))
6737 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6738 scm_remember_upto_here_1 (y
);
6739 return (sgn
< 0) ? x
: y
;
6741 else if (SCM_REALP (y
))
6744 double yyd
= SCM_REAL_VALUE (y
);
6747 return scm_from_double (xxd
);
6748 /* If y is a NaN, then "==" is false and we return the NaN */
6749 else if (SCM_LIKELY (!(xxd
== yyd
)))
6751 /* Handle signed zeroes properly */
6757 else if (SCM_FRACTIONP (y
))
6760 return (scm_is_false (scm_less_p (x
, y
)) ? x
: y
);
6763 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6765 else if (SCM_BIGP (x
))
6767 if (SCM_I_INUMP (y
))
6769 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6770 scm_remember_upto_here_1 (x
);
6771 return (sgn
< 0) ? y
: x
;
6773 else if (SCM_BIGP (y
))
6775 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6776 scm_remember_upto_here_2 (x
, y
);
6777 return (cmp
> 0) ? x
: y
;
6779 else if (SCM_REALP (y
))
6781 /* if y==NaN then xx>yy is false, so we return the NaN y */
6784 xx
= scm_i_big2dbl (x
);
6785 yy
= SCM_REAL_VALUE (y
);
6786 return (xx
> yy
? scm_from_double (xx
) : y
);
6788 else if (SCM_FRACTIONP (y
))
6793 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6795 else if (SCM_REALP (x
))
6797 if (SCM_I_INUMP (y
))
6799 scm_t_inum yy
= SCM_I_INUM (y
);
6800 double xxd
= SCM_REAL_VALUE (x
);
6804 return scm_from_double (yyd
);
6805 /* If x is a NaN, then "==" is false and we return the NaN */
6806 else if (SCM_LIKELY (!(xxd
== yyd
)))
6808 /* Handle signed zeroes properly */
6814 else if (SCM_BIGP (y
))
6819 else if (SCM_REALP (y
))
6821 double xx
= SCM_REAL_VALUE (x
);
6822 double yy
= SCM_REAL_VALUE (y
);
6824 /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
6827 else if (SCM_LIKELY (xx
< yy
))
6829 /* If neither (xx > yy) nor (xx < yy), then
6830 either they're equal or one is a NaN */
6831 else if (SCM_UNLIKELY (isnan (xx
)))
6832 return DOUBLE_IS_POSITIVE_INFINITY (yy
) ? y
: x
;
6833 else if (SCM_UNLIKELY (isnan (yy
)))
6834 return DOUBLE_IS_POSITIVE_INFINITY (xx
) ? x
: y
;
6835 /* xx == yy, but handle signed zeroes properly */
6836 else if (double_is_non_negative_zero (yy
))
6841 else if (SCM_FRACTIONP (y
))
6843 double yy
= scm_i_fraction2double (y
);
6844 double xx
= SCM_REAL_VALUE (x
);
6845 return (xx
< yy
) ? scm_from_double (yy
) : x
;
6848 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6850 else if (SCM_FRACTIONP (x
))
6852 if (SCM_I_INUMP (y
))
6856 else if (SCM_BIGP (y
))
6860 else if (SCM_REALP (y
))
6862 double xx
= scm_i_fraction2double (x
);
6863 /* if y==NaN then ">" is false, so we return the NaN y */
6864 return (xx
> SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
6866 else if (SCM_FRACTIONP (y
))
6871 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
6874 return scm_wta_dispatch_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
6878 SCM_PRIMITIVE_GENERIC (scm_i_min
, "min", 0, 2, 1,
6879 (SCM x
, SCM y
, SCM rest
),
6880 "Return the minimum of all parameter values.")
6881 #define FUNC_NAME s_scm_i_min
6883 while (!scm_is_null (rest
))
6884 { x
= scm_min (x
, y
);
6886 rest
= scm_cdr (rest
);
6888 return scm_min (x
, y
);
6892 #define s_min s_scm_i_min
6893 #define g_min g_scm_i_min
6896 scm_min (SCM x
, SCM y
)
6901 return scm_wta_dispatch_0 (g_min
, s_min
);
6902 else if (SCM_I_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
6905 return scm_wta_dispatch_1 (g_min
, x
, SCM_ARG1
, s_min
);
6908 if (SCM_I_INUMP (x
))
6910 scm_t_inum xx
= SCM_I_INUM (x
);
6911 if (SCM_I_INUMP (y
))
6913 scm_t_inum yy
= SCM_I_INUM (y
);
6914 return (xx
< yy
) ? x
: y
;
6916 else if (SCM_BIGP (y
))
6918 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
6919 scm_remember_upto_here_1 (y
);
6920 return (sgn
< 0) ? y
: x
;
6922 else if (SCM_REALP (y
))
6925 /* if y==NaN then "<" is false and we return NaN */
6926 return (z
< SCM_REAL_VALUE (y
)) ? scm_from_double (z
) : y
;
6928 else if (SCM_FRACTIONP (y
))
6931 return (scm_is_false (scm_less_p (x
, y
)) ? y
: x
);
6934 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6936 else if (SCM_BIGP (x
))
6938 if (SCM_I_INUMP (y
))
6940 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
6941 scm_remember_upto_here_1 (x
);
6942 return (sgn
< 0) ? x
: y
;
6944 else if (SCM_BIGP (y
))
6946 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
6947 scm_remember_upto_here_2 (x
, y
);
6948 return (cmp
> 0) ? y
: x
;
6950 else if (SCM_REALP (y
))
6952 /* if y==NaN then xx<yy is false, so we return the NaN y */
6955 xx
= scm_i_big2dbl (x
);
6956 yy
= SCM_REAL_VALUE (y
);
6957 return (xx
< yy
? scm_from_double (xx
) : y
);
6959 else if (SCM_FRACTIONP (y
))
6964 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
6966 else if (SCM_REALP (x
))
6968 if (SCM_I_INUMP (y
))
6970 double z
= SCM_I_INUM (y
);
6971 /* if x==NaN then "<" is false and we return NaN */
6972 return (z
< SCM_REAL_VALUE (x
)) ? scm_from_double (z
) : x
;
6974 else if (SCM_BIGP (y
))
6979 else if (SCM_REALP (y
))
6981 double xx
= SCM_REAL_VALUE (x
);
6982 double yy
= SCM_REAL_VALUE (y
);
6984 /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
6987 else if (SCM_LIKELY (xx
> yy
))
6989 /* If neither (xx < yy) nor (xx > yy), then
6990 either they're equal or one is a NaN */
6991 else if (SCM_UNLIKELY (isnan (xx
)))
6992 return DOUBLE_IS_NEGATIVE_INFINITY (yy
) ? y
: x
;
6993 else if (SCM_UNLIKELY (isnan (yy
)))
6994 return DOUBLE_IS_NEGATIVE_INFINITY (xx
) ? x
: y
;
6995 /* xx == yy, but handle signed zeroes properly */
6996 else if (double_is_non_negative_zero (xx
))
7001 else if (SCM_FRACTIONP (y
))
7003 double yy
= scm_i_fraction2double (y
);
7004 double xx
= SCM_REAL_VALUE (x
);
7005 return (yy
< xx
) ? scm_from_double (yy
) : x
;
7008 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7010 else if (SCM_FRACTIONP (x
))
7012 if (SCM_I_INUMP (y
))
7016 else if (SCM_BIGP (y
))
7020 else if (SCM_REALP (y
))
7022 double xx
= scm_i_fraction2double (x
);
7023 /* if y==NaN then "<" is false, so we return the NaN y */
7024 return (xx
< SCM_REAL_VALUE (y
)) ? scm_from_double (xx
) : y
;
7026 else if (SCM_FRACTIONP (y
))
7031 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
7034 return scm_wta_dispatch_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
7038 SCM_PRIMITIVE_GENERIC (scm_i_sum
, "+", 0, 2, 1,
7039 (SCM x
, SCM y
, SCM rest
),
7040 "Return the sum of all parameter values. Return 0 if called without\n"
7042 #define FUNC_NAME s_scm_i_sum
7044 while (!scm_is_null (rest
))
7045 { x
= scm_sum (x
, y
);
7047 rest
= scm_cdr (rest
);
7049 return scm_sum (x
, y
);
7053 #define s_sum s_scm_i_sum
7054 #define g_sum g_scm_i_sum
7057 scm_sum (SCM x
, SCM y
)
7059 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7061 if (SCM_NUMBERP (x
)) return x
;
7062 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
7063 return scm_wta_dispatch_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
7066 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7068 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7070 scm_t_inum xx
= SCM_I_INUM (x
);
7071 scm_t_inum yy
= SCM_I_INUM (y
);
7072 scm_t_inum z
= xx
+ yy
;
7073 return SCM_FIXABLE (z
) ? SCM_I_MAKINUM (z
) : scm_i_inum2big (z
);
7075 else if (SCM_BIGP (y
))
7080 else if (SCM_REALP (y
))
7082 scm_t_inum xx
= SCM_I_INUM (x
);
7083 return scm_from_double (xx
+ SCM_REAL_VALUE (y
));
7085 else if (SCM_COMPLEXP (y
))
7087 scm_t_inum xx
= SCM_I_INUM (x
);
7088 return scm_c_make_rectangular (xx
+ SCM_COMPLEX_REAL (y
),
7089 SCM_COMPLEX_IMAG (y
));
7091 else if (SCM_FRACTIONP (y
))
7092 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7093 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7094 SCM_FRACTION_DENOMINATOR (y
));
7096 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7097 } else if (SCM_BIGP (x
))
7099 if (SCM_I_INUMP (y
))
7104 inum
= SCM_I_INUM (y
);
7107 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7110 SCM result
= scm_i_mkbig ();
7111 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
7112 scm_remember_upto_here_1 (x
);
7113 /* we know the result will have to be a bignum */
7116 return scm_i_normbig (result
);
7120 SCM result
= scm_i_mkbig ();
7121 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
7122 scm_remember_upto_here_1 (x
);
7123 /* we know the result will have to be a bignum */
7126 return scm_i_normbig (result
);
7129 else if (SCM_BIGP (y
))
7131 SCM result
= scm_i_mkbig ();
7132 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7133 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7134 mpz_add (SCM_I_BIG_MPZ (result
),
7137 scm_remember_upto_here_2 (x
, y
);
7138 /* we know the result will have to be a bignum */
7141 return scm_i_normbig (result
);
7143 else if (SCM_REALP (y
))
7145 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
7146 scm_remember_upto_here_1 (x
);
7147 return scm_from_double (result
);
7149 else if (SCM_COMPLEXP (y
))
7151 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7152 + SCM_COMPLEX_REAL (y
));
7153 scm_remember_upto_here_1 (x
);
7154 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7156 else if (SCM_FRACTIONP (y
))
7157 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
7158 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
7159 SCM_FRACTION_DENOMINATOR (y
));
7161 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7163 else if (SCM_REALP (x
))
7165 if (SCM_I_INUMP (y
))
7166 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_I_INUM (y
));
7167 else if (SCM_BIGP (y
))
7169 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
7170 scm_remember_upto_here_1 (y
);
7171 return scm_from_double (result
);
7173 else if (SCM_REALP (y
))
7174 return scm_from_double (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
7175 else if (SCM_COMPLEXP (y
))
7176 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
7177 SCM_COMPLEX_IMAG (y
));
7178 else if (SCM_FRACTIONP (y
))
7179 return scm_from_double (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
7181 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7183 else if (SCM_COMPLEXP (x
))
7185 if (SCM_I_INUMP (y
))
7186 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_I_INUM (y
),
7187 SCM_COMPLEX_IMAG (x
));
7188 else if (SCM_BIGP (y
))
7190 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
7191 + SCM_COMPLEX_REAL (x
));
7192 scm_remember_upto_here_1 (y
);
7193 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (x
));
7195 else if (SCM_REALP (y
))
7196 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
7197 SCM_COMPLEX_IMAG (x
));
7198 else if (SCM_COMPLEXP (y
))
7199 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
7200 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
7201 else if (SCM_FRACTIONP (y
))
7202 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
7203 SCM_COMPLEX_IMAG (x
));
7205 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7207 else if (SCM_FRACTIONP (x
))
7209 if (SCM_I_INUMP (y
))
7210 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7211 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7212 SCM_FRACTION_DENOMINATOR (x
));
7213 else if (SCM_BIGP (y
))
7214 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
7215 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
7216 SCM_FRACTION_DENOMINATOR (x
));
7217 else if (SCM_REALP (y
))
7218 return scm_from_double (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
7219 else if (SCM_COMPLEXP (y
))
7220 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
7221 SCM_COMPLEX_IMAG (y
));
7222 else if (SCM_FRACTIONP (y
))
7223 /* a/b + c/d = (ad + bc) / bd */
7224 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7225 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7226 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7228 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
7231 return scm_wta_dispatch_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
7235 SCM_DEFINE (scm_oneplus
, "1+", 1, 0, 0,
7237 "Return @math{@var{x}+1}.")
7238 #define FUNC_NAME s_scm_oneplus
7240 return scm_sum (x
, SCM_INUM1
);
7245 SCM_PRIMITIVE_GENERIC (scm_i_difference
, "-", 0, 2, 1,
7246 (SCM x
, SCM y
, SCM rest
),
7247 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7248 "the sum of all but the first argument are subtracted from the first\n"
7250 #define FUNC_NAME s_scm_i_difference
7252 while (!scm_is_null (rest
))
7253 { x
= scm_difference (x
, y
);
7255 rest
= scm_cdr (rest
);
7257 return scm_difference (x
, y
);
7261 #define s_difference s_scm_i_difference
7262 #define g_difference g_scm_i_difference
7265 scm_difference (SCM x
, SCM y
)
7266 #define FUNC_NAME s_difference
7268 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7271 return scm_wta_dispatch_0 (g_difference
, s_difference
);
7273 if (SCM_I_INUMP (x
))
7275 scm_t_inum xx
= -SCM_I_INUM (x
);
7276 if (SCM_FIXABLE (xx
))
7277 return SCM_I_MAKINUM (xx
);
7279 return scm_i_inum2big (xx
);
7281 else if (SCM_BIGP (x
))
7282 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7283 bignum, but negating that gives a fixnum. */
7284 return scm_i_normbig (scm_i_clonebig (x
, 0));
7285 else if (SCM_REALP (x
))
7286 return scm_from_double (-SCM_REAL_VALUE (x
));
7287 else if (SCM_COMPLEXP (x
))
7288 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x
),
7289 -SCM_COMPLEX_IMAG (x
));
7290 else if (SCM_FRACTIONP (x
))
7291 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
7292 SCM_FRACTION_DENOMINATOR (x
));
7294 return scm_wta_dispatch_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
7297 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7299 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7301 scm_t_inum xx
= SCM_I_INUM (x
);
7302 scm_t_inum yy
= SCM_I_INUM (y
);
7303 scm_t_inum z
= xx
- yy
;
7304 if (SCM_FIXABLE (z
))
7305 return SCM_I_MAKINUM (z
);
7307 return scm_i_inum2big (z
);
7309 else if (SCM_BIGP (y
))
7311 /* inum-x - big-y */
7312 scm_t_inum xx
= SCM_I_INUM (x
);
7316 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7317 bignum, but negating that gives a fixnum. */
7318 return scm_i_normbig (scm_i_clonebig (y
, 0));
7322 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7323 SCM result
= scm_i_mkbig ();
7326 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
7329 /* x - y == -(y + -x) */
7330 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
7331 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7333 scm_remember_upto_here_1 (y
);
7335 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
7336 /* we know the result will have to be a bignum */
7339 return scm_i_normbig (result
);
7342 else if (SCM_REALP (y
))
7344 scm_t_inum xx
= SCM_I_INUM (x
);
7347 * We need to handle x == exact 0
7348 * specially because R6RS states that:
7349 * (- 0.0) ==> -0.0 and
7350 * (- 0.0 0.0) ==> 0.0
7351 * and the scheme compiler changes
7352 * (- 0.0) into (- 0 0.0)
7353 * So we need to treat (- 0 0.0) like (- 0.0).
7354 * At the C level, (-x) is different than (0.0 - x).
7355 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7358 return scm_from_double (- SCM_REAL_VALUE (y
));
7360 return scm_from_double (xx
- SCM_REAL_VALUE (y
));
7362 else if (SCM_COMPLEXP (y
))
7364 scm_t_inum xx
= SCM_I_INUM (x
);
7366 /* We need to handle x == exact 0 specially.
7367 See the comment above (for SCM_REALP (y)) */
7369 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y
),
7370 - SCM_COMPLEX_IMAG (y
));
7372 return scm_c_make_rectangular (xx
- SCM_COMPLEX_REAL (y
),
7373 - SCM_COMPLEX_IMAG (y
));
7375 else if (SCM_FRACTIONP (y
))
7376 /* a - b/c = (ac - b) / c */
7377 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7378 SCM_FRACTION_NUMERATOR (y
)),
7379 SCM_FRACTION_DENOMINATOR (y
));
7381 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7383 else if (SCM_BIGP (x
))
7385 if (SCM_I_INUMP (y
))
7387 /* big-x - inum-y */
7388 scm_t_inum yy
= SCM_I_INUM (y
);
7389 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7391 scm_remember_upto_here_1 (x
);
7393 return (SCM_FIXABLE (-yy
) ?
7394 SCM_I_MAKINUM (-yy
) : scm_from_inum (-yy
));
7397 SCM result
= scm_i_mkbig ();
7400 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
7402 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
7403 scm_remember_upto_here_1 (x
);
7405 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
7406 /* we know the result will have to be a bignum */
7409 return scm_i_normbig (result
);
7412 else if (SCM_BIGP (y
))
7414 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7415 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
7416 SCM result
= scm_i_mkbig ();
7417 mpz_sub (SCM_I_BIG_MPZ (result
),
7420 scm_remember_upto_here_2 (x
, y
);
7421 /* we know the result will have to be a bignum */
7422 if ((sgn_x
== 1) && (sgn_y
== -1))
7424 if ((sgn_x
== -1) && (sgn_y
== 1))
7426 return scm_i_normbig (result
);
7428 else if (SCM_REALP (y
))
7430 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
7431 scm_remember_upto_here_1 (x
);
7432 return scm_from_double (result
);
7434 else if (SCM_COMPLEXP (y
))
7436 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
7437 - SCM_COMPLEX_REAL (y
));
7438 scm_remember_upto_here_1 (x
);
7439 return scm_c_make_rectangular (real_part
, - SCM_COMPLEX_IMAG (y
));
7441 else if (SCM_FRACTIONP (y
))
7442 return scm_i_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7443 SCM_FRACTION_NUMERATOR (y
)),
7444 SCM_FRACTION_DENOMINATOR (y
));
7446 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7448 else if (SCM_REALP (x
))
7450 if (SCM_I_INUMP (y
))
7451 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_I_INUM (y
));
7452 else if (SCM_BIGP (y
))
7454 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
7455 scm_remember_upto_here_1 (x
);
7456 return scm_from_double (result
);
7458 else if (SCM_REALP (y
))
7459 return scm_from_double (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
7460 else if (SCM_COMPLEXP (y
))
7461 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
7462 -SCM_COMPLEX_IMAG (y
));
7463 else if (SCM_FRACTIONP (y
))
7464 return scm_from_double (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
7466 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7468 else if (SCM_COMPLEXP (x
))
7470 if (SCM_I_INUMP (y
))
7471 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_I_INUM (y
),
7472 SCM_COMPLEX_IMAG (x
));
7473 else if (SCM_BIGP (y
))
7475 double real_part
= (SCM_COMPLEX_REAL (x
)
7476 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
7477 scm_remember_upto_here_1 (x
);
7478 return scm_c_make_rectangular (real_part
, SCM_COMPLEX_IMAG (y
));
7480 else if (SCM_REALP (y
))
7481 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
7482 SCM_COMPLEX_IMAG (x
));
7483 else if (SCM_COMPLEXP (y
))
7484 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
7485 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
7486 else if (SCM_FRACTIONP (y
))
7487 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
7488 SCM_COMPLEX_IMAG (x
));
7490 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7492 else if (SCM_FRACTIONP (x
))
7494 if (SCM_I_INUMP (y
))
7495 /* a/b - c = (a - cb) / b */
7496 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7497 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7498 SCM_FRACTION_DENOMINATOR (x
));
7499 else if (SCM_BIGP (y
))
7500 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
7501 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
7502 SCM_FRACTION_DENOMINATOR (x
));
7503 else if (SCM_REALP (y
))
7504 return scm_from_double (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
7505 else if (SCM_COMPLEXP (y
))
7506 return scm_c_make_rectangular (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
7507 -SCM_COMPLEX_IMAG (y
));
7508 else if (SCM_FRACTIONP (y
))
7509 /* a/b - c/d = (ad - bc) / bd */
7510 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
7511 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
7512 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
7514 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
7517 return scm_wta_dispatch_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
7522 SCM_DEFINE (scm_oneminus
, "1-", 1, 0, 0,
7524 "Return @math{@var{x}-1}.")
7525 #define FUNC_NAME s_scm_oneminus
7527 return scm_difference (x
, SCM_INUM1
);
7532 SCM_PRIMITIVE_GENERIC (scm_i_product
, "*", 0, 2, 1,
7533 (SCM x
, SCM y
, SCM rest
),
7534 "Return the product of all arguments. If called without arguments,\n"
7536 #define FUNC_NAME s_scm_i_product
7538 while (!scm_is_null (rest
))
7539 { x
= scm_product (x
, y
);
7541 rest
= scm_cdr (rest
);
7543 return scm_product (x
, y
);
7547 #define s_product s_scm_i_product
7548 #define g_product g_scm_i_product
7551 scm_product (SCM x
, SCM y
)
7553 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7556 return SCM_I_MAKINUM (1L);
7557 else if (SCM_NUMBERP (x
))
7560 return scm_wta_dispatch_1 (g_product
, x
, SCM_ARG1
, s_product
);
7563 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7568 xx
= SCM_I_INUM (x
);
7573 /* exact1 is the universal multiplicative identity */
7577 /* exact0 times a fixnum is exact0: optimize this case */
7578 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7580 /* if the other argument is inexact, the result is inexact,
7581 and we must do the multiplication in order to handle
7582 infinities and NaNs properly. */
7583 else if (SCM_REALP (y
))
7584 return scm_from_double (0.0 * SCM_REAL_VALUE (y
));
7585 else if (SCM_COMPLEXP (y
))
7586 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y
),
7587 0.0 * SCM_COMPLEX_IMAG (y
));
7588 /* we've already handled inexact numbers,
7589 so y must be exact, and we return exact0 */
7590 else if (SCM_NUMP (y
))
7593 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7597 * This case is important for more than just optimization.
7598 * It handles the case of negating
7599 * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
7600 * which is a bignum that must be changed back into a fixnum.
7601 * Failure to do so will cause the following to return #f:
7602 * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
7604 return scm_difference(y
, SCM_UNDEFINED
);
7608 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7610 scm_t_inum yy
= SCM_I_INUM (y
);
7611 scm_t_inum kk
= xx
* yy
;
7612 SCM k
= SCM_I_MAKINUM (kk
);
7613 if ((kk
== SCM_I_INUM (k
)) && (kk
/ xx
== yy
))
7617 SCM result
= scm_i_inum2big (xx
);
7618 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
7619 return scm_i_normbig (result
);
7622 else if (SCM_BIGP (y
))
7624 SCM result
= scm_i_mkbig ();
7625 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
7626 scm_remember_upto_here_1 (y
);
7629 else if (SCM_REALP (y
))
7630 return scm_from_double (xx
* SCM_REAL_VALUE (y
));
7631 else if (SCM_COMPLEXP (y
))
7632 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7633 xx
* SCM_COMPLEX_IMAG (y
));
7634 else if (SCM_FRACTIONP (y
))
7635 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7636 SCM_FRACTION_DENOMINATOR (y
));
7638 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7640 else if (SCM_BIGP (x
))
7642 if (SCM_I_INUMP (y
))
7647 else if (SCM_BIGP (y
))
7649 SCM result
= scm_i_mkbig ();
7650 mpz_mul (SCM_I_BIG_MPZ (result
),
7653 scm_remember_upto_here_2 (x
, y
);
7656 else if (SCM_REALP (y
))
7658 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
7659 scm_remember_upto_here_1 (x
);
7660 return scm_from_double (result
);
7662 else if (SCM_COMPLEXP (y
))
7664 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
7665 scm_remember_upto_here_1 (x
);
7666 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (y
),
7667 z
* SCM_COMPLEX_IMAG (y
));
7669 else if (SCM_FRACTIONP (y
))
7670 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
7671 SCM_FRACTION_DENOMINATOR (y
));
7673 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7675 else if (SCM_REALP (x
))
7677 if (SCM_I_INUMP (y
))
7682 else if (SCM_BIGP (y
))
7684 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
7685 scm_remember_upto_here_1 (y
);
7686 return scm_from_double (result
);
7688 else if (SCM_REALP (y
))
7689 return scm_from_double (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
7690 else if (SCM_COMPLEXP (y
))
7691 return scm_c_make_rectangular (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
7692 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
7693 else if (SCM_FRACTIONP (y
))
7694 return scm_from_double (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
7696 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7698 else if (SCM_COMPLEXP (x
))
7700 if (SCM_I_INUMP (y
))
7705 else if (SCM_BIGP (y
))
7707 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
7708 scm_remember_upto_here_1 (y
);
7709 return scm_c_make_rectangular (z
* SCM_COMPLEX_REAL (x
),
7710 z
* SCM_COMPLEX_IMAG (x
));
7712 else if (SCM_REALP (y
))
7713 return scm_c_make_rectangular (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
7714 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
7715 else if (SCM_COMPLEXP (y
))
7717 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
7718 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
7719 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
7720 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
7722 else if (SCM_FRACTIONP (y
))
7724 double yy
= scm_i_fraction2double (y
);
7725 return scm_c_make_rectangular (yy
* SCM_COMPLEX_REAL (x
),
7726 yy
* SCM_COMPLEX_IMAG (x
));
7729 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7731 else if (SCM_FRACTIONP (x
))
7733 if (SCM_I_INUMP (y
))
7734 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7735 SCM_FRACTION_DENOMINATOR (x
));
7736 else if (SCM_BIGP (y
))
7737 return scm_i_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
7738 SCM_FRACTION_DENOMINATOR (x
));
7739 else if (SCM_REALP (y
))
7740 return scm_from_double (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
7741 else if (SCM_COMPLEXP (y
))
7743 double xx
= scm_i_fraction2double (x
);
7744 return scm_c_make_rectangular (xx
* SCM_COMPLEX_REAL (y
),
7745 xx
* SCM_COMPLEX_IMAG (y
));
7747 else if (SCM_FRACTIONP (y
))
7748 /* a/b * c/d = ac / bd */
7749 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
7750 SCM_FRACTION_NUMERATOR (y
)),
7751 scm_product (SCM_FRACTION_DENOMINATOR (x
),
7752 SCM_FRACTION_DENOMINATOR (y
)));
7754 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
7757 return scm_wta_dispatch_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
7760 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
7761 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
7762 #define ALLOW_DIVIDE_BY_ZERO
7763 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
7766 /* The code below for complex division is adapted from the GNU
7767 libstdc++, which adapted it from f2c's libF77, and is subject to
7770 /****************************************************************
7771 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
7773 Permission to use, copy, modify, and distribute this software
7774 and its documentation for any purpose and without fee is hereby
7775 granted, provided that the above copyright notice appear in all
7776 copies and that both that the copyright notice and this
7777 permission notice and warranty disclaimer appear in supporting
7778 documentation, and that the names of AT&T Bell Laboratories or
7779 Bellcore or any of their entities not be used in advertising or
7780 publicity pertaining to distribution of the software without
7781 specific, written prior permission.
7783 AT&T and Bellcore disclaim all warranties with regard to this
7784 software, including all implied warranties of merchantability
7785 and fitness. In no event shall AT&T or Bellcore be liable for
7786 any special, indirect or consequential damages or any damages
7787 whatsoever resulting from loss of use, data or profits, whether
7788 in an action of contract, negligence or other tortious action,
7789 arising out of or in connection with the use or performance of
7791 ****************************************************************/
7793 SCM_PRIMITIVE_GENERIC (scm_i_divide
, "/", 0, 2, 1,
7794 (SCM x
, SCM y
, SCM rest
),
7795 "Divide the first argument by the product of the remaining\n"
7796 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
7798 #define FUNC_NAME s_scm_i_divide
7800 while (!scm_is_null (rest
))
7801 { x
= scm_divide (x
, y
);
7803 rest
= scm_cdr (rest
);
7805 return scm_divide (x
, y
);
7809 #define s_divide s_scm_i_divide
7810 #define g_divide g_scm_i_divide
7813 do_divide (SCM x
, SCM y
, int inexact
)
7814 #define FUNC_NAME s_divide
7818 if (SCM_UNLIKELY (SCM_UNBNDP (y
)))
7821 return scm_wta_dispatch_0 (g_divide
, s_divide
);
7822 else if (SCM_I_INUMP (x
))
7824 scm_t_inum xx
= SCM_I_INUM (x
);
7825 if (xx
== 1 || xx
== -1)
7827 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7829 scm_num_overflow (s_divide
);
7834 return scm_from_double (1.0 / (double) xx
);
7835 else return scm_i_make_ratio (SCM_INUM1
, x
);
7838 else if (SCM_BIGP (x
))
7841 return scm_from_double (1.0 / scm_i_big2dbl (x
));
7842 else return scm_i_make_ratio (SCM_INUM1
, x
);
7844 else if (SCM_REALP (x
))
7846 double xx
= SCM_REAL_VALUE (x
);
7847 #ifndef ALLOW_DIVIDE_BY_ZERO
7849 scm_num_overflow (s_divide
);
7852 return scm_from_double (1.0 / xx
);
7854 else if (SCM_COMPLEXP (x
))
7856 double r
= SCM_COMPLEX_REAL (x
);
7857 double i
= SCM_COMPLEX_IMAG (x
);
7858 if (fabs(r
) <= fabs(i
))
7861 double d
= i
* (1.0 + t
* t
);
7862 return scm_c_make_rectangular (t
/ d
, -1.0 / d
);
7867 double d
= r
* (1.0 + t
* t
);
7868 return scm_c_make_rectangular (1.0 / d
, -t
/ d
);
7871 else if (SCM_FRACTIONP (x
))
7872 return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
7873 SCM_FRACTION_NUMERATOR (x
));
7875 return scm_wta_dispatch_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
7878 if (SCM_LIKELY (SCM_I_INUMP (x
)))
7880 scm_t_inum xx
= SCM_I_INUM (x
);
7881 if (SCM_LIKELY (SCM_I_INUMP (y
)))
7883 scm_t_inum yy
= SCM_I_INUM (y
);
7886 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7887 scm_num_overflow (s_divide
);
7889 return scm_from_double ((double) xx
/ (double) yy
);
7892 else if (xx
% yy
!= 0)
7895 return scm_from_double ((double) xx
/ (double) yy
);
7896 else return scm_i_make_ratio (x
, y
);
7900 scm_t_inum z
= xx
/ yy
;
7901 if (SCM_FIXABLE (z
))
7902 return SCM_I_MAKINUM (z
);
7904 return scm_i_inum2big (z
);
7907 else if (SCM_BIGP (y
))
7910 return scm_from_double ((double) xx
/ scm_i_big2dbl (y
));
7911 else return scm_i_make_ratio (x
, y
);
7913 else if (SCM_REALP (y
))
7915 double yy
= SCM_REAL_VALUE (y
);
7916 #ifndef ALLOW_DIVIDE_BY_ZERO
7918 scm_num_overflow (s_divide
);
7921 return scm_from_double ((double) xx
/ yy
);
7923 else if (SCM_COMPLEXP (y
))
7926 complex_div
: /* y _must_ be a complex number */
7928 double r
= SCM_COMPLEX_REAL (y
);
7929 double i
= SCM_COMPLEX_IMAG (y
);
7930 if (fabs(r
) <= fabs(i
))
7933 double d
= i
* (1.0 + t
* t
);
7934 return scm_c_make_rectangular ((a
* t
) / d
, -a
/ d
);
7939 double d
= r
* (1.0 + t
* t
);
7940 return scm_c_make_rectangular (a
/ d
, -(a
* t
) / d
);
7944 else if (SCM_FRACTIONP (y
))
7945 /* a / b/c = ac / b */
7946 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
7947 SCM_FRACTION_NUMERATOR (y
));
7949 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
7951 else if (SCM_BIGP (x
))
7953 if (SCM_I_INUMP (y
))
7955 scm_t_inum yy
= SCM_I_INUM (y
);
7958 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
7959 scm_num_overflow (s_divide
);
7961 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
7962 scm_remember_upto_here_1 (x
);
7963 return (sgn
== 0) ? scm_nan () : scm_inf ();
7970 /* FIXME: HMM, what are the relative performance issues here?
7971 We need to test. Is it faster on average to test
7972 divisible_p, then perform whichever operation, or is it
7973 faster to perform the integer div opportunistically and
7974 switch to real if there's a remainder? For now we take the
7975 middle ground: test, then if divisible, use the faster div
7978 scm_t_inum abs_yy
= yy
< 0 ? -yy
: yy
;
7979 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
7983 SCM result
= scm_i_mkbig ();
7984 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
7985 scm_remember_upto_here_1 (x
);
7987 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
7988 return scm_i_normbig (result
);
7993 return scm_from_double (scm_i_big2dbl (x
) / (double) yy
);
7994 else return scm_i_make_ratio (x
, y
);
7998 else if (SCM_BIGP (y
))
8003 /* It's easily possible for the ratio x/y to fit a double
8004 but one or both x and y be too big to fit a double,
8005 hence the use of mpq_get_d rather than converting and
8008 *mpq_numref(q
) = *SCM_I_BIG_MPZ (x
);
8009 *mpq_denref(q
) = *SCM_I_BIG_MPZ (y
);
8010 return scm_from_double (mpq_get_d (q
));
8014 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
8018 SCM result
= scm_i_mkbig ();
8019 mpz_divexact (SCM_I_BIG_MPZ (result
),
8022 scm_remember_upto_here_2 (x
, y
);
8023 return scm_i_normbig (result
);
8026 return scm_i_make_ratio (x
, y
);
8029 else if (SCM_REALP (y
))
8031 double yy
= SCM_REAL_VALUE (y
);
8032 #ifndef ALLOW_DIVIDE_BY_ZERO
8034 scm_num_overflow (s_divide
);
8037 return scm_from_double (scm_i_big2dbl (x
) / yy
);
8039 else if (SCM_COMPLEXP (y
))
8041 a
= scm_i_big2dbl (x
);
8044 else if (SCM_FRACTIONP (y
))
8045 return scm_i_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
8046 SCM_FRACTION_NUMERATOR (y
));
8048 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8050 else if (SCM_REALP (x
))
8052 double rx
= SCM_REAL_VALUE (x
);
8053 if (SCM_I_INUMP (y
))
8055 scm_t_inum yy
= SCM_I_INUM (y
);
8056 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8058 scm_num_overflow (s_divide
);
8061 return scm_from_double (rx
/ (double) yy
);
8063 else if (SCM_BIGP (y
))
8065 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8066 scm_remember_upto_here_1 (y
);
8067 return scm_from_double (rx
/ dby
);
8069 else if (SCM_REALP (y
))
8071 double yy
= SCM_REAL_VALUE (y
);
8072 #ifndef ALLOW_DIVIDE_BY_ZERO
8074 scm_num_overflow (s_divide
);
8077 return scm_from_double (rx
/ yy
);
8079 else if (SCM_COMPLEXP (y
))
8084 else if (SCM_FRACTIONP (y
))
8085 return scm_from_double (rx
/ scm_i_fraction2double (y
));
8087 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8089 else if (SCM_COMPLEXP (x
))
8091 double rx
= SCM_COMPLEX_REAL (x
);
8092 double ix
= SCM_COMPLEX_IMAG (x
);
8093 if (SCM_I_INUMP (y
))
8095 scm_t_inum yy
= SCM_I_INUM (y
);
8096 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8098 scm_num_overflow (s_divide
);
8103 return scm_c_make_rectangular (rx
/ d
, ix
/ d
);
8106 else if (SCM_BIGP (y
))
8108 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
8109 scm_remember_upto_here_1 (y
);
8110 return scm_c_make_rectangular (rx
/ dby
, ix
/ dby
);
8112 else if (SCM_REALP (y
))
8114 double yy
= SCM_REAL_VALUE (y
);
8115 #ifndef ALLOW_DIVIDE_BY_ZERO
8117 scm_num_overflow (s_divide
);
8120 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8122 else if (SCM_COMPLEXP (y
))
8124 double ry
= SCM_COMPLEX_REAL (y
);
8125 double iy
= SCM_COMPLEX_IMAG (y
);
8126 if (fabs(ry
) <= fabs(iy
))
8129 double d
= iy
* (1.0 + t
* t
);
8130 return scm_c_make_rectangular ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
8135 double d
= ry
* (1.0 + t
* t
);
8136 return scm_c_make_rectangular ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
8139 else if (SCM_FRACTIONP (y
))
8141 double yy
= scm_i_fraction2double (y
);
8142 return scm_c_make_rectangular (rx
/ yy
, ix
/ yy
);
8145 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8147 else if (SCM_FRACTIONP (x
))
8149 if (SCM_I_INUMP (y
))
8151 scm_t_inum yy
= SCM_I_INUM (y
);
8152 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8154 scm_num_overflow (s_divide
);
8157 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8158 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8160 else if (SCM_BIGP (y
))
8162 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x
),
8163 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
8165 else if (SCM_REALP (y
))
8167 double yy
= SCM_REAL_VALUE (y
);
8168 #ifndef ALLOW_DIVIDE_BY_ZERO
8170 scm_num_overflow (s_divide
);
8173 return scm_from_double (scm_i_fraction2double (x
) / yy
);
8175 else if (SCM_COMPLEXP (y
))
8177 a
= scm_i_fraction2double (x
);
8180 else if (SCM_FRACTIONP (y
))
8181 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
8182 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
8184 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
8187 return scm_wta_dispatch_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
8191 scm_divide (SCM x
, SCM y
)
8193 return do_divide (x
, y
, 0);
8196 static SCM
scm_divide2real (SCM x
, SCM y
)
8198 return do_divide (x
, y
, 1);
8204 scm_c_truncate (double x
)
8209 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8210 half-way case (ie. when x is an integer plus 0.5) going upwards.
8211 Then half-way cases are identified and adjusted down if the
8212 round-upwards didn't give the desired even integer.
8214 "plus_half == result" identifies a half-way case. If plus_half, which is
8215 x + 0.5, is an integer then x must be an integer plus 0.5.
8217 An odd "result" value is identified with result/2 != floor(result/2).
8218 This is done with plus_half, since that value is ready for use sooner in
8219 a pipelined cpu, and we're already requiring plus_half == result.
8221 Note however that we need to be careful when x is big and already an
8222 integer. In that case "x+0.5" may round to an adjacent integer, causing
8223 us to return such a value, incorrectly. For instance if the hardware is
8224 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8225 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8226 returned. Or if the hardware is in round-upwards mode, then other bigger
8227 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8228 representable value, 2^128+2^76 (or whatever), again incorrect.
8230 These bad roundings of x+0.5 are avoided by testing at the start whether
8231 x is already an integer. If it is then clearly that's the desired result
8232 already. And if it's not then the exponent must be small enough to allow
8233 an 0.5 to be represented, and hence added without a bad rounding. */
8236 scm_c_round (double x
)
8238 double plus_half
, result
;
8243 plus_half
= x
+ 0.5;
8244 result
= floor (plus_half
);
8245 /* Adjust so that the rounding is towards even. */
8246 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
8251 SCM_PRIMITIVE_GENERIC (scm_truncate_number
, "truncate", 1, 0, 0,
8253 "Round the number @var{x} towards zero.")
8254 #define FUNC_NAME s_scm_truncate_number
8256 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8258 else if (SCM_REALP (x
))
8259 return scm_from_double (trunc (SCM_REAL_VALUE (x
)));
8260 else if (SCM_FRACTIONP (x
))
8261 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x
),
8262 SCM_FRACTION_DENOMINATOR (x
));
8264 return scm_wta_dispatch_1 (g_scm_truncate_number
, x
, SCM_ARG1
,
8265 s_scm_truncate_number
);
8269 SCM_PRIMITIVE_GENERIC (scm_round_number
, "round", 1, 0, 0,
8271 "Round the number @var{x} towards the nearest integer. "
8272 "When it is exactly halfway between two integers, "
8273 "round towards the even one.")
8274 #define FUNC_NAME s_scm_round_number
8276 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8278 else if (SCM_REALP (x
))
8279 return scm_from_double (scm_c_round (SCM_REAL_VALUE (x
)));
8280 else if (SCM_FRACTIONP (x
))
8281 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x
),
8282 SCM_FRACTION_DENOMINATOR (x
));
8284 return scm_wta_dispatch_1 (g_scm_round_number
, x
, SCM_ARG1
,
8285 s_scm_round_number
);
8289 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
8291 "Round the number @var{x} towards minus infinity.")
8292 #define FUNC_NAME s_scm_floor
8294 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8296 else if (SCM_REALP (x
))
8297 return scm_from_double (floor (SCM_REAL_VALUE (x
)));
8298 else if (SCM_FRACTIONP (x
))
8299 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x
),
8300 SCM_FRACTION_DENOMINATOR (x
));
8302 return scm_wta_dispatch_1 (g_scm_floor
, x
, 1, s_scm_floor
);
8306 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
8308 "Round the number @var{x} towards infinity.")
8309 #define FUNC_NAME s_scm_ceiling
8311 if (SCM_I_INUMP (x
) || SCM_BIGP (x
))
8313 else if (SCM_REALP (x
))
8314 return scm_from_double (ceil (SCM_REAL_VALUE (x
)));
8315 else if (SCM_FRACTIONP (x
))
8316 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x
),
8317 SCM_FRACTION_DENOMINATOR (x
));
8319 return scm_wta_dispatch_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
8323 SCM_PRIMITIVE_GENERIC (scm_expt
, "expt", 2, 0, 0,
8325 "Return @var{x} raised to the power of @var{y}.")
8326 #define FUNC_NAME s_scm_expt
8328 if (scm_is_integer (y
))
8330 if (scm_is_true (scm_exact_p (y
)))
8331 return scm_integer_expt (x
, y
);
8334 /* Here we handle the case where the exponent is an inexact
8335 integer. We make the exponent exact in order to use
8336 scm_integer_expt, and thus avoid the spurious imaginary
8337 parts that may result from round-off errors in the general
8338 e^(y log x) method below (for example when squaring a large
8339 negative number). In this case, we must return an inexact
8340 result for correctness. We also make the base inexact so
8341 that scm_integer_expt will use fast inexact arithmetic
8342 internally. Note that making the base inexact is not
8343 sufficient to guarantee an inexact result, because
8344 scm_integer_expt will return an exact 1 when the exponent
8345 is 0, even if the base is inexact. */
8346 return scm_exact_to_inexact
8347 (scm_integer_expt (scm_exact_to_inexact (x
),
8348 scm_inexact_to_exact (y
)));
8351 else if (scm_is_real (x
) && scm_is_real (y
) && scm_to_double (x
) >= 0.0)
8353 return scm_from_double (pow (scm_to_double (x
), scm_to_double (y
)));
8355 else if (scm_is_complex (x
) && scm_is_complex (y
))
8356 return scm_exp (scm_product (scm_log (x
), y
));
8357 else if (scm_is_complex (x
))
8358 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG2
, s_scm_expt
);
8360 return scm_wta_dispatch_2 (g_scm_expt
, x
, y
, SCM_ARG1
, s_scm_expt
);
8364 /* sin/cos/tan/asin/acos/atan
8365 sinh/cosh/tanh/asinh/acosh/atanh
8366 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8367 Written by Jerry D. Hedden, (C) FSF.
8368 See the file `COPYING' for terms applying to this program. */
8370 SCM_PRIMITIVE_GENERIC (scm_sin
, "sin", 1, 0, 0,
8372 "Compute the sine of @var{z}.")
8373 #define FUNC_NAME s_scm_sin
8375 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8376 return z
; /* sin(exact0) = exact0 */
8377 else if (scm_is_real (z
))
8378 return scm_from_double (sin (scm_to_double (z
)));
8379 else if (SCM_COMPLEXP (z
))
8381 x
= SCM_COMPLEX_REAL (z
);
8382 y
= SCM_COMPLEX_IMAG (z
);
8383 return scm_c_make_rectangular (sin (x
) * cosh (y
),
8384 cos (x
) * sinh (y
));
8387 return scm_wta_dispatch_1 (g_scm_sin
, z
, 1, s_scm_sin
);
8391 SCM_PRIMITIVE_GENERIC (scm_cos
, "cos", 1, 0, 0,
8393 "Compute the cosine of @var{z}.")
8394 #define FUNC_NAME s_scm_cos
8396 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8397 return SCM_INUM1
; /* cos(exact0) = exact1 */
8398 else if (scm_is_real (z
))
8399 return scm_from_double (cos (scm_to_double (z
)));
8400 else if (SCM_COMPLEXP (z
))
8402 x
= SCM_COMPLEX_REAL (z
);
8403 y
= SCM_COMPLEX_IMAG (z
);
8404 return scm_c_make_rectangular (cos (x
) * cosh (y
),
8405 -sin (x
) * sinh (y
));
8408 return scm_wta_dispatch_1 (g_scm_cos
, z
, 1, s_scm_cos
);
8412 SCM_PRIMITIVE_GENERIC (scm_tan
, "tan", 1, 0, 0,
8414 "Compute the tangent of @var{z}.")
8415 #define FUNC_NAME s_scm_tan
8417 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8418 return z
; /* tan(exact0) = exact0 */
8419 else if (scm_is_real (z
))
8420 return scm_from_double (tan (scm_to_double (z
)));
8421 else if (SCM_COMPLEXP (z
))
8423 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8424 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8425 w
= cos (x
) + cosh (y
);
8426 #ifndef ALLOW_DIVIDE_BY_ZERO
8428 scm_num_overflow (s_scm_tan
);
8430 return scm_c_make_rectangular (sin (x
) / w
, sinh (y
) / w
);
8433 return scm_wta_dispatch_1 (g_scm_tan
, z
, 1, s_scm_tan
);
8437 SCM_PRIMITIVE_GENERIC (scm_sinh
, "sinh", 1, 0, 0,
8439 "Compute the hyperbolic sine of @var{z}.")
8440 #define FUNC_NAME s_scm_sinh
8442 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8443 return z
; /* sinh(exact0) = exact0 */
8444 else if (scm_is_real (z
))
8445 return scm_from_double (sinh (scm_to_double (z
)));
8446 else if (SCM_COMPLEXP (z
))
8448 x
= SCM_COMPLEX_REAL (z
);
8449 y
= SCM_COMPLEX_IMAG (z
);
8450 return scm_c_make_rectangular (sinh (x
) * cos (y
),
8451 cosh (x
) * sin (y
));
8454 return scm_wta_dispatch_1 (g_scm_sinh
, z
, 1, s_scm_sinh
);
8458 SCM_PRIMITIVE_GENERIC (scm_cosh
, "cosh", 1, 0, 0,
8460 "Compute the hyperbolic cosine of @var{z}.")
8461 #define FUNC_NAME s_scm_cosh
8463 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8464 return SCM_INUM1
; /* cosh(exact0) = exact1 */
8465 else if (scm_is_real (z
))
8466 return scm_from_double (cosh (scm_to_double (z
)));
8467 else if (SCM_COMPLEXP (z
))
8469 x
= SCM_COMPLEX_REAL (z
);
8470 y
= SCM_COMPLEX_IMAG (z
);
8471 return scm_c_make_rectangular (cosh (x
) * cos (y
),
8472 sinh (x
) * sin (y
));
8475 return scm_wta_dispatch_1 (g_scm_cosh
, z
, 1, s_scm_cosh
);
8479 SCM_PRIMITIVE_GENERIC (scm_tanh
, "tanh", 1, 0, 0,
8481 "Compute the hyperbolic tangent of @var{z}.")
8482 #define FUNC_NAME s_scm_tanh
8484 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8485 return z
; /* tanh(exact0) = exact0 */
8486 else if (scm_is_real (z
))
8487 return scm_from_double (tanh (scm_to_double (z
)));
8488 else if (SCM_COMPLEXP (z
))
8490 x
= 2.0 * SCM_COMPLEX_REAL (z
);
8491 y
= 2.0 * SCM_COMPLEX_IMAG (z
);
8492 w
= cosh (x
) + cos (y
);
8493 #ifndef ALLOW_DIVIDE_BY_ZERO
8495 scm_num_overflow (s_scm_tanh
);
8497 return scm_c_make_rectangular (sinh (x
) / w
, sin (y
) / w
);
8500 return scm_wta_dispatch_1 (g_scm_tanh
, z
, 1, s_scm_tanh
);
8504 SCM_PRIMITIVE_GENERIC (scm_asin
, "asin", 1, 0, 0,
8506 "Compute the arc sine of @var{z}.")
8507 #define FUNC_NAME s_scm_asin
8509 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8510 return z
; /* asin(exact0) = exact0 */
8511 else if (scm_is_real (z
))
8513 double w
= scm_to_double (z
);
8514 if (w
>= -1.0 && w
<= 1.0)
8515 return scm_from_double (asin (w
));
8517 return scm_product (scm_c_make_rectangular (0, -1),
8518 scm_sys_asinh (scm_c_make_rectangular (0, w
)));
8520 else if (SCM_COMPLEXP (z
))
8522 x
= SCM_COMPLEX_REAL (z
);
8523 y
= SCM_COMPLEX_IMAG (z
);
8524 return scm_product (scm_c_make_rectangular (0, -1),
8525 scm_sys_asinh (scm_c_make_rectangular (-y
, x
)));
8528 return scm_wta_dispatch_1 (g_scm_asin
, z
, 1, s_scm_asin
);
8532 SCM_PRIMITIVE_GENERIC (scm_acos
, "acos", 1, 0, 0,
8534 "Compute the arc cosine of @var{z}.")
8535 #define FUNC_NAME s_scm_acos
8537 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8538 return SCM_INUM0
; /* acos(exact1) = exact0 */
8539 else if (scm_is_real (z
))
8541 double w
= scm_to_double (z
);
8542 if (w
>= -1.0 && w
<= 1.0)
8543 return scm_from_double (acos (w
));
8545 return scm_sum (scm_from_double (acos (0.0)),
8546 scm_product (scm_c_make_rectangular (0, 1),
8547 scm_sys_asinh (scm_c_make_rectangular (0, w
))));
8549 else if (SCM_COMPLEXP (z
))
8551 x
= SCM_COMPLEX_REAL (z
);
8552 y
= SCM_COMPLEX_IMAG (z
);
8553 return scm_sum (scm_from_double (acos (0.0)),
8554 scm_product (scm_c_make_rectangular (0, 1),
8555 scm_sys_asinh (scm_c_make_rectangular (-y
, x
))));
8558 return scm_wta_dispatch_1 (g_scm_acos
, z
, 1, s_scm_acos
);
8562 SCM_PRIMITIVE_GENERIC (scm_atan
, "atan", 1, 1, 0,
8564 "With one argument, compute the arc tangent of @var{z}.\n"
8565 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
8566 "using the sign of @var{z} and @var{y} to determine the quadrant.")
8567 #define FUNC_NAME s_scm_atan
8571 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8572 return z
; /* atan(exact0) = exact0 */
8573 else if (scm_is_real (z
))
8574 return scm_from_double (atan (scm_to_double (z
)));
8575 else if (SCM_COMPLEXP (z
))
8578 v
= SCM_COMPLEX_REAL (z
);
8579 w
= SCM_COMPLEX_IMAG (z
);
8580 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v
, w
- 1.0),
8581 scm_c_make_rectangular (v
, w
+ 1.0))),
8582 scm_c_make_rectangular (0, 2));
8585 return scm_wta_dispatch_1 (g_scm_atan
, z
, SCM_ARG1
, s_scm_atan
);
8587 else if (scm_is_real (z
))
8589 if (scm_is_real (y
))
8590 return scm_from_double (atan2 (scm_to_double (z
), scm_to_double (y
)));
8592 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG2
, s_scm_atan
);
8595 return scm_wta_dispatch_2 (g_scm_atan
, z
, y
, SCM_ARG1
, s_scm_atan
);
8599 SCM_PRIMITIVE_GENERIC (scm_sys_asinh
, "asinh", 1, 0, 0,
8601 "Compute the inverse hyperbolic sine of @var{z}.")
8602 #define FUNC_NAME s_scm_sys_asinh
8604 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8605 return z
; /* asinh(exact0) = exact0 */
8606 else if (scm_is_real (z
))
8607 return scm_from_double (asinh (scm_to_double (z
)));
8608 else if (scm_is_number (z
))
8609 return scm_log (scm_sum (z
,
8610 scm_sqrt (scm_sum (scm_product (z
, z
),
8613 return scm_wta_dispatch_1 (g_scm_sys_asinh
, z
, 1, s_scm_sys_asinh
);
8617 SCM_PRIMITIVE_GENERIC (scm_sys_acosh
, "acosh", 1, 0, 0,
8619 "Compute the inverse hyperbolic cosine of @var{z}.")
8620 #define FUNC_NAME s_scm_sys_acosh
8622 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM1
)))
8623 return SCM_INUM0
; /* acosh(exact1) = exact0 */
8624 else if (scm_is_real (z
) && scm_to_double (z
) >= 1.0)
8625 return scm_from_double (acosh (scm_to_double (z
)));
8626 else if (scm_is_number (z
))
8627 return scm_log (scm_sum (z
,
8628 scm_sqrt (scm_difference (scm_product (z
, z
),
8631 return scm_wta_dispatch_1 (g_scm_sys_acosh
, z
, 1, s_scm_sys_acosh
);
8635 SCM_PRIMITIVE_GENERIC (scm_sys_atanh
, "atanh", 1, 0, 0,
8637 "Compute the inverse hyperbolic tangent of @var{z}.")
8638 #define FUNC_NAME s_scm_sys_atanh
8640 if (SCM_UNLIKELY (scm_is_eq (z
, SCM_INUM0
)))
8641 return z
; /* atanh(exact0) = exact0 */
8642 else if (scm_is_real (z
) && scm_to_double (z
) >= -1.0 && scm_to_double (z
) <= 1.0)
8643 return scm_from_double (atanh (scm_to_double (z
)));
8644 else if (scm_is_number (z
))
8645 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1
, z
),
8646 scm_difference (SCM_INUM1
, z
))),
8649 return scm_wta_dispatch_1 (g_scm_sys_atanh
, z
, 1, s_scm_sys_atanh
);
8654 scm_c_make_rectangular (double re
, double im
)
8658 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex
),
8660 SCM_SET_CELL_TYPE (z
, scm_tc16_complex
);
8661 SCM_COMPLEX_REAL (z
) = re
;
8662 SCM_COMPLEX_IMAG (z
) = im
;
8666 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
8667 (SCM real_part
, SCM imaginary_part
),
8668 "Return a complex number constructed of the given @var{real-part} "
8669 "and @var{imaginary-part} parts.")
8670 #define FUNC_NAME s_scm_make_rectangular
8672 SCM_ASSERT_TYPE (scm_is_real (real_part
), real_part
,
8673 SCM_ARG1
, FUNC_NAME
, "real");
8674 SCM_ASSERT_TYPE (scm_is_real (imaginary_part
), imaginary_part
,
8675 SCM_ARG2
, FUNC_NAME
, "real");
8677 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
8678 if (scm_is_eq (imaginary_part
, SCM_INUM0
))
8681 return scm_c_make_rectangular (scm_to_double (real_part
),
8682 scm_to_double (imaginary_part
));
8687 scm_c_make_polar (double mag
, double ang
)
8691 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
8692 use it on Glibc-based systems that have it (it's a GNU extension). See
8693 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
8695 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
8696 sincos (ang
, &s
, &c
);
8702 /* If s and c are NaNs, this indicates that the angle is a NaN,
8703 infinite, or perhaps simply too large to determine its value
8704 mod 2*pi. However, we know something that the floating-point
8705 implementation doesn't know: We know that s and c are finite.
8706 Therefore, if the magnitude is zero, return a complex zero.
8708 The reason we check for the NaNs instead of using this case
8709 whenever mag == 0.0 is because when the angle is known, we'd
8710 like to return the correct kind of non-real complex zero:
8711 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
8712 on which quadrant the angle is in.
8714 if (SCM_UNLIKELY (isnan(s
)) && isnan(c
) && (mag
== 0.0))
8715 return scm_c_make_rectangular (0.0, 0.0);
8717 return scm_c_make_rectangular (mag
* c
, mag
* s
);
8720 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
8722 "Return the complex number @var{mag} * e^(i * @var{ang}).")
8723 #define FUNC_NAME s_scm_make_polar
8725 SCM_ASSERT_TYPE (scm_is_real (mag
), mag
, SCM_ARG1
, FUNC_NAME
, "real");
8726 SCM_ASSERT_TYPE (scm_is_real (ang
), ang
, SCM_ARG2
, FUNC_NAME
, "real");
8728 /* If mag is exact0, return exact0 */
8729 if (scm_is_eq (mag
, SCM_INUM0
))
8731 /* Return a real if ang is exact0 */
8732 else if (scm_is_eq (ang
, SCM_INUM0
))
8735 return scm_c_make_polar (scm_to_double (mag
), scm_to_double (ang
));
8740 SCM_PRIMITIVE_GENERIC (scm_real_part
, "real-part", 1, 0, 0,
8742 "Return the real part of the number @var{z}.")
8743 #define FUNC_NAME s_scm_real_part
8745 if (SCM_COMPLEXP (z
))
8746 return scm_from_double (SCM_COMPLEX_REAL (z
));
8747 else if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_REALP (z
) || SCM_FRACTIONP (z
))
8750 return scm_wta_dispatch_1 (g_scm_real_part
, z
, SCM_ARG1
, s_scm_real_part
);
8755 SCM_PRIMITIVE_GENERIC (scm_imag_part
, "imag-part", 1, 0, 0,
8757 "Return the imaginary part of the number @var{z}.")
8758 #define FUNC_NAME s_scm_imag_part
8760 if (SCM_COMPLEXP (z
))
8761 return scm_from_double (SCM_COMPLEX_IMAG (z
));
8762 else if (SCM_I_INUMP (z
) || SCM_REALP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8765 return scm_wta_dispatch_1 (g_scm_imag_part
, z
, SCM_ARG1
, s_scm_imag_part
);
8769 SCM_PRIMITIVE_GENERIC (scm_numerator
, "numerator", 1, 0, 0,
8771 "Return the numerator of the number @var{z}.")
8772 #define FUNC_NAME s_scm_numerator
8774 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8776 else if (SCM_FRACTIONP (z
))
8777 return SCM_FRACTION_NUMERATOR (z
);
8778 else if (SCM_REALP (z
))
8779 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
8781 return scm_wta_dispatch_1 (g_scm_numerator
, z
, SCM_ARG1
, s_scm_numerator
);
8786 SCM_PRIMITIVE_GENERIC (scm_denominator
, "denominator", 1, 0, 0,
8788 "Return the denominator of the number @var{z}.")
8789 #define FUNC_NAME s_scm_denominator
8791 if (SCM_I_INUMP (z
) || SCM_BIGP (z
))
8793 else if (SCM_FRACTIONP (z
))
8794 return SCM_FRACTION_DENOMINATOR (z
);
8795 else if (SCM_REALP (z
))
8796 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
8798 return scm_wta_dispatch_1 (g_scm_denominator
, z
, SCM_ARG1
,
8804 SCM_PRIMITIVE_GENERIC (scm_magnitude
, "magnitude", 1, 0, 0,
8806 "Return the magnitude of the number @var{z}. This is the same as\n"
8807 "@code{abs} for real arguments, but also allows complex numbers.")
8808 #define FUNC_NAME s_scm_magnitude
8810 if (SCM_I_INUMP (z
))
8812 scm_t_inum zz
= SCM_I_INUM (z
);
8815 else if (SCM_POSFIXABLE (-zz
))
8816 return SCM_I_MAKINUM (-zz
);
8818 return scm_i_inum2big (-zz
);
8820 else if (SCM_BIGP (z
))
8822 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8823 scm_remember_upto_here_1 (z
);
8825 return scm_i_clonebig (z
, 0);
8829 else if (SCM_REALP (z
))
8830 return scm_from_double (fabs (SCM_REAL_VALUE (z
)));
8831 else if (SCM_COMPLEXP (z
))
8832 return scm_from_double (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
8833 else if (SCM_FRACTIONP (z
))
8835 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8837 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
8838 SCM_FRACTION_DENOMINATOR (z
));
8841 return scm_wta_dispatch_1 (g_scm_magnitude
, z
, SCM_ARG1
,
8847 SCM_PRIMITIVE_GENERIC (scm_angle
, "angle", 1, 0, 0,
8849 "Return the angle of the complex number @var{z}.")
8850 #define FUNC_NAME s_scm_angle
8852 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
8853 flo0 to save allocating a new flonum with scm_from_double each time.
8854 But if atan2 follows the floating point rounding mode, then the value
8855 is not a constant. Maybe it'd be close enough though. */
8856 if (SCM_I_INUMP (z
))
8858 if (SCM_I_INUM (z
) >= 0)
8861 return scm_from_double (atan2 (0.0, -1.0));
8863 else if (SCM_BIGP (z
))
8865 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
8866 scm_remember_upto_here_1 (z
);
8868 return scm_from_double (atan2 (0.0, -1.0));
8872 else if (SCM_REALP (z
))
8874 if (SCM_REAL_VALUE (z
) >= 0)
8877 return scm_from_double (atan2 (0.0, -1.0));
8879 else if (SCM_COMPLEXP (z
))
8880 return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
8881 else if (SCM_FRACTIONP (z
))
8883 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
8885 else return scm_from_double (atan2 (0.0, -1.0));
8888 return scm_wta_dispatch_1 (g_scm_angle
, z
, SCM_ARG1
, s_scm_angle
);
8893 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact
, "exact->inexact", 1, 0, 0,
8895 "Convert the number @var{z} to its inexact representation.\n")
8896 #define FUNC_NAME s_scm_exact_to_inexact
8898 if (SCM_I_INUMP (z
))
8899 return scm_from_double ((double) SCM_I_INUM (z
));
8900 else if (SCM_BIGP (z
))
8901 return scm_from_double (scm_i_big2dbl (z
));
8902 else if (SCM_FRACTIONP (z
))
8903 return scm_from_double (scm_i_fraction2double (z
));
8904 else if (SCM_INEXACTP (z
))
8907 return scm_wta_dispatch_1 (g_scm_exact_to_inexact
, z
, 1,
8908 s_scm_exact_to_inexact
);
8913 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
8915 "Return an exact number that is numerically closest to @var{z}.")
8916 #define FUNC_NAME s_scm_inexact_to_exact
8918 if (SCM_I_INUMP (z
) || SCM_BIGP (z
) || SCM_FRACTIONP (z
))
8925 val
= SCM_REAL_VALUE (z
);
8926 else if (SCM_COMPLEXP (z
) && SCM_COMPLEX_IMAG (z
) == 0.0)
8927 val
= SCM_COMPLEX_REAL (z
);
8929 return scm_wta_dispatch_1 (g_scm_inexact_to_exact
, z
, 1,
8930 s_scm_inexact_to_exact
);
8932 if (!SCM_LIKELY (DOUBLE_IS_FINITE (val
)))
8933 SCM_OUT_OF_RANGE (1, z
);
8940 mpq_set_d (frac
, val
);
8941 q
= scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
8942 scm_i_mpz2num (mpq_denref (frac
)));
8944 /* When scm_i_make_ratio throws, we leak the memory allocated
8954 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
8956 "Returns the @emph{simplest} rational number differing\n"
8957 "from @var{x} by no more than @var{eps}.\n"
8959 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
8960 "exact result when both its arguments are exact. Thus, you might need\n"
8961 "to use @code{inexact->exact} on the arguments.\n"
8964 "(rationalize (inexact->exact 1.2) 1/100)\n"
8967 #define FUNC_NAME s_scm_rationalize
8969 SCM_ASSERT_TYPE (scm_is_real (x
), x
, SCM_ARG1
, FUNC_NAME
, "real");
8970 SCM_ASSERT_TYPE (scm_is_real (eps
), eps
, SCM_ARG2
, FUNC_NAME
, "real");
8971 eps
= scm_abs (eps
);
8972 if (scm_is_false (scm_positive_p (eps
)))
8974 /* eps is either zero or a NaN */
8975 if (scm_is_true (scm_nan_p (eps
)))
8977 else if (SCM_INEXACTP (eps
))
8978 return scm_exact_to_inexact (x
);
8982 else if (scm_is_false (scm_finite_p (eps
)))
8984 if (scm_is_true (scm_finite_p (x
)))
8989 else if (scm_is_false (scm_finite_p (x
))) /* checks for both inf and nan */
8991 else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x
, eps
)),
8992 scm_ceiling (scm_difference (x
, eps
)))))
8994 /* There's an integer within range; we want the one closest to zero */
8995 if (scm_is_false (scm_less_p (eps
, scm_abs (x
))))
8997 /* zero is within range */
8998 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9003 else if (scm_is_true (scm_positive_p (x
)))
9004 return scm_ceiling (scm_difference (x
, eps
));
9006 return scm_floor (scm_sum (x
, eps
));
9010 /* Use continued fractions to find closest ratio. All
9011 arithmetic is done with exact numbers.
9014 SCM ex
= scm_inexact_to_exact (x
);
9015 SCM int_part
= scm_floor (ex
);
9017 SCM a1
= SCM_INUM0
, a2
= SCM_INUM1
, a
= SCM_INUM0
;
9018 SCM b1
= SCM_INUM1
, b2
= SCM_INUM0
, b
= SCM_INUM0
;
9022 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
9023 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
9025 /* We stop after a million iterations just to be absolutely sure
9026 that we don't go into an infinite loop. The process normally
9027 converges after less than a dozen iterations.
9030 while (++i
< 1000000)
9032 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
9033 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
9034 if (scm_is_false (scm_zero_p (b
)) && /* b != 0 */
9036 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
9037 eps
))) /* abs(x-a/b) <= eps */
9039 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
9040 if (SCM_INEXACTP (x
) || SCM_INEXACTP (eps
))
9041 return scm_exact_to_inexact (res
);
9045 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
9047 tt
= scm_floor (rx
); /* tt = floor (rx) */
9053 scm_num_overflow (s_scm_rationalize
);
9058 /* conversion functions */
9061 scm_is_integer (SCM val
)
9063 return scm_is_true (scm_integer_p (val
));
9067 scm_is_signed_integer (SCM val
, scm_t_intmax min
, scm_t_intmax max
)
9069 if (SCM_I_INUMP (val
))
9071 scm_t_signed_bits n
= SCM_I_INUM (val
);
9072 return n
>= min
&& n
<= max
;
9074 else if (SCM_BIGP (val
))
9076 if (min
>= SCM_MOST_NEGATIVE_FIXNUM
&& max
<= SCM_MOST_POSITIVE_FIXNUM
)
9078 else if (min
>= LONG_MIN
&& max
<= LONG_MAX
)
9080 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val
)))
9082 long n
= mpz_get_si (SCM_I_BIG_MPZ (val
));
9083 return n
>= min
&& n
<= max
;
9093 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9094 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9097 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9098 SCM_I_BIG_MPZ (val
));
9100 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) >= 0)
9112 return n
>= min
&& n
<= max
;
9120 scm_is_unsigned_integer (SCM val
, scm_t_uintmax min
, scm_t_uintmax max
)
9122 if (SCM_I_INUMP (val
))
9124 scm_t_signed_bits n
= SCM_I_INUM (val
);
9125 return n
>= 0 && ((scm_t_uintmax
)n
) >= min
&& ((scm_t_uintmax
)n
) <= max
;
9127 else if (SCM_BIGP (val
))
9129 if (max
<= SCM_MOST_POSITIVE_FIXNUM
)
9131 else if (max
<= ULONG_MAX
)
9133 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val
)))
9135 unsigned long n
= mpz_get_ui (SCM_I_BIG_MPZ (val
));
9136 return n
>= min
&& n
<= max
;
9146 if (mpz_sgn (SCM_I_BIG_MPZ (val
)) < 0)
9149 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val
), 2)
9150 > CHAR_BIT
*sizeof (scm_t_uintmax
))
9153 mpz_export (&n
, &count
, 1, sizeof (scm_t_uintmax
), 0, 0,
9154 SCM_I_BIG_MPZ (val
));
9156 return n
>= min
&& n
<= max
;
9164 scm_i_range_error (SCM bad_val
, SCM min
, SCM max
)
9166 scm_error (scm_out_of_range_key
,
9168 "Value out of range ~S to ~S: ~S",
9169 scm_list_3 (min
, max
, bad_val
),
9170 scm_list_1 (bad_val
));
9173 #define TYPE scm_t_intmax
9174 #define TYPE_MIN min
9175 #define TYPE_MAX max
9176 #define SIZEOF_TYPE 0
9177 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9178 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9179 #include "libguile/conv-integer.i.c"
9181 #define TYPE scm_t_uintmax
9182 #define TYPE_MIN min
9183 #define TYPE_MAX max
9184 #define SIZEOF_TYPE 0
9185 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9186 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9187 #include "libguile/conv-uinteger.i.c"
9189 #define TYPE scm_t_int8
9190 #define TYPE_MIN SCM_T_INT8_MIN
9191 #define TYPE_MAX SCM_T_INT8_MAX
9192 #define SIZEOF_TYPE 1
9193 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9194 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9195 #include "libguile/conv-integer.i.c"
9197 #define TYPE scm_t_uint8
9199 #define TYPE_MAX SCM_T_UINT8_MAX
9200 #define SIZEOF_TYPE 1
9201 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9202 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9203 #include "libguile/conv-uinteger.i.c"
9205 #define TYPE scm_t_int16
9206 #define TYPE_MIN SCM_T_INT16_MIN
9207 #define TYPE_MAX SCM_T_INT16_MAX
9208 #define SIZEOF_TYPE 2
9209 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9210 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9211 #include "libguile/conv-integer.i.c"
9213 #define TYPE scm_t_uint16
9215 #define TYPE_MAX SCM_T_UINT16_MAX
9216 #define SIZEOF_TYPE 2
9217 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9218 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9219 #include "libguile/conv-uinteger.i.c"
9221 #define TYPE scm_t_int32
9222 #define TYPE_MIN SCM_T_INT32_MIN
9223 #define TYPE_MAX SCM_T_INT32_MAX
9224 #define SIZEOF_TYPE 4
9225 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9226 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9227 #include "libguile/conv-integer.i.c"
9229 #define TYPE scm_t_uint32
9231 #define TYPE_MAX SCM_T_UINT32_MAX
9232 #define SIZEOF_TYPE 4
9233 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9234 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9235 #include "libguile/conv-uinteger.i.c"
9237 #define TYPE scm_t_wchar
9238 #define TYPE_MIN (scm_t_int32)-1
9239 #define TYPE_MAX (scm_t_int32)0x10ffff
9240 #define SIZEOF_TYPE 4
9241 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9242 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9243 #include "libguile/conv-integer.i.c"
9245 #define TYPE scm_t_int64
9246 #define TYPE_MIN SCM_T_INT64_MIN
9247 #define TYPE_MAX SCM_T_INT64_MAX
9248 #define SIZEOF_TYPE 8
9249 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9250 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9251 #include "libguile/conv-integer.i.c"
9253 #define TYPE scm_t_uint64
9255 #define TYPE_MAX SCM_T_UINT64_MAX
9256 #define SIZEOF_TYPE 8
9257 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9258 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9259 #include "libguile/conv-uinteger.i.c"
9262 scm_to_mpz (SCM val
, mpz_t rop
)
9264 if (SCM_I_INUMP (val
))
9265 mpz_set_si (rop
, SCM_I_INUM (val
));
9266 else if (SCM_BIGP (val
))
9267 mpz_set (rop
, SCM_I_BIG_MPZ (val
));
9269 scm_wrong_type_arg_msg (NULL
, 0, val
, "exact integer");
9273 scm_from_mpz (mpz_t val
)
9275 return scm_i_mpz2num (val
);
9279 scm_is_real (SCM val
)
9281 return scm_is_true (scm_real_p (val
));
9285 scm_is_rational (SCM val
)
9287 return scm_is_true (scm_rational_p (val
));
9291 scm_to_double (SCM val
)
9293 if (SCM_I_INUMP (val
))
9294 return SCM_I_INUM (val
);
9295 else if (SCM_BIGP (val
))
9296 return scm_i_big2dbl (val
);
9297 else if (SCM_FRACTIONP (val
))
9298 return scm_i_fraction2double (val
);
9299 else if (SCM_REALP (val
))
9300 return SCM_REAL_VALUE (val
);
9302 scm_wrong_type_arg_msg (NULL
, 0, val
, "real number");
9306 scm_from_double (double val
)
9310 z
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double
), "real"));
9312 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
9313 SCM_REAL_VALUE (z
) = val
;
9319 scm_is_complex (SCM val
)
9321 return scm_is_true (scm_complex_p (val
));
9325 scm_c_real_part (SCM z
)
9327 if (SCM_COMPLEXP (z
))
9328 return SCM_COMPLEX_REAL (z
);
9331 /* Use the scm_real_part to get proper error checking and
9334 return scm_to_double (scm_real_part (z
));
9339 scm_c_imag_part (SCM z
)
9341 if (SCM_COMPLEXP (z
))
9342 return SCM_COMPLEX_IMAG (z
);
9345 /* Use the scm_imag_part to get proper error checking and
9346 dispatching. The result will almost always be 0.0, but not
9349 return scm_to_double (scm_imag_part (z
));
9354 scm_c_magnitude (SCM z
)
9356 return scm_to_double (scm_magnitude (z
));
9362 return scm_to_double (scm_angle (z
));
9366 scm_is_number (SCM z
)
9368 return scm_is_true (scm_number_p (z
));
9372 /* Returns log(x * 2^shift) */
9374 log_of_shifted_double (double x
, long shift
)
9376 double ans
= log (fabs (x
)) + shift
* M_LN2
;
9378 if (x
> 0.0 || double_is_non_negative_zero (x
))
9379 return scm_from_double (ans
);
9381 return scm_c_make_rectangular (ans
, M_PI
);
9384 /* Returns log(n), for exact integer n of integer-length size */
9386 log_of_exact_integer_with_size (SCM n
, long size
)
9388 long shift
= size
- 2 * scm_dblprec
[0];
9391 return log_of_shifted_double
9392 (scm_to_double (scm_ash (n
, scm_from_long(-shift
))),
9395 return log_of_shifted_double (scm_to_double (n
), 0);
9398 /* Returns log(n), for exact integer n */
9400 log_of_exact_integer (SCM n
)
9402 return log_of_exact_integer_with_size
9403 (n
, scm_to_long (scm_integer_length (n
)));
9406 /* Returns log(n/d), for exact non-zero integers n and d */
9408 log_of_fraction (SCM n
, SCM d
)
9410 long n_size
= scm_to_long (scm_integer_length (n
));
9411 long d_size
= scm_to_long (scm_integer_length (d
));
9413 if (abs (n_size
- d_size
) > 1)
9414 return (scm_difference (log_of_exact_integer_with_size (n
, n_size
),
9415 log_of_exact_integer_with_size (d
, d_size
)));
9416 else if (scm_is_false (scm_negative_p (n
)))
9417 return scm_from_double
9418 (log1p (scm_to_double (scm_divide2real (scm_difference (n
, d
), d
))));
9420 return scm_c_make_rectangular
9421 (log1p (scm_to_double (scm_divide2real
9422 (scm_difference (scm_abs (n
), d
),
9428 /* In the following functions we dispatch to the real-arg funcs like log()
9429 when we know the arg is real, instead of just handing everything to
9430 clog() for instance. This is in case clog() doesn't optimize for a
9431 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
9432 well use it to go straight to the applicable C func. */
9434 SCM_PRIMITIVE_GENERIC (scm_log
, "log", 1, 0, 0,
9436 "Return the natural logarithm of @var{z}.")
9437 #define FUNC_NAME s_scm_log
9439 if (SCM_COMPLEXP (z
))
9441 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
9442 && defined (SCM_COMPLEX_VALUE)
9443 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z
)));
9445 double re
= SCM_COMPLEX_REAL (z
);
9446 double im
= SCM_COMPLEX_IMAG (z
);
9447 return scm_c_make_rectangular (log (hypot (re
, im
)),
9451 else if (SCM_REALP (z
))
9452 return log_of_shifted_double (SCM_REAL_VALUE (z
), 0);
9453 else if (SCM_I_INUMP (z
))
9455 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9456 if (scm_is_eq (z
, SCM_INUM0
))
9457 scm_num_overflow (s_scm_log
);
9459 return log_of_shifted_double (SCM_I_INUM (z
), 0);
9461 else if (SCM_BIGP (z
))
9462 return log_of_exact_integer (z
);
9463 else if (SCM_FRACTIONP (z
))
9464 return log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9465 SCM_FRACTION_DENOMINATOR (z
));
9467 return scm_wta_dispatch_1 (g_scm_log
, z
, 1, s_scm_log
);
9472 SCM_PRIMITIVE_GENERIC (scm_log10
, "log10", 1, 0, 0,
9474 "Return the base 10 logarithm of @var{z}.")
9475 #define FUNC_NAME s_scm_log10
9477 if (SCM_COMPLEXP (z
))
9479 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
9480 clog() and a multiply by M_LOG10E, rather than the fallback
9481 log10+hypot+atan2.) */
9482 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
9483 && defined SCM_COMPLEX_VALUE
9484 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z
)));
9486 double re
= SCM_COMPLEX_REAL (z
);
9487 double im
= SCM_COMPLEX_IMAG (z
);
9488 return scm_c_make_rectangular (log10 (hypot (re
, im
)),
9489 M_LOG10E
* atan2 (im
, re
));
9492 else if (SCM_REALP (z
) || SCM_I_INUMP (z
))
9494 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
9495 if (scm_is_eq (z
, SCM_INUM0
))
9496 scm_num_overflow (s_scm_log10
);
9499 double re
= scm_to_double (z
);
9500 double l
= log10 (fabs (re
));
9501 if (re
> 0.0 || double_is_non_negative_zero (re
))
9502 return scm_from_double (l
);
9504 return scm_c_make_rectangular (l
, M_LOG10E
* M_PI
);
9507 else if (SCM_BIGP (z
))
9508 return scm_product (flo_log10e
, log_of_exact_integer (z
));
9509 else if (SCM_FRACTIONP (z
))
9510 return scm_product (flo_log10e
,
9511 log_of_fraction (SCM_FRACTION_NUMERATOR (z
),
9512 SCM_FRACTION_DENOMINATOR (z
)));
9514 return scm_wta_dispatch_1 (g_scm_log10
, z
, 1, s_scm_log10
);
9519 SCM_PRIMITIVE_GENERIC (scm_exp
, "exp", 1, 0, 0,
9521 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
9522 "base of natural logarithms (2.71828@dots{}).")
9523 #define FUNC_NAME s_scm_exp
9525 if (SCM_COMPLEXP (z
))
9527 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
9528 && defined (SCM_COMPLEX_VALUE)
9529 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z
)));
9531 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z
)),
9532 SCM_COMPLEX_IMAG (z
));
9535 else if (SCM_NUMBERP (z
))
9537 /* When z is a negative bignum the conversion to double overflows,
9538 giving -infinity, but that's ok, the exp is still 0.0. */
9539 return scm_from_double (exp (scm_to_double (z
)));
9542 return scm_wta_dispatch_1 (g_scm_exp
, z
, 1, s_scm_exp
);
9547 SCM_DEFINE (scm_i_exact_integer_sqrt
, "exact-integer-sqrt", 1, 0, 0,
9549 "Return two exact non-negative integers @var{s} and @var{r}\n"
9550 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
9551 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
9552 "An error is raised if @var{k} is not an exact non-negative integer.\n"
9555 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
9557 #define FUNC_NAME s_scm_i_exact_integer_sqrt
9561 scm_exact_integer_sqrt (k
, &s
, &r
);
9562 return scm_values (scm_list_2 (s
, r
));
9567 scm_exact_integer_sqrt (SCM k
, SCM
*sp
, SCM
*rp
)
9569 if (SCM_LIKELY (SCM_I_INUMP (k
)))
9571 scm_t_inum kk
= SCM_I_INUM (k
);
9575 if (SCM_LIKELY (kk
> 0))
9580 uu
= (ss
+ kk
/ss
) / 2;
9582 *sp
= SCM_I_MAKINUM (ss
);
9583 *rp
= SCM_I_MAKINUM (kk
- ss
*ss
);
9585 else if (SCM_LIKELY (kk
== 0))
9586 *sp
= *rp
= SCM_INUM0
;
9588 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9589 "exact non-negative integer");
9591 else if (SCM_LIKELY (SCM_BIGP (k
)))
9595 if (mpz_sgn (SCM_I_BIG_MPZ (k
)) < 0)
9596 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9597 "exact non-negative integer");
9600 mpz_sqrtrem (SCM_I_BIG_MPZ (s
), SCM_I_BIG_MPZ (r
), SCM_I_BIG_MPZ (k
));
9601 scm_remember_upto_here_1 (k
);
9602 *sp
= scm_i_normbig (s
);
9603 *rp
= scm_i_normbig (r
);
9606 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1
, k
,
9607 "exact non-negative integer");
9611 SCM_PRIMITIVE_GENERIC (scm_sqrt
, "sqrt", 1, 0, 0,
9613 "Return the square root of @var{z}. Of the two possible roots\n"
9614 "(positive and negative), the one with positive real part\n"
9615 "is returned, or if that's zero then a positive imaginary part.\n"
9619 "(sqrt 9.0) @result{} 3.0\n"
9620 "(sqrt -9.0) @result{} 0.0+3.0i\n"
9621 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
9622 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
9624 #define FUNC_NAME s_scm_sqrt
9626 if (SCM_COMPLEXP (z
))
9628 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
9629 && defined SCM_COMPLEX_VALUE
9630 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z
)));
9632 double re
= SCM_COMPLEX_REAL (z
);
9633 double im
= SCM_COMPLEX_IMAG (z
);
9634 return scm_c_make_polar (sqrt (hypot (re
, im
)),
9635 0.5 * atan2 (im
, re
));
9638 else if (SCM_NUMBERP (z
))
9640 double xx
= scm_to_double (z
);
9642 return scm_c_make_rectangular (0.0, sqrt (-xx
));
9644 return scm_from_double (sqrt (xx
));
9647 return scm_wta_dispatch_1 (g_scm_sqrt
, z
, 1, s_scm_sqrt
);
9658 mpz_init_set_si (z_negative_one
, -1);
9660 /* It may be possible to tune the performance of some algorithms by using
9661 * the following constants to avoid the creation of bignums. Please, before
9662 * using these values, remember the two rules of program optimization:
9663 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
9664 scm_c_define ("most-positive-fixnum",
9665 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
9666 scm_c_define ("most-negative-fixnum",
9667 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
9669 scm_add_feature ("complex");
9670 scm_add_feature ("inexact");
9671 flo0
= scm_from_double (0.0);
9672 flo_log10e
= scm_from_double (M_LOG10E
);
9674 /* determine floating point precision */
9675 for (i
=2; i
<= SCM_MAX_DBL_RADIX
; ++i
)
9677 init_dblprec(&scm_dblprec
[i
-2],i
);
9678 init_fx_radix(fx_per_radix
[i
-2],i
);
9681 /* hard code precision for base 10 if the preprocessor tells us to... */
9682 scm_dblprec
[10-2] = (DBL_DIG
> 20) ? 20 : DBL_DIG
;
9685 exactly_one_half
= scm_divide (SCM_INUM1
, SCM_I_MAKINUM (2));
9686 #include "libguile/numbers.x"