1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004 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
9 * License as published by the Free Software Foundation; either
10 * version 2.1 of the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful,
13 * but 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23 /* General assumptions:
24 * All objects satisfying SCM_COMPLEXP() have a non-zero complex component.
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 * All objects satisfying SCM_FRACTIONP are never an integer.
33 - see if special casing bignums and reals in integer-exponent when
34 possible (to use mpz_pow and mpf_pow_ui) is faster.
36 - look in to better short-circuiting of common cases in
37 integer-expt and elsewhere.
39 - see if direct mpz operations can help in ash and elsewhere.
43 /* tell glibc (2.3) to give prototype for C99 trunc() */
55 #include "libguile/_scm.h"
56 #include "libguile/feature.h"
57 #include "libguile/ports.h"
58 #include "libguile/root.h"
59 #include "libguile/smob.h"
60 #include "libguile/strings.h"
62 #include "libguile/validate.h"
63 #include "libguile/numbers.h"
64 #include "libguile/deprecation.h"
66 #include "libguile/eq.h"
71 Wonder if this might be faster for some of our code? A switch on
72 the numtag would jump directly to the right case, and the
73 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
75 #define SCM_I_NUMTAG_NOTNUM 0
76 #define SCM_I_NUMTAG_INUM 1
77 #define SCM_I_NUMTAG_BIG scm_tc16_big
78 #define SCM_I_NUMTAG_REAL scm_tc16_real
79 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
80 #define SCM_I_NUMTAG(x) \
81 (SCM_INUMP(x) ? SCM_I_NUMTAG_INUM \
82 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
83 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
84 : SCM_I_NUMTAG_NOTNUM)))
86 /* the macro above will not work as is with fractions */
89 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
91 /* FLOBUFLEN is the maximum number of characters neccessary for the
92 * printed or scm_string representation of an inexact number.
94 #define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
97 #if ! defined (HAVE_ISNAN)
102 return (IsNANorINF (x
) && NaN (x
) && ! IsINF (x
)) ? 1 : 0;
105 #if ! defined (HAVE_ISINF)
110 return (IsNANorINF (x
) && IsINF (x
)) ? 1 : 0;
117 /* mpz_cmp_d only recognises infinities in gmp 4.2 and up.
118 For prior versions use an explicit check here. */
119 #if __GNU_MP_VERSION < 4 \
120 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2)
121 #define xmpz_cmp_d(z, d) \
122 (xisinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
124 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
130 #if defined (HAVE_ISINF)
132 #elif defined (HAVE_FINITE) && defined (HAVE_ISNAN)
133 return (! (finite (x
) || isnan (x
)));
142 #if defined (HAVE_ISNAN)
151 static mpz_t z_negative_one
;
155 SCM_C_INLINE_KEYWORD SCM
158 /* Return a newly created bignum. */
159 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
160 mpz_init (SCM_I_BIG_MPZ (z
));
164 SCM_C_INLINE_KEYWORD
static SCM
165 scm_i_clonebig (SCM src_big
, int same_sign_p
)
167 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
168 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
169 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
171 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
175 SCM_C_INLINE_KEYWORD
int
176 scm_i_bigcmp (SCM x
, SCM y
)
178 /* Return neg if x < y, pos if x > y, and 0 if x == y */
179 /* presume we already know x and y are bignums */
180 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
181 scm_remember_upto_here_2 (x
, y
);
185 SCM_C_INLINE_KEYWORD SCM
186 scm_i_dbl2big (double d
)
188 /* results are only defined if d is an integer */
189 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
190 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
194 /* Convert a integer in double representation to a SCM number. */
196 SCM_C_INLINE_KEYWORD SCM
197 scm_i_dbl2num (double u
)
199 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
200 powers of 2, so there's no rounding when making "double" values
201 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
202 get rounded on a 64-bit machine, hence the "+1".
204 The use of floor() to force to an integer value ensures we get a
205 "numerically closest" value without depending on how a
206 double->long cast or how mpz_set_d will round. For reference,
207 double->long probably follows the hardware rounding mode,
208 mpz_set_d truncates towards zero. */
210 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
211 representable as a double? */
213 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
214 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
215 return SCM_MAKINUM ((long) u
);
217 return scm_i_dbl2big (u
);
220 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
221 with R5RS exact->inexact.
223 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
224 (ie. it truncates towards zero), then adjust to get the closest double by
225 examining the next lower bit and adding 1 if necessary.
227 Note that bignums exactly half way between representable doubles are
228 rounded to the next higher absolute value (ie. away from zero). This
229 seems like an adequate interpretation of R5RS "numerically closest", and
230 it's easier and faster than a full "nearest-even" style.
232 The bit test is done on the absolute value of the mpz_t, which means we
233 must use mpz_getlimbn. mpz_tstbit is not right, it treats negatives as
236 Prior to GMP 4.2, the rounding done by mpz_get_d was unspecified. It
237 happened to follow the hardware rounding mode, but on the absolute value
238 of its operand. This is not what we want, so we put the high
239 DBL_MANT_DIG bits into a temporary. This extra init/clear is a slowdown,
240 but doesn't matter too much since it's only for older GMP. */
243 scm_i_big2dbl (SCM b
)
248 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
250 #if __GNU_MP_VERSION < 4 \
251 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2)
253 /* GMP prior to 4.2, force truncate towards zero */
255 if (bits
> DBL_MANT_DIG
)
257 size_t shift
= bits
- DBL_MANT_DIG
;
258 mpz_init2 (tmp
, DBL_MANT_DIG
);
259 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
260 result
= ldexp (mpz_get_d (tmp
), shift
);
265 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
270 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
273 if (bits
> DBL_MANT_DIG
)
275 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
276 /* test bit number "pos" in absolute value */
277 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
278 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
280 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
284 scm_remember_upto_here_1 (b
);
288 SCM_C_INLINE_KEYWORD SCM
289 scm_i_normbig (SCM b
)
291 /* convert a big back to a fixnum if it'll fit */
292 /* presume b is a bignum */
293 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
295 long val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
296 if (SCM_FIXABLE (val
))
297 b
= SCM_MAKINUM (val
);
302 static SCM_C_INLINE_KEYWORD SCM
303 scm_i_mpz2num (mpz_t b
)
305 /* convert a mpz number to a SCM number. */
306 if (mpz_fits_slong_p (b
))
308 long val
= mpz_get_si (b
);
309 if (SCM_FIXABLE (val
))
310 return SCM_MAKINUM (val
);
314 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
315 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
320 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
321 static SCM
scm_divide2real (SCM x
, SCM y
);
324 scm_make_ratio (SCM numerator
, SCM denominator
)
325 #define FUNC_NAME "make-ratio"
327 /* First make sure the arguments are proper.
329 if (SCM_INUMP (denominator
))
331 if (SCM_EQ_P (denominator
, SCM_INUM0
))
332 scm_num_overflow ("make-ratio");
333 if (SCM_EQ_P (denominator
, SCM_MAKINUM(1)))
338 if (!(SCM_BIGP(denominator
)))
339 SCM_WRONG_TYPE_ARG (2, denominator
);
341 if (!SCM_INUMP (numerator
) && !SCM_BIGP (numerator
))
342 SCM_WRONG_TYPE_ARG (1, numerator
);
344 /* Then flip signs so that the denominator is positive.
346 if (SCM_NFALSEP (scm_negative_p (denominator
)))
348 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
349 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
352 /* Now consider for each of the four fixnum/bignum combinations
353 whether the rational number is really an integer.
355 if (SCM_INUMP (numerator
))
357 long x
= SCM_INUM (numerator
);
358 if (SCM_EQ_P (numerator
, SCM_INUM0
))
360 if (SCM_INUMP (denominator
))
363 y
= SCM_INUM (denominator
);
365 return SCM_MAKINUM(1);
367 return SCM_MAKINUM (x
/ y
);
371 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
372 of that value for the denominator, as a bignum. Apart from
373 that case, abs(bignum) > abs(inum) so inum/bignum is not an
375 if (x
== SCM_MOST_NEGATIVE_FIXNUM
376 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
377 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
378 return SCM_MAKINUM(-1);
381 else if (SCM_BIGP (numerator
))
383 if (SCM_INUMP (denominator
))
385 long yy
= SCM_INUM (denominator
);
386 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
387 return scm_divide (numerator
, denominator
);
391 if (SCM_EQ_P (numerator
, denominator
))
392 return SCM_MAKINUM(1);
393 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
394 SCM_I_BIG_MPZ (denominator
)))
395 return scm_divide(numerator
, denominator
);
399 /* No, it's a proper fraction.
401 return scm_double_cell (scm_tc16_fraction
,
402 SCM_UNPACK (numerator
),
403 SCM_UNPACK (denominator
), 0);
407 static void scm_i_fraction_reduce (SCM z
)
409 if (!(SCM_FRACTION_REDUCED (z
)))
412 divisor
= scm_gcd (SCM_FRACTION_NUMERATOR (z
), SCM_FRACTION_DENOMINATOR (z
));
413 if (!(SCM_EQ_P (divisor
, SCM_MAKINUM(1))))
416 SCM_FRACTION_SET_NUMERATOR (z
, scm_divide (SCM_FRACTION_NUMERATOR (z
), divisor
));
417 SCM_FRACTION_SET_DENOMINATOR (z
, scm_divide (SCM_FRACTION_DENOMINATOR (z
), divisor
));
419 SCM_FRACTION_REDUCED_SET (z
);
424 scm_i_fraction2double (SCM z
)
426 return scm_num2dbl (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
427 SCM_FRACTION_DENOMINATOR (z
)),
431 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
433 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
435 #define FUNC_NAME s_scm_exact_p
441 if (SCM_FRACTIONP (x
))
445 SCM_WRONG_TYPE_ARG (1, x
);
450 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
452 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
454 #define FUNC_NAME s_scm_odd_p
458 long val
= SCM_INUM (n
);
459 return SCM_BOOL ((val
& 1L) != 0);
461 else if (SCM_BIGP (n
))
463 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
464 scm_remember_upto_here_1 (n
);
465 return SCM_BOOL (odd_p
);
467 else if (!SCM_FALSEP (scm_inf_p (n
)))
469 else if (SCM_REALP (n
))
471 double rem
= fabs (fmod (SCM_REAL_VALUE(n
), 2.0));
477 SCM_WRONG_TYPE_ARG (1, n
);
480 SCM_WRONG_TYPE_ARG (1, n
);
485 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
487 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
489 #define FUNC_NAME s_scm_even_p
493 long val
= SCM_INUM (n
);
494 return SCM_BOOL ((val
& 1L) == 0);
496 else if (SCM_BIGP (n
))
498 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
499 scm_remember_upto_here_1 (n
);
500 return SCM_BOOL (even_p
);
502 else if (!SCM_FALSEP (scm_inf_p (n
)))
504 else if (SCM_REALP (n
))
506 double rem
= fabs (fmod (SCM_REAL_VALUE(n
), 2.0));
512 SCM_WRONG_TYPE_ARG (1, n
);
515 SCM_WRONG_TYPE_ARG (1, n
);
519 SCM_DEFINE (scm_inf_p
, "inf?", 1, 0, 0,
521 "Return @code{#t} if @var{n} is infinite, @code{#f}\n"
523 #define FUNC_NAME s_scm_inf_p
526 return SCM_BOOL (xisinf (SCM_REAL_VALUE (n
)));
527 else if (SCM_COMPLEXP (n
))
528 return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n
))
529 || xisinf (SCM_COMPLEX_IMAG (n
)));
535 SCM_DEFINE (scm_nan_p
, "nan?", 1, 0, 0,
537 "Return @code{#t} if @var{n} is a NaN, @code{#f}\n"
539 #define FUNC_NAME s_scm_nan_p
542 return SCM_BOOL (xisnan (SCM_REAL_VALUE (n
)));
543 else if (SCM_COMPLEXP (n
))
544 return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n
))
545 || xisnan (SCM_COMPLEX_IMAG (n
)));
551 /* Guile's idea of infinity. */
552 static double guile_Inf
;
554 /* Guile's idea of not a number. */
555 static double guile_NaN
;
558 guile_ieee_init (void)
560 #if defined (HAVE_ISINF) || defined (HAVE_FINITE)
562 /* Some version of gcc on some old version of Linux used to crash when
563 trying to make Inf and NaN. */
566 /* C99 INFINITY, when available.
567 FIXME: The standard allows for INFINITY to be something that overflows
568 at compile time. We ought to have a configure test to check for that
569 before trying to use it. (But in practice we believe this is not a
570 problem on any system guile is likely to target.) */
571 guile_Inf
= INFINITY
;
574 extern unsigned int DINFINITY
[2];
575 guile_Inf
= (*(X_CAST(double *, DINFINITY
)));
582 if (guile_Inf
== tmp
)
590 #if defined (HAVE_ISNAN)
593 /* C99 NAN, when available */
597 extern unsigned int DQNAN
[2];
598 guile_NaN
= (*(X_CAST(double *, DQNAN
)));
600 guile_NaN
= guile_Inf
/ guile_Inf
;
606 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
609 #define FUNC_NAME s_scm_inf
611 static int initialized
= 0;
617 return scm_make_real (guile_Inf
);
621 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
624 #define FUNC_NAME s_scm_nan
626 static int initialized
= 0;
632 return scm_make_real (guile_NaN
);
637 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
639 "Return the absolute value of @var{x}.")
644 long int xx
= SCM_INUM (x
);
647 else if (SCM_POSFIXABLE (-xx
))
648 return SCM_MAKINUM (-xx
);
650 return scm_i_long2big (-xx
);
652 else if (SCM_BIGP (x
))
654 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
656 return scm_i_clonebig (x
, 0);
660 else if (SCM_REALP (x
))
662 /* note that if x is a NaN then xx<0 is false so we return x unchanged */
663 double xx
= SCM_REAL_VALUE (x
);
665 return scm_make_real (-xx
);
669 else if (SCM_FRACTIONP (x
))
671 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
673 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
674 SCM_FRACTION_DENOMINATOR (x
));
677 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
682 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
683 /* "Return the quotient of the numbers @var{x} and @var{y}."
686 scm_quotient (SCM x
, SCM y
)
690 long xx
= SCM_INUM (x
);
693 long yy
= SCM_INUM (y
);
695 scm_num_overflow (s_quotient
);
700 return SCM_MAKINUM (z
);
702 return scm_i_long2big (z
);
705 else if (SCM_BIGP (y
))
707 if ((SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
)
708 && (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
709 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
711 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
712 scm_remember_upto_here_1 (y
);
713 return SCM_MAKINUM (-1);
716 return SCM_MAKINUM (0);
719 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
721 else if (SCM_BIGP (x
))
725 long yy
= SCM_INUM (y
);
727 scm_num_overflow (s_quotient
);
732 SCM result
= scm_i_mkbig ();
735 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result
),
738 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
741 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
742 scm_remember_upto_here_1 (x
);
743 return scm_i_normbig (result
);
746 else if (SCM_BIGP (y
))
748 SCM result
= scm_i_mkbig ();
749 mpz_tdiv_q (SCM_I_BIG_MPZ (result
),
752 scm_remember_upto_here_2 (x
, y
);
753 return scm_i_normbig (result
);
756 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
759 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
762 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
763 /* "Return the remainder of the numbers @var{x} and @var{y}.\n"
765 * "(remainder 13 4) @result{} 1\n"
766 * "(remainder -13 4) @result{} -1\n"
770 scm_remainder (SCM x
, SCM y
)
776 long yy
= SCM_INUM (y
);
778 scm_num_overflow (s_remainder
);
781 long z
= SCM_INUM (x
) % yy
;
782 return SCM_MAKINUM (z
);
785 else if (SCM_BIGP (y
))
787 if ((SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
)
788 && (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
789 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
791 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
792 scm_remember_upto_here_1 (y
);
793 return SCM_MAKINUM (0);
799 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
801 else if (SCM_BIGP (x
))
805 long yy
= SCM_INUM (y
);
807 scm_num_overflow (s_remainder
);
810 SCM result
= scm_i_mkbig ();
813 mpz_tdiv_r_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ(x
), yy
);
814 scm_remember_upto_here_1 (x
);
815 return scm_i_normbig (result
);
818 else if (SCM_BIGP (y
))
820 SCM result
= scm_i_mkbig ();
821 mpz_tdiv_r (SCM_I_BIG_MPZ (result
),
824 scm_remember_upto_here_2 (x
, y
);
825 return scm_i_normbig (result
);
828 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
831 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
835 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
836 /* "Return the modulo of the numbers @var{x} and @var{y}.\n"
838 * "(modulo 13 4) @result{} 1\n"
839 * "(modulo -13 4) @result{} 3\n"
843 scm_modulo (SCM x
, SCM y
)
847 long xx
= SCM_INUM (x
);
850 long yy
= SCM_INUM (y
);
852 scm_num_overflow (s_modulo
);
855 /* FIXME: I think this may be a bug on some arches -- results
856 of % with negative second arg are undefined... */
874 return SCM_MAKINUM (result
);
877 else if (SCM_BIGP (y
))
879 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
886 SCM pos_y
= scm_i_clonebig (y
, 0);
887 /* do this after the last scm_op */
888 mpz_init_set_si (z_x
, xx
);
889 result
= pos_y
; /* re-use this bignum */
890 mpz_mod (SCM_I_BIG_MPZ (result
),
892 SCM_I_BIG_MPZ (pos_y
));
893 scm_remember_upto_here_1 (pos_y
);
897 result
= scm_i_mkbig ();
898 /* do this after the last scm_op */
899 mpz_init_set_si (z_x
, xx
);
900 mpz_mod (SCM_I_BIG_MPZ (result
),
903 scm_remember_upto_here_1 (y
);
906 if ((sgn_y
< 0) && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
907 mpz_add (SCM_I_BIG_MPZ (result
),
909 SCM_I_BIG_MPZ (result
));
910 scm_remember_upto_here_1 (y
);
911 /* and do this before the next one */
913 return scm_i_normbig (result
);
917 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
919 else if (SCM_BIGP (x
))
923 long yy
= SCM_INUM (y
);
925 scm_num_overflow (s_modulo
);
928 SCM result
= scm_i_mkbig ();
929 mpz_mod_ui (SCM_I_BIG_MPZ (result
),
931 (yy
< 0) ? - yy
: yy
);
932 scm_remember_upto_here_1 (x
);
933 if ((yy
< 0) && (mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0))
934 mpz_sub_ui (SCM_I_BIG_MPZ (result
),
935 SCM_I_BIG_MPZ (result
),
937 return scm_i_normbig (result
);
940 else if (SCM_BIGP (y
))
943 SCM result
= scm_i_mkbig ();
944 int y_sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
945 SCM pos_y
= scm_i_clonebig (y
, y_sgn
>= 0);
946 mpz_mod (SCM_I_BIG_MPZ (result
),
948 SCM_I_BIG_MPZ (pos_y
));
950 scm_remember_upto_here_1 (x
);
951 if ((y_sgn
< 0) && (mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0))
952 mpz_add (SCM_I_BIG_MPZ (result
),
954 SCM_I_BIG_MPZ (result
));
955 scm_remember_upto_here_2 (y
, pos_y
);
956 return scm_i_normbig (result
);
960 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
963 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
966 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
967 /* "Return the greatest common divisor of all arguments.\n"
968 * "If called without arguments, 0 is returned."
971 scm_gcd (SCM x
, SCM y
)
974 return SCM_UNBNDP (x
) ? SCM_INUM0
: x
;
980 long xx
= SCM_INUM (x
);
981 long yy
= SCM_INUM (y
);
982 long u
= xx
< 0 ? -xx
: xx
;
983 long v
= yy
< 0 ? -yy
: yy
;
993 /* Determine a common factor 2^k */
994 while (!(1 & (u
| v
)))
1000 /* Now, any factor 2^n can be eliminated */
1020 return (SCM_POSFIXABLE (result
)
1021 ? SCM_MAKINUM (result
)
1022 : scm_i_long2big (result
));
1024 else if (SCM_BIGP (y
))
1026 SCM result
= scm_i_mkbig ();
1027 SCM mx
= scm_i_mkbig ();
1028 mpz_set_si (SCM_I_BIG_MPZ (mx
), SCM_INUM (x
));
1029 scm_remember_upto_here_1 (x
);
1030 mpz_gcd (SCM_I_BIG_MPZ (result
),
1033 scm_remember_upto_here_2 (mx
, y
);
1034 return scm_i_normbig (result
);
1037 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
1039 else if (SCM_BIGP (x
))
1043 unsigned long result
;
1044 long yy
= SCM_INUM (y
);
1049 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
1050 scm_remember_upto_here_1 (x
);
1051 return (SCM_POSFIXABLE (result
)
1052 ? SCM_MAKINUM (result
)
1053 : scm_ulong2num (result
));
1055 else if (SCM_BIGP (y
))
1057 SCM result
= scm_i_mkbig ();
1058 mpz_gcd (SCM_I_BIG_MPZ (result
),
1061 scm_remember_upto_here_2 (x
, y
);
1062 return scm_i_normbig (result
);
1065 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
1068 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
1071 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
1072 /* "Return the least common multiple of the arguments.\n"
1073 * "If called without arguments, 1 is returned."
1076 scm_lcm (SCM n1
, SCM n2
)
1078 if (SCM_UNBNDP (n2
))
1080 if (SCM_UNBNDP (n1
))
1081 return SCM_MAKINUM (1L);
1082 n2
= SCM_MAKINUM (1L);
1085 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
1086 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
1087 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
1088 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
1094 SCM d
= scm_gcd (n1
, n2
);
1095 if (SCM_EQ_P (d
, SCM_INUM0
))
1098 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
1102 /* inum n1, big n2 */
1105 SCM result
= scm_i_mkbig ();
1106 long nn1
= SCM_INUM (n1
);
1107 if (nn1
== 0) return SCM_INUM0
;
1108 if (nn1
< 0) nn1
= - nn1
;
1109 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
1110 scm_remember_upto_here_1 (n2
);
1125 SCM result
= scm_i_mkbig ();
1126 mpz_lcm(SCM_I_BIG_MPZ (result
),
1128 SCM_I_BIG_MPZ (n2
));
1129 scm_remember_upto_here_2(n1
, n2
);
1130 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
1136 #ifndef scm_long2num
1137 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
1139 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
1142 /* Emulating 2's complement bignums with sign magnitude arithmetic:
1147 + + + x (map digit:logand X Y)
1148 + - + x (map digit:logand X (lognot (+ -1 Y)))
1149 - + + y (map digit:logand (lognot (+ -1 X)) Y)
1150 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
1155 + + + (map digit:logior X Y)
1156 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
1157 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
1158 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
1163 + + + (map digit:logxor X Y)
1164 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
1165 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
1166 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
1171 + + (any digit:logand X Y)
1172 + - (any digit:logand X (lognot (+ -1 Y)))
1173 - + (any digit:logand (lognot (+ -1 X)) Y)
1178 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
1180 "Return the bitwise AND of the integer arguments.\n\n"
1182 "(logand) @result{} -1\n"
1183 "(logand 7) @result{} 7\n"
1184 "(logand #b111 #b011 #b001) @result{} 1\n"
1186 #define FUNC_NAME s_scm_logand
1190 if (SCM_UNBNDP (n2
))
1192 if (SCM_UNBNDP (n1
))
1193 return SCM_MAKINUM (-1);
1194 else if (!SCM_NUMBERP (n1
))
1195 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1196 else if (SCM_NUMBERP (n1
))
1199 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1204 nn1
= SCM_INUM (n1
);
1207 long nn2
= SCM_INUM (n2
);
1208 return SCM_MAKINUM (nn1
& nn2
);
1210 else if SCM_BIGP (n2
)
1216 SCM result_z
= scm_i_mkbig ();
1218 mpz_init_set_si (nn1_z
, nn1
);
1219 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
1220 scm_remember_upto_here_1 (n2
);
1222 return scm_i_normbig (result_z
);
1226 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1228 else if (SCM_BIGP (n1
))
1233 nn1
= SCM_INUM (n1
);
1236 else if (SCM_BIGP (n2
))
1238 SCM result_z
= scm_i_mkbig ();
1239 mpz_and (SCM_I_BIG_MPZ (result_z
),
1241 SCM_I_BIG_MPZ (n2
));
1242 scm_remember_upto_here_2 (n1
, n2
);
1243 return scm_i_normbig (result_z
);
1246 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1249 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1254 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
1256 "Return the bitwise OR of the integer arguments.\n\n"
1258 "(logior) @result{} 0\n"
1259 "(logior 7) @result{} 7\n"
1260 "(logior #b000 #b001 #b011) @result{} 3\n"
1262 #define FUNC_NAME s_scm_logior
1266 if (SCM_UNBNDP (n2
))
1268 if (SCM_UNBNDP (n1
))
1270 else if (SCM_NUMBERP (n1
))
1273 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1278 nn1
= SCM_INUM (n1
);
1281 long nn2
= SCM_INUM (n2
);
1282 return SCM_MAKINUM (nn1
| nn2
);
1284 else if (SCM_BIGP (n2
))
1290 SCM result_z
= scm_i_mkbig ();
1292 mpz_init_set_si (nn1_z
, nn1
);
1293 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
1294 scm_remember_upto_here_1 (n2
);
1300 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1302 else if (SCM_BIGP (n1
))
1307 nn1
= SCM_INUM (n1
);
1310 else if (SCM_BIGP (n2
))
1312 SCM result_z
= scm_i_mkbig ();
1313 mpz_ior (SCM_I_BIG_MPZ (result_z
),
1315 SCM_I_BIG_MPZ (n2
));
1316 scm_remember_upto_here_2 (n1
, n2
);
1320 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1323 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1328 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
1330 "Return the bitwise XOR of the integer arguments. A bit is\n"
1331 "set in the result if it is set in an odd number of arguments.\n"
1333 "(logxor) @result{} 0\n"
1334 "(logxor 7) @result{} 7\n"
1335 "(logxor #b000 #b001 #b011) @result{} 2\n"
1336 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
1338 #define FUNC_NAME s_scm_logxor
1342 if (SCM_UNBNDP (n2
))
1344 if (SCM_UNBNDP (n1
))
1346 else if (SCM_NUMBERP (n1
))
1349 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1354 nn1
= SCM_INUM (n1
);
1357 long nn2
= SCM_INUM (n2
);
1358 return SCM_MAKINUM (nn1
^ nn2
);
1360 else if (SCM_BIGP (n2
))
1364 SCM result_z
= scm_i_mkbig ();
1366 mpz_init_set_si (nn1_z
, nn1
);
1367 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
1368 scm_remember_upto_here_1 (n2
);
1370 return scm_i_normbig (result_z
);
1374 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1376 else if (SCM_BIGP (n1
))
1381 nn1
= SCM_INUM (n1
);
1384 else if (SCM_BIGP (n2
))
1386 SCM result_z
= scm_i_mkbig ();
1387 mpz_xor (SCM_I_BIG_MPZ (result_z
),
1389 SCM_I_BIG_MPZ (n2
));
1390 scm_remember_upto_here_2 (n1
, n2
);
1391 return scm_i_normbig (result_z
);
1394 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1397 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1402 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
1405 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
1406 "(logtest #b0100 #b1011) @result{} #f\n"
1407 "(logtest #b0100 #b0111) @result{} #t\n"
1409 #define FUNC_NAME s_scm_logtest
1418 long nk
= SCM_INUM (k
);
1419 return SCM_BOOL (nj
& nk
);
1421 else if (SCM_BIGP (k
))
1429 mpz_init_set_si (nj_z
, nj
);
1430 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
1431 scm_remember_upto_here_1 (k
);
1432 result
= SCM_BOOL (mpz_sgn (nj_z
) != 0);
1438 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1440 else if (SCM_BIGP (j
))
1448 else if (SCM_BIGP (k
))
1452 mpz_init (result_z
);
1456 scm_remember_upto_here_2 (j
, k
);
1457 result
= SCM_BOOL (mpz_sgn (result_z
) != 0);
1458 mpz_clear (result_z
);
1462 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1465 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
1470 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
1473 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1474 "(logbit? 0 #b1101) @result{} #t\n"
1475 "(logbit? 1 #b1101) @result{} #f\n"
1476 "(logbit? 2 #b1101) @result{} #t\n"
1477 "(logbit? 3 #b1101) @result{} #t\n"
1478 "(logbit? 4 #b1101) @result{} #f\n"
1480 #define FUNC_NAME s_scm_logbit_p
1482 unsigned long int iindex
;
1484 SCM_VALIDATE_INUM_MIN (SCM_ARG1
, index
, 0);
1485 iindex
= (unsigned long int) SCM_INUM (index
);
1488 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1489 else if (SCM_BIGP (j
))
1491 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
1492 scm_remember_upto_here_1 (j
);
1493 return SCM_BOOL (val
);
1496 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1501 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1503 "Return the integer which is the ones-complement of the integer\n"
1507 "(number->string (lognot #b10000000) 2)\n"
1508 " @result{} \"-10000001\"\n"
1509 "(number->string (lognot #b0) 2)\n"
1510 " @result{} \"-1\"\n"
1512 #define FUNC_NAME s_scm_lognot
1514 if (SCM_INUMP (n
)) {
1515 /* No overflow here, just need to toggle all the bits making up the inum.
1516 Enhancement: No need to strip the tag and add it back, could just xor
1517 a block of 1 bits, if that worked with the various debug versions of
1519 return SCM_MAKINUM (~ SCM_INUM (n
));
1521 } else if (SCM_BIGP (n
)) {
1522 SCM result
= scm_i_mkbig ();
1523 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
1524 scm_remember_upto_here_1 (n
);
1528 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1533 /* returns 0 if IN is not an integer. OUT must already be
1536 coerce_to_big (SCM in
, mpz_t out
)
1539 mpz_set (out
, SCM_I_BIG_MPZ (in
));
1540 else if (SCM_INUMP (in
))
1541 mpz_set_si (out
, SCM_INUM (in
));
1548 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
1549 (SCM n
, SCM k
, SCM m
),
1550 "Return @var{n} raised to the integer exponent\n"
1551 "@var{k}, modulo @var{m}.\n"
1554 "(modulo-expt 2 3 5)\n"
1557 #define FUNC_NAME s_scm_modulo_expt
1563 /* There are two classes of error we might encounter --
1564 1) Math errors, which we'll report by calling scm_num_overflow,
1566 2) wrong-type errors, which of course we'll report by calling
1568 We don't report those errors immediately, however; instead we do
1569 some cleanup first. These variables tell us which error (if
1570 any) we should report after cleaning up.
1572 int report_overflow
= 0;
1574 int position_of_wrong_type
= 0;
1575 SCM value_of_wrong_type
= SCM_INUM0
;
1577 SCM result
= SCM_UNDEFINED
;
1583 if (SCM_EQ_P (m
, SCM_INUM0
))
1585 report_overflow
= 1;
1589 if (!coerce_to_big (n
, n_tmp
))
1591 value_of_wrong_type
= n
;
1592 position_of_wrong_type
= 1;
1596 if (!coerce_to_big (k
, k_tmp
))
1598 value_of_wrong_type
= k
;
1599 position_of_wrong_type
= 2;
1603 if (!coerce_to_big (m
, m_tmp
))
1605 value_of_wrong_type
= m
;
1606 position_of_wrong_type
= 3;
1610 /* if the exponent K is negative, and we simply call mpz_powm, we
1611 will get a divide-by-zero exception when an inverse 1/n mod m
1612 doesn't exist (or is not unique). Since exceptions are hard to
1613 handle, we'll attempt the inversion "by hand" -- that way, we get
1614 a simple failure code, which is easy to handle. */
1616 if (-1 == mpz_sgn (k_tmp
))
1618 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
1620 report_overflow
= 1;
1623 mpz_neg (k_tmp
, k_tmp
);
1626 result
= scm_i_mkbig ();
1627 mpz_powm (SCM_I_BIG_MPZ (result
),
1632 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
1633 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
1640 if (report_overflow
)
1641 scm_num_overflow (FUNC_NAME
);
1643 if (position_of_wrong_type
)
1644 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
1645 value_of_wrong_type
);
1647 return scm_i_normbig (result
);
1651 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1653 "Return @var{n} raised to the non-negative integer exponent\n"
1657 "(integer-expt 2 5)\n"
1659 "(integer-expt -3 3)\n"
1662 #define FUNC_NAME s_scm_integer_expt
1665 SCM z_i2
= SCM_BOOL_F
;
1667 SCM acc
= SCM_MAKINUM (1L);
1669 /* 0^0 == 1 according to R5RS */
1670 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1671 return SCM_FALSEP (scm_zero_p(k
)) ? n
: acc
;
1672 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1673 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1677 else if (SCM_BIGP (k
))
1679 z_i2
= scm_i_clonebig (k
, 1);
1680 scm_remember_upto_here_1 (k
);
1683 else if (SCM_REALP (k
))
1685 double r
= SCM_REAL_VALUE (k
);
1687 SCM_WRONG_TYPE_ARG (2, k
);
1688 if ((r
> SCM_MOST_POSITIVE_FIXNUM
) || (r
< SCM_MOST_NEGATIVE_FIXNUM
))
1690 z_i2
= scm_i_mkbig ();
1691 mpz_set_d (SCM_I_BIG_MPZ (z_i2
), r
);
1700 SCM_WRONG_TYPE_ARG (2, k
);
1704 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
1706 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
1707 n
= scm_divide (n
, SCM_UNDEFINED
);
1711 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
1715 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
1717 return scm_product (acc
, n
);
1719 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
1720 acc
= scm_product (acc
, n
);
1721 n
= scm_product (n
, n
);
1722 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
1730 n
= scm_divide (n
, SCM_UNDEFINED
);
1737 return scm_product (acc
, n
);
1739 acc
= scm_product (acc
, n
);
1740 n
= scm_product (n
, n
);
1747 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1749 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
1750 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
1752 "This is effectively a multiplication by 2^@var{cnt}}, and when\n"
1753 "@var{cnt} is negative it's a division, rounded towards negative\n"
1754 "infinity. (Note that this is not the same rounding as\n"
1755 "@code{quotient} does.)\n"
1757 "With @var{n} viewed as an infinite precision twos complement,\n"
1758 "@code{ash} means a left shift introducing zero bits, or a right\n"
1759 "shift dropping bits.\n"
1762 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1763 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
1765 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
1766 "(ash -23 -2) @result{} -6\n"
1768 #define FUNC_NAME s_scm_ash
1772 SCM_VALIDATE_INUM (2, cnt
);
1774 bits_to_shift
= SCM_INUM (cnt
);
1776 if (bits_to_shift
< 0)
1778 /* Shift right by abs(cnt) bits. This is realized as a division
1779 by div:=2^abs(cnt). However, to guarantee the floor
1780 rounding, negative values require some special treatment.
1782 SCM div
= scm_integer_expt (SCM_MAKINUM (2),
1783 SCM_MAKINUM (-bits_to_shift
));
1785 /* scm_quotient assumes its arguments are integers, but it's legal to (ash 1/2 -1) */
1786 if (SCM_FALSEP (scm_negative_p (n
)))
1787 return scm_quotient (n
, div
);
1789 return scm_sum (SCM_MAKINUM (-1L),
1790 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1793 /* Shift left is done by multiplication with 2^CNT */
1794 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1799 #define MIN(x,y) ((x) < (y) ? (x) : (y))
1801 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1802 (SCM n
, SCM start
, SCM end
),
1803 "Return the integer composed of the @var{start} (inclusive)\n"
1804 "through @var{end} (exclusive) bits of @var{n}. The\n"
1805 "@var{start}th bit becomes the 0-th bit in the result.\n"
1808 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1809 " @result{} \"1010\"\n"
1810 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1811 " @result{} \"10110\"\n"
1813 #define FUNC_NAME s_scm_bit_extract
1815 unsigned long int istart
, iend
, bits
;
1816 SCM_VALIDATE_INUM_MIN_COPY (2, start
,0, istart
);
1817 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1818 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1820 /* how many bits to keep */
1821 bits
= iend
- istart
;
1825 long int in
= SCM_INUM (n
);
1827 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
1828 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in".
1829 FIXME: This shift relies on signed right shifts being arithmetic,
1830 which is not guaranteed by C99. */
1831 in
>>= MIN (istart
, SCM_I_FIXNUM_BIT
-1);
1833 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
1835 /* Since we emulate two's complement encoded numbers, this
1836 * special case requires us to produce a result that has
1837 * more bits than can be stored in a fixnum.
1839 SCM result
= scm_i_long2big (in
);
1840 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
1845 /* mask down to requisite bits */
1846 bits
= MIN (bits
, SCM_I_FIXNUM_BIT
);
1847 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1849 else if (SCM_BIGP (n
))
1854 result
= SCM_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
1858 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
1859 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
1860 such bits into a ulong. */
1861 result
= scm_i_mkbig ();
1862 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
1863 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
1864 result
= scm_i_normbig (result
);
1866 scm_remember_upto_here_1 (n
);
1870 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1875 static const char scm_logtab
[] = {
1876 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1879 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1881 "Return the number of bits in integer @var{n}. If integer is\n"
1882 "positive, the 1-bits in its binary representation are counted.\n"
1883 "If negative, the 0-bits in its two's-complement binary\n"
1884 "representation are counted. If 0, 0 is returned.\n"
1887 "(logcount #b10101010)\n"
1894 #define FUNC_NAME s_scm_logcount
1898 unsigned long int c
= 0;
1899 long int nn
= SCM_INUM (n
);
1904 c
+= scm_logtab
[15 & nn
];
1907 return SCM_MAKINUM (c
);
1909 else if (SCM_BIGP (n
))
1911 unsigned long count
;
1912 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
1913 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
1915 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
1916 scm_remember_upto_here_1 (n
);
1917 return SCM_MAKINUM (count
);
1920 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1925 static const char scm_ilentab
[] = {
1926 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1930 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1932 "Return the number of bits necessary to represent @var{n}.\n"
1935 "(integer-length #b10101010)\n"
1937 "(integer-length 0)\n"
1939 "(integer-length #b1111)\n"
1942 #define FUNC_NAME s_scm_integer_length
1946 unsigned long int c
= 0;
1948 long int nn
= SCM_INUM (n
);
1954 l
= scm_ilentab
[15 & nn
];
1957 return SCM_MAKINUM (c
- 4 + l
);
1959 else if (SCM_BIGP (n
))
1961 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
1962 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
1963 1 too big, so check for that and adjust. */
1964 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
1965 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
1966 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
1967 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
1969 scm_remember_upto_here_1 (n
);
1970 return SCM_MAKINUM (size
);
1973 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1977 /*** NUMBERS -> STRINGS ***/
1979 static const double fx
[] =
1980 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1981 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1982 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1983 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1986 idbl2str (double f
, char *a
)
1988 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1994 #ifdef HAVE_COPYSIGN
1995 double sgn
= copysign (1.0, f
);
2001 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
2007 strcpy (a
, "-inf.0");
2009 strcpy (a
, "+inf.0");
2012 else if (xisnan (f
))
2014 strcpy (a
, "+nan.0");
2024 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
2025 make-uniform-vector, from causing infinite loops. */
2029 if (exp
-- < DBL_MIN_10_EXP
)
2040 if (exp
++ > DBL_MAX_10_EXP
)
2060 if (f
+ fx
[wp
] >= 10.0)
2067 dpt
= (exp
+ 9999) % 3;
2071 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2096 if (f
+ fx
[wp
] >= 1.0)
2110 if ((dpt
> 4) && (exp
> 6))
2112 d
= (a
[0] == '-' ? 2 : 1);
2113 for (i
= ch
++; i
> d
; i
--)
2126 if (a
[ch
- 1] == '.')
2127 a
[ch
++] = '0'; /* trailing zero */
2136 for (i
= 10; i
<= exp
; i
*= 10);
2137 for (i
/= 10; i
; i
/= 10)
2139 a
[ch
++] = exp
/ i
+ '0';
2148 iflo2str (SCM flt
, char *str
)
2151 if (SCM_REALP (flt
))
2152 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2155 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2156 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2158 double imag
= SCM_COMPLEX_IMAG (flt
);
2159 /* Don't output a '+' for negative numbers or for Inf and
2160 NaN. They will provide their own sign. */
2161 if (0 <= imag
&& !xisinf (imag
) && !xisnan (imag
))
2163 i
+= idbl2str (imag
, &str
[i
]);
2170 /* convert a long to a string (unterminated). returns the number of
2171 characters in the result.
2173 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2175 scm_iint2str (long num
, int rad
, char *p
)
2179 unsigned long n
= (num
< 0) ? -num
: num
;
2181 for (n
/= rad
; n
> 0; n
/= rad
)
2198 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2203 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2205 "Return a string holding the external representation of the\n"
2206 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2207 "inexact, a radix of 10 will be used.")
2208 #define FUNC_NAME s_scm_number_to_string
2212 if (SCM_UNBNDP (radix
))
2216 SCM_VALIDATE_INUM (2, radix
);
2217 base
= SCM_INUM (radix
);
2218 /* FIXME: ask if range limit was OK, and if so, document */
2219 SCM_ASSERT_RANGE (2, radix
, (base
>= 2) && (base
<= 36));
2224 char num_buf
[SCM_INTBUFLEN
];
2225 size_t length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2226 return scm_mem2string (num_buf
, length
);
2228 else if (SCM_BIGP (n
))
2230 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
2231 scm_remember_upto_here_1 (n
);
2232 return scm_take0str (str
);
2234 else if (SCM_FRACTIONP (n
))
2236 scm_i_fraction_reduce (n
);
2237 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
2238 scm_mem2string ("/", 1),
2239 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
2241 else if (SCM_INEXACTP (n
))
2243 char num_buf
[FLOBUFLEN
];
2244 return scm_mem2string (num_buf
, iflo2str (n
, num_buf
));
2247 SCM_WRONG_TYPE_ARG (1, n
);
2252 /* These print routines used to be stubbed here so that scm_repl.c
2253 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
2256 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2258 char num_buf
[FLOBUFLEN
];
2259 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2264 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2267 char num_buf
[FLOBUFLEN
];
2268 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2273 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2276 scm_i_fraction_reduce (sexp
);
2277 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
2278 scm_lfwrite (SCM_STRING_CHARS (str
), SCM_STRING_LENGTH (str
), port
);
2279 scm_remember_upto_here_1 (str
);
2284 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2286 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
2287 scm_remember_upto_here_1 (exp
);
2288 scm_lfwrite (str
, (size_t) strlen (str
), port
);
2292 /*** END nums->strs ***/
2295 /*** STRINGS -> NUMBERS ***/
2297 /* The following functions implement the conversion from strings to numbers.
2298 * The implementation somehow follows the grammar for numbers as it is given
2299 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
2300 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
2301 * points should be noted about the implementation:
2302 * * Each function keeps a local index variable 'idx' that points at the
2303 * current position within the parsed string. The global index is only
2304 * updated if the function could parse the corresponding syntactic unit
2306 * * Similarly, the functions keep track of indicators of inexactness ('#',
2307 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
2308 * global exactness information is only updated after each part has been
2309 * successfully parsed.
2310 * * Sequences of digits are parsed into temporary variables holding fixnums.
2311 * Only if these fixnums would overflow, the result variables are updated
2312 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
2313 * the temporary variables holding the fixnums are cleared, and the process
2314 * starts over again. If for example fixnums were able to store five decimal
2315 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
2316 * and the result was computed as 12345 * 100000 + 67890. In other words,
2317 * only every five digits two bignum operations were performed.
2320 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
2322 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
2324 /* In non ASCII-style encodings the following macro might not work. */
2325 #define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
2328 mem2uinteger (const char* mem
, size_t len
, unsigned int *p_idx
,
2329 unsigned int radix
, enum t_exactness
*p_exactness
)
2331 unsigned int idx
= *p_idx
;
2332 unsigned int hash_seen
= 0;
2333 scm_t_bits shift
= 1;
2335 unsigned int digit_value
;
2345 digit_value
= XDIGIT2UINT (c
);
2346 if (digit_value
>= radix
)
2350 result
= SCM_MAKINUM (digit_value
);
2358 digit_value
= XDIGIT2UINT (c
);
2359 if (digit_value
>= radix
)
2371 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
2373 result
= scm_product (result
, SCM_MAKINUM (shift
));
2375 result
= scm_sum (result
, SCM_MAKINUM (add
));
2382 shift
= shift
* radix
;
2383 add
= add
* radix
+ digit_value
;
2388 result
= scm_product (result
, SCM_MAKINUM (shift
));
2390 result
= scm_sum (result
, SCM_MAKINUM (add
));
2394 *p_exactness
= INEXACT
;
2400 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2401 * covers the parts of the rules that start at a potential point. The value
2402 * of the digits up to the point have been parsed by the caller and are given
2403 * in variable result. The content of *p_exactness indicates, whether a hash
2404 * has already been seen in the digits before the point.
2407 /* In non ASCII-style encodings the following macro might not work. */
2408 #define DIGIT2UINT(d) ((d) - '0')
2411 mem2decimal_from_point (SCM result
, const char* mem
, size_t len
,
2412 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
2414 unsigned int idx
= *p_idx
;
2415 enum t_exactness x
= *p_exactness
;
2420 if (mem
[idx
] == '.')
2422 scm_t_bits shift
= 1;
2424 unsigned int digit_value
;
2425 SCM big_shift
= SCM_MAKINUM (1);
2436 digit_value
= DIGIT2UINT (c
);
2447 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
2449 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2450 result
= scm_product (result
, SCM_MAKINUM (shift
));
2452 result
= scm_sum (result
, SCM_MAKINUM (add
));
2460 add
= add
* 10 + digit_value
;
2466 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2467 result
= scm_product (result
, SCM_MAKINUM (shift
));
2468 result
= scm_sum (result
, SCM_MAKINUM (add
));
2471 result
= scm_divide (result
, big_shift
);
2473 /* We've seen a decimal point, thus the value is implicitly inexact. */
2485 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2516 exponent
= DIGIT2UINT (c
);
2523 if (exponent
<= SCM_MAXEXP
)
2524 exponent
= exponent
* 10 + DIGIT2UINT (c
);
2530 if (exponent
> SCM_MAXEXP
)
2532 size_t exp_len
= idx
- start
;
2533 SCM exp_string
= scm_mem2string (&mem
[start
], exp_len
);
2534 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
2535 scm_out_of_range ("string->number", exp_num
);
2538 e
= scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent
));
2540 result
= scm_product (result
, e
);
2542 result
= scm_divide2real (result
, e
);
2544 /* We've seen an exponent, thus the value is implicitly inexact. */
2562 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2565 mem2ureal (const char* mem
, size_t len
, unsigned int *p_idx
,
2566 unsigned int radix
, enum t_exactness
*p_exactness
)
2568 unsigned int idx
= *p_idx
;
2574 if (idx
+5 <= len
&& !strncmp (mem
+idx
, "inf.0", 5))
2580 if (idx
+4 < len
&& !strncmp (mem
+idx
, "nan.", 4))
2582 enum t_exactness x
= EXACT
;
2584 /* Cobble up the fractional part. We might want to set the
2585 NaN's mantissa from it. */
2587 mem2uinteger (mem
, len
, &idx
, 10, &x
);
2592 if (mem
[idx
] == '.')
2596 else if (idx
+ 1 == len
)
2598 else if (!isdigit (mem
[idx
+ 1]))
2601 result
= mem2decimal_from_point (SCM_MAKINUM (0), mem
, len
,
2602 p_idx
, p_exactness
);
2606 enum t_exactness x
= EXACT
;
2609 uinteger
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2610 if (SCM_FALSEP (uinteger
))
2615 else if (mem
[idx
] == '/')
2621 divisor
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2622 if (SCM_FALSEP (divisor
))
2625 /* both are int/big here, I assume */
2626 result
= scm_make_ratio (uinteger
, divisor
);
2628 else if (radix
== 10)
2630 result
= mem2decimal_from_point (uinteger
, mem
, len
, &idx
, &x
);
2631 if (SCM_FALSEP (result
))
2642 /* When returning an inexact zero, make sure it is represented as a
2643 floating point value so that we can change its sign.
2645 if (SCM_EQ_P (result
, SCM_MAKINUM(0)) && *p_exactness
== INEXACT
)
2646 result
= scm_make_real (0.0);
2652 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2655 mem2complex (const char* mem
, size_t len
, unsigned int idx
,
2656 unsigned int radix
, enum t_exactness
*p_exactness
)
2680 ureal
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2681 if (SCM_FALSEP (ureal
))
2683 /* input must be either +i or -i */
2688 if (mem
[idx
] == 'i' || mem
[idx
] == 'I')
2694 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign
));
2701 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2702 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
2711 /* either +<ureal>i or -<ureal>i */
2718 return scm_make_rectangular (SCM_MAKINUM (0), ureal
);
2721 /* polar input: <real>@<real>. */
2746 angle
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2747 if (SCM_FALSEP (angle
))
2752 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2753 angle
= scm_difference (angle
, SCM_UNDEFINED
);
2755 result
= scm_make_polar (ureal
, angle
);
2760 /* expecting input matching <real>[+-]<ureal>?i */
2767 int sign
= (c
== '+') ? 1 : -1;
2768 SCM imag
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2770 if (SCM_FALSEP (imag
))
2771 imag
= SCM_MAKINUM (sign
);
2772 else if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2773 imag
= scm_difference (imag
, SCM_UNDEFINED
);
2777 if (mem
[idx
] != 'i' && mem
[idx
] != 'I')
2784 return scm_make_rectangular (ureal
, imag
);
2793 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2795 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
2798 scm_i_mem2number (const char* mem
, size_t len
, unsigned int default_radix
)
2800 unsigned int idx
= 0;
2801 unsigned int radix
= NO_RADIX
;
2802 enum t_exactness forced_x
= NO_EXACTNESS
;
2803 enum t_exactness implicit_x
= EXACT
;
2806 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2807 while (idx
+ 2 < len
&& mem
[idx
] == '#')
2809 switch (mem
[idx
+ 1])
2812 if (radix
!= NO_RADIX
)
2817 if (radix
!= NO_RADIX
)
2822 if (forced_x
!= NO_EXACTNESS
)
2827 if (forced_x
!= NO_EXACTNESS
)
2832 if (radix
!= NO_RADIX
)
2837 if (radix
!= NO_RADIX
)
2847 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2848 if (radix
== NO_RADIX
)
2849 result
= mem2complex (mem
, len
, idx
, default_radix
, &implicit_x
);
2851 result
= mem2complex (mem
, len
, idx
, (unsigned int) radix
, &implicit_x
);
2853 if (SCM_FALSEP (result
))
2859 if (SCM_INEXACTP (result
))
2860 return scm_inexact_to_exact (result
);
2864 if (SCM_INEXACTP (result
))
2867 return scm_exact_to_inexact (result
);
2870 if (implicit_x
== INEXACT
)
2872 if (SCM_INEXACTP (result
))
2875 return scm_exact_to_inexact (result
);
2883 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2884 (SCM string
, SCM radix
),
2885 "Return a number of the maximally precise representation\n"
2886 "expressed by the given @var{string}. @var{radix} must be an\n"
2887 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2888 "is a default radix that may be overridden by an explicit radix\n"
2889 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2890 "supplied, then the default radix is 10. If string is not a\n"
2891 "syntactically valid notation for a number, then\n"
2892 "@code{string->number} returns @code{#f}.")
2893 #define FUNC_NAME s_scm_string_to_number
2897 SCM_VALIDATE_STRING (1, string
);
2898 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix
,2,10, base
);
2899 answer
= scm_i_mem2number (SCM_STRING_CHARS (string
),
2900 SCM_STRING_LENGTH (string
),
2902 return scm_return_first (answer
, string
);
2907 /*** END strs->nums ***/
2911 scm_make_real (double x
)
2913 SCM z
= scm_double_cell (scm_tc16_real
, 0, 0, 0);
2915 SCM_REAL_VALUE (z
) = x
;
2921 scm_make_complex (double x
, double y
)
2924 return scm_make_real (x
);
2928 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_gc_malloc (sizeof (scm_t_complex
),
2930 SCM_COMPLEX_REAL (z
) = x
;
2931 SCM_COMPLEX_IMAG (z
) = y
;
2938 scm_bigequal (SCM x
, SCM y
)
2940 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2941 scm_remember_upto_here_2 (x
, y
);
2942 return SCM_BOOL (0 == result
);
2946 scm_real_equalp (SCM x
, SCM y
)
2948 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2952 scm_complex_equalp (SCM x
, SCM y
)
2954 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2955 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2959 scm_i_fraction_equalp (SCM x
, SCM y
)
2961 scm_i_fraction_reduce (x
);
2962 scm_i_fraction_reduce (y
);
2963 if (SCM_FALSEP (scm_equal_p (SCM_FRACTION_NUMERATOR (x
),
2964 SCM_FRACTION_NUMERATOR (y
)))
2965 || SCM_FALSEP (scm_equal_p (SCM_FRACTION_DENOMINATOR (x
),
2966 SCM_FRACTION_DENOMINATOR (y
))))
2973 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2974 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2975 * "else. Note that the sets of complex, real, rational and\n"
2976 * "integer values form subsets of the set of numbers, i. e. the\n"
2977 * "predicate will be fulfilled for any number."
2979 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2981 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2982 "otherwise. Note that the sets of real, rational and integer\n"
2983 "values form subsets of the set of complex numbers, i. e. the\n"
2984 "predicate will also be fulfilled if @var{x} is a real,\n"
2985 "rational or integer number.")
2986 #define FUNC_NAME s_scm_number_p
2988 return SCM_BOOL (SCM_NUMBERP (x
));
2993 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
2995 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
2996 "otherwise. Note that the set of integer values forms a subset of\n"
2997 "the set of real numbers, i. e. the predicate will also be\n"
2998 "fulfilled if @var{x} is an integer number.")
2999 #define FUNC_NAME s_scm_real_p
3001 /* we can't represent irrational numbers. */
3002 return scm_rational_p (x
);
3006 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
3008 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
3009 "otherwise. Note that the set of integer values forms a subset of\n"
3010 "the set of rational numbers, i. e. the predicate will also be\n"
3011 "fulfilled if @var{x} is an integer number.")
3012 #define FUNC_NAME s_scm_rational_p
3016 else if (SCM_IMP (x
))
3018 else if (SCM_BIGP (x
))
3020 else if (SCM_FRACTIONP (x
))
3022 else if (SCM_REALP (x
))
3023 /* due to their limited precision, all floating point numbers are
3024 rational as well. */
3032 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
3034 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
3036 #define FUNC_NAME s_scm_integer_p
3045 if (!SCM_INEXACTP (x
))
3047 if (SCM_COMPLEXP (x
))
3049 r
= SCM_REAL_VALUE (x
);
3057 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
3059 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
3061 #define FUNC_NAME s_scm_inexact_p
3063 if (SCM_INEXACTP (x
))
3065 if (SCM_NUMBERP (x
))
3067 SCM_WRONG_TYPE_ARG (1, x
);
3072 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
3073 /* "Return @code{#t} if all parameters are numerically equal." */
3075 scm_num_eq_p (SCM x
, SCM y
)
3080 long xx
= SCM_INUM (x
);
3083 long yy
= SCM_INUM (y
);
3084 return SCM_BOOL (xx
== yy
);
3086 else if (SCM_BIGP (y
))
3088 else if (SCM_REALP (y
))
3089 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
3090 else if (SCM_COMPLEXP (y
))
3091 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
3092 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3093 else if (SCM_FRACTIONP (y
))
3096 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3098 else if (SCM_BIGP (x
))
3102 else if (SCM_BIGP (y
))
3104 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3105 scm_remember_upto_here_2 (x
, y
);
3106 return SCM_BOOL (0 == cmp
);
3108 else if (SCM_REALP (y
))
3111 if (xisnan (SCM_REAL_VALUE (y
)))
3113 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
3114 scm_remember_upto_here_1 (x
);
3115 return SCM_BOOL (0 == cmp
);
3117 else if (SCM_COMPLEXP (y
))
3120 if (0.0 != SCM_COMPLEX_IMAG (y
))
3122 if (xisnan (SCM_COMPLEX_REAL (y
)))
3124 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
3125 scm_remember_upto_here_1 (x
);
3126 return SCM_BOOL (0 == cmp
);
3128 else if (SCM_FRACTIONP (y
))
3131 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3133 else if (SCM_REALP (x
))
3136 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3137 else if (SCM_BIGP (y
))
3140 if (xisnan (SCM_REAL_VALUE (x
)))
3142 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
3143 scm_remember_upto_here_1 (y
);
3144 return SCM_BOOL (0 == cmp
);
3146 else if (SCM_REALP (y
))
3147 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3148 else if (SCM_COMPLEXP (y
))
3149 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3150 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3151 else if (SCM_FRACTIONP (y
))
3153 double xx
= SCM_REAL_VALUE (x
);
3157 return SCM_BOOL (xx
< 0.0);
3158 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
3162 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3164 else if (SCM_COMPLEXP (x
))
3167 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3168 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3169 else if (SCM_BIGP (y
))
3172 if (0.0 != SCM_COMPLEX_IMAG (x
))
3174 if (xisnan (SCM_COMPLEX_REAL (x
)))
3176 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
3177 scm_remember_upto_here_1 (y
);
3178 return SCM_BOOL (0 == cmp
);
3180 else if (SCM_REALP (y
))
3181 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3182 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3183 else if (SCM_COMPLEXP (y
))
3184 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3185 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3186 else if (SCM_FRACTIONP (y
))
3189 if (SCM_COMPLEX_IMAG (x
) != 0.0)
3191 xx
= SCM_COMPLEX_REAL (x
);
3195 return SCM_BOOL (xx
< 0.0);
3196 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
3200 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3202 else if (SCM_FRACTIONP (x
))
3206 else if (SCM_BIGP (y
))
3208 else if (SCM_REALP (y
))
3210 double yy
= SCM_REAL_VALUE (y
);
3214 return SCM_BOOL (0.0 < yy
);
3215 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
3218 else if (SCM_COMPLEXP (y
))
3221 if (SCM_COMPLEX_IMAG (y
) != 0.0)
3223 yy
= SCM_COMPLEX_REAL (y
);
3227 return SCM_BOOL (0.0 < yy
);
3228 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
3231 else if (SCM_FRACTIONP (y
))
3232 return scm_i_fraction_equalp (x
, y
);
3234 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3237 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3241 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
3242 done are good for inums, but for bignums an answer can almost always be
3243 had by just examining a few high bits of the operands, as done by GMP in
3244 mpq_cmp. flonum/frac compares likewise, but with the slight complication
3245 of the float exponent to take into account. */
3247 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3248 /* "Return @code{#t} if the list of parameters is monotonically\n"
3252 scm_less_p (SCM x
, SCM y
)
3257 long xx
= SCM_INUM (x
);
3260 long yy
= SCM_INUM (y
);
3261 return SCM_BOOL (xx
< yy
);
3263 else if (SCM_BIGP (y
))
3265 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3266 scm_remember_upto_here_1 (y
);
3267 return SCM_BOOL (sgn
> 0);
3269 else if (SCM_REALP (y
))
3270 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3271 else if (SCM_FRACTIONP (y
))
3273 /* "x < a/b" becomes "x*b < a" */
3275 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
3276 y
= SCM_FRACTION_NUMERATOR (y
);
3280 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3282 else if (SCM_BIGP (x
))
3286 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3287 scm_remember_upto_here_1 (x
);
3288 return SCM_BOOL (sgn
< 0);
3290 else if (SCM_BIGP (y
))
3292 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3293 scm_remember_upto_here_2 (x
, y
);
3294 return SCM_BOOL (cmp
< 0);
3296 else if (SCM_REALP (y
))
3299 if (xisnan (SCM_REAL_VALUE (y
)))
3301 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
3302 scm_remember_upto_here_1 (x
);
3303 return SCM_BOOL (cmp
< 0);
3305 else if (SCM_FRACTIONP (y
))
3308 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3310 else if (SCM_REALP (x
))
3313 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3314 else if (SCM_BIGP (y
))
3317 if (xisnan (SCM_REAL_VALUE (x
)))
3319 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
3320 scm_remember_upto_here_1 (y
);
3321 return SCM_BOOL (cmp
> 0);
3323 else if (SCM_REALP (y
))
3324 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3325 else if (SCM_FRACTIONP (y
))
3327 double xx
= SCM_REAL_VALUE (x
);
3331 return SCM_BOOL (xx
< 0.0);
3332 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
3336 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3338 else if (SCM_FRACTIONP (x
))
3340 if (SCM_INUMP (y
) || SCM_BIGP (y
))
3342 /* "a/b < y" becomes "a < y*b" */
3343 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
3344 x
= SCM_FRACTION_NUMERATOR (x
);
3347 else if (SCM_REALP (y
))
3349 double yy
= SCM_REAL_VALUE (y
);
3353 return SCM_BOOL (0.0 < yy
);
3354 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
3357 else if (SCM_FRACTIONP (y
))
3359 /* "a/b < c/d" becomes "a*d < c*b" */
3360 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
3361 SCM_FRACTION_DENOMINATOR (y
));
3362 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
3363 SCM_FRACTION_DENOMINATOR (x
));
3369 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3372 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3376 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3377 /* "Return @code{#t} if the list of parameters is monotonically\n"
3380 #define FUNC_NAME s_scm_gr_p
3382 scm_gr_p (SCM x
, SCM y
)
3384 if (!SCM_NUMBERP (x
))
3385 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3386 else if (!SCM_NUMBERP (y
))
3387 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3389 return scm_less_p (y
, x
);
3394 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3395 /* "Return @code{#t} if the list of parameters is monotonically\n"
3398 #define FUNC_NAME s_scm_leq_p
3400 scm_leq_p (SCM x
, SCM y
)
3402 if (!SCM_NUMBERP (x
))
3403 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3404 else if (!SCM_NUMBERP (y
))
3405 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3406 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
3409 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3414 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3415 /* "Return @code{#t} if the list of parameters is monotonically\n"
3418 #define FUNC_NAME s_scm_geq_p
3420 scm_geq_p (SCM x
, SCM y
)
3422 if (!SCM_NUMBERP (x
))
3423 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3424 else if (!SCM_NUMBERP (y
))
3425 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3426 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
3429 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3434 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3435 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3442 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3443 else if (SCM_BIGP (z
))
3445 else if (SCM_REALP (z
))
3446 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3447 else if (SCM_COMPLEXP (z
))
3448 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3449 && SCM_COMPLEX_IMAG (z
) == 0.0);
3450 else if (SCM_FRACTIONP (z
))
3453 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3457 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3458 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3462 scm_positive_p (SCM x
)
3465 return SCM_BOOL (SCM_INUM (x
) > 0);
3466 else if (SCM_BIGP (x
))
3468 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3469 scm_remember_upto_here_1 (x
);
3470 return SCM_BOOL (sgn
> 0);
3472 else if (SCM_REALP (x
))
3473 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3474 else if (SCM_FRACTIONP (x
))
3475 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
3477 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3481 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3482 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3486 scm_negative_p (SCM x
)
3489 return SCM_BOOL (SCM_INUM (x
) < 0);
3490 else if (SCM_BIGP (x
))
3492 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3493 scm_remember_upto_here_1 (x
);
3494 return SCM_BOOL (sgn
< 0);
3496 else if (SCM_REALP (x
))
3497 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3498 else if (SCM_FRACTIONP (x
))
3499 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
3501 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3505 /* scm_min and scm_max return an inexact when either argument is inexact, as
3506 required by r5rs. On that basis, for exact/inexact combinations the
3507 exact is converted to inexact to compare and possibly return. This is
3508 unlike scm_less_p above which takes some trouble to preserve all bits in
3509 its test, such trouble is not required for min and max. */
3511 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3512 /* "Return the maximum of all parameter values."
3515 scm_max (SCM x
, SCM y
)
3520 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
3521 else if (SCM_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
3524 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3529 long xx
= SCM_INUM (x
);
3532 long yy
= SCM_INUM (y
);
3533 return (xx
< yy
) ? y
: x
;
3535 else if (SCM_BIGP (y
))
3537 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3538 scm_remember_upto_here_1 (y
);
3539 return (sgn
< 0) ? x
: y
;
3541 else if (SCM_REALP (y
))
3544 /* if y==NaN then ">" is false and we return NaN */
3545 return (z
> SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3547 else if (SCM_FRACTIONP (y
))
3550 return (z
> scm_i_fraction2double (y
)) ? x
: y
;
3553 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3555 else if (SCM_BIGP (x
))
3559 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3560 scm_remember_upto_here_1 (x
);
3561 return (sgn
< 0) ? y
: x
;
3563 else if (SCM_BIGP (y
))
3565 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3566 scm_remember_upto_here_2 (x
, y
);
3567 return (cmp
> 0) ? x
: y
;
3569 else if (SCM_REALP (y
))
3571 /* if y==NaN then xx>yy is false, so we return the NaN y */
3574 xx
= scm_i_big2dbl (x
);
3575 yy
= SCM_REAL_VALUE (y
);
3576 return (xx
> yy
? scm_make_real (xx
) : y
);
3578 else if (SCM_FRACTIONP (y
))
3580 double yy
= scm_i_fraction2double (y
);
3582 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), yy
);
3583 scm_remember_upto_here_1 (x
);
3584 return (cmp
> 0) ? x
: y
;
3587 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3589 else if (SCM_REALP (x
))
3593 double z
= SCM_INUM (y
);
3594 /* if x==NaN then "<" is false and we return NaN */
3595 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3597 else if (SCM_BIGP (y
))
3599 SCM t
= x
; x
= y
; y
= t
;
3602 else if (SCM_REALP (y
))
3604 /* if x==NaN then our explicit check means we return NaN
3605 if y==NaN then ">" is false and we return NaN
3606 calling isnan is unavoidable, since it's the only way to know
3607 which of x or y causes any compares to be false */
3608 double xx
= SCM_REAL_VALUE (x
);
3609 return (xisnan (xx
) || xx
> SCM_REAL_VALUE (y
)) ? x
: y
;
3611 else if (SCM_FRACTIONP (y
))
3613 double yy
= scm_i_fraction2double (y
);
3614 double xx
= SCM_REAL_VALUE (x
);
3615 return (xx
< yy
) ? scm_make_real (yy
) : x
;
3618 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3620 else if (SCM_FRACTIONP (x
))
3624 double z
= SCM_INUM (y
);
3625 return (scm_i_fraction2double (x
) < z
) ? y
: x
;
3627 else if (SCM_BIGP (y
))
3629 double xx
= scm_i_fraction2double (x
);
3631 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
3632 scm_remember_upto_here_1 (y
);
3633 return (cmp
< 0) ? x
: y
;
3635 else if (SCM_REALP (y
))
3637 double xx
= scm_i_fraction2double (x
);
3638 return (xx
< SCM_REAL_VALUE (y
)) ? y
: scm_make_real (xx
);
3640 else if (SCM_FRACTIONP (y
))
3642 double yy
= scm_i_fraction2double (y
);
3643 double xx
= scm_i_fraction2double (x
);
3644 return (xx
< yy
) ? y
: x
;
3647 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3650 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3654 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3655 /* "Return the minium of all parameter values."
3658 scm_min (SCM x
, SCM y
)
3663 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
3664 else if (SCM_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
3667 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3672 long xx
= SCM_INUM (x
);
3675 long yy
= SCM_INUM (y
);
3676 return (xx
< yy
) ? x
: y
;
3678 else if (SCM_BIGP (y
))
3680 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3681 scm_remember_upto_here_1 (y
);
3682 return (sgn
< 0) ? y
: x
;
3684 else if (SCM_REALP (y
))
3687 /* if y==NaN then "<" is false and we return NaN */
3688 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3690 else if (SCM_FRACTIONP (y
))
3693 return (z
< scm_i_fraction2double (y
)) ? x
: y
;
3696 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3698 else if (SCM_BIGP (x
))
3702 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3703 scm_remember_upto_here_1 (x
);
3704 return (sgn
< 0) ? x
: y
;
3706 else if (SCM_BIGP (y
))
3708 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3709 scm_remember_upto_here_2 (x
, y
);
3710 return (cmp
> 0) ? y
: x
;
3712 else if (SCM_REALP (y
))
3714 /* if y==NaN then xx<yy is false, so we return the NaN y */
3717 xx
= scm_i_big2dbl (x
);
3718 yy
= SCM_REAL_VALUE (y
);
3719 return (xx
< yy
? scm_make_real (xx
) : y
);
3721 else if (SCM_FRACTIONP (y
))
3723 double yy
= scm_i_fraction2double (y
);
3725 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), yy
);
3726 scm_remember_upto_here_1 (x
);
3727 return (cmp
> 0) ? y
: x
;
3730 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3732 else if (SCM_REALP (x
))
3736 double z
= SCM_INUM (y
);
3737 /* if x==NaN then "<" is false and we return NaN */
3738 return (z
< SCM_REAL_VALUE (x
)) ? scm_make_real (z
) : x
;
3740 else if (SCM_BIGP (y
))
3742 SCM t
= x
; x
= y
; y
= t
;
3745 else if (SCM_REALP (y
))
3747 /* if x==NaN then our explicit check means we return NaN
3748 if y==NaN then "<" is false and we return NaN
3749 calling isnan is unavoidable, since it's the only way to know
3750 which of x or y causes any compares to be false */
3751 double xx
= SCM_REAL_VALUE (x
);
3752 return (xisnan (xx
) || xx
< SCM_REAL_VALUE (y
)) ? x
: y
;
3754 else if (SCM_FRACTIONP (y
))
3756 double yy
= scm_i_fraction2double (y
);
3757 double xx
= SCM_REAL_VALUE (x
);
3758 return (yy
< xx
) ? scm_make_real (yy
) : x
;
3761 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3763 else if (SCM_FRACTIONP (x
))
3767 double z
= SCM_INUM (y
);
3768 return (scm_i_fraction2double (x
) < z
) ? x
: y
;
3770 else if (SCM_BIGP (y
))
3772 double xx
= scm_i_fraction2double (x
);
3774 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
3775 scm_remember_upto_here_1 (y
);
3776 return (cmp
< 0) ? y
: x
;
3778 else if (SCM_REALP (y
))
3780 double xx
= scm_i_fraction2double (x
);
3781 return (SCM_REAL_VALUE (y
) < xx
) ? y
: scm_make_real (xx
);
3783 else if (SCM_FRACTIONP (y
))
3785 double yy
= scm_i_fraction2double (y
);
3786 double xx
= scm_i_fraction2double (x
);
3787 return (xx
< yy
) ? x
: y
;
3790 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3793 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3797 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3798 /* "Return the sum of all parameter values. Return 0 if called without\n"
3802 scm_sum (SCM x
, SCM y
)
3806 if (SCM_NUMBERP (x
)) return x
;
3807 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
3808 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3815 long xx
= SCM_INUM (x
);
3816 long yy
= SCM_INUM (y
);
3817 long int z
= xx
+ yy
;
3818 return SCM_FIXABLE (z
) ? SCM_MAKINUM (z
) : scm_i_long2big (z
);
3820 else if (SCM_BIGP (y
))
3825 else if (SCM_REALP (y
))
3827 long int xx
= SCM_INUM (x
);
3828 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3830 else if (SCM_COMPLEXP (y
))
3832 long int xx
= SCM_INUM (x
);
3833 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3834 SCM_COMPLEX_IMAG (y
));
3836 else if (SCM_FRACTIONP (y
))
3837 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
3838 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
3839 SCM_FRACTION_DENOMINATOR (y
));
3841 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3842 } else if (SCM_BIGP (x
))
3849 inum
= SCM_INUM (y
);
3852 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3855 SCM result
= scm_i_mkbig ();
3856 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
3857 scm_remember_upto_here_1 (x
);
3858 /* we know the result will have to be a bignum */
3861 return scm_i_normbig (result
);
3865 SCM result
= scm_i_mkbig ();
3866 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
3867 scm_remember_upto_here_1 (x
);
3868 /* we know the result will have to be a bignum */
3871 return scm_i_normbig (result
);
3874 else if (SCM_BIGP (y
))
3876 SCM result
= scm_i_mkbig ();
3877 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3878 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3879 mpz_add (SCM_I_BIG_MPZ (result
),
3882 scm_remember_upto_here_2 (x
, y
);
3883 /* we know the result will have to be a bignum */
3886 return scm_i_normbig (result
);
3888 else if (SCM_REALP (y
))
3890 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
3891 scm_remember_upto_here_1 (x
);
3892 return scm_make_real (result
);
3894 else if (SCM_COMPLEXP (y
))
3896 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
3897 + SCM_COMPLEX_REAL (y
));
3898 scm_remember_upto_here_1 (x
);
3899 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (y
));
3901 else if (SCM_FRACTIONP (y
))
3902 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
3903 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
3904 SCM_FRACTION_DENOMINATOR (y
));
3906 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3908 else if (SCM_REALP (x
))
3911 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3912 else if (SCM_BIGP (y
))
3914 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
3915 scm_remember_upto_here_1 (y
);
3916 return scm_make_real (result
);
3918 else if (SCM_REALP (y
))
3919 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3920 else if (SCM_COMPLEXP (y
))
3921 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3922 SCM_COMPLEX_IMAG (y
));
3923 else if (SCM_FRACTIONP (y
))
3924 return scm_make_real (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
3926 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3928 else if (SCM_COMPLEXP (x
))
3931 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3932 SCM_COMPLEX_IMAG (x
));
3933 else if (SCM_BIGP (y
))
3935 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
3936 + SCM_COMPLEX_REAL (x
));
3937 scm_remember_upto_here_1 (y
);
3938 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (x
));
3940 else if (SCM_REALP (y
))
3941 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3942 SCM_COMPLEX_IMAG (x
));
3943 else if (SCM_COMPLEXP (y
))
3944 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3945 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3946 else if (SCM_FRACTIONP (y
))
3947 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
3948 SCM_COMPLEX_IMAG (x
));
3950 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3952 else if (SCM_FRACTIONP (x
))
3955 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
3956 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
3957 SCM_FRACTION_DENOMINATOR (x
));
3958 else if (SCM_BIGP (y
))
3959 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
3960 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
3961 SCM_FRACTION_DENOMINATOR (x
));
3962 else if (SCM_REALP (y
))
3963 return scm_make_real (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
3964 else if (SCM_COMPLEXP (y
))
3965 return scm_make_complex (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
3966 SCM_COMPLEX_IMAG (y
));
3967 else if (SCM_FRACTIONP (y
))
3968 /* a/b + c/d = (ad + bc) / bd */
3969 return scm_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
3970 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
3971 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
3973 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3976 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3980 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3981 /* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3982 * the sum of all but the first argument are subtracted from the first
3984 #define FUNC_NAME s_difference
3986 scm_difference (SCM x
, SCM y
)
3991 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3995 long xx
= -SCM_INUM (x
);
3996 if (SCM_FIXABLE (xx
))
3997 return SCM_MAKINUM (xx
);
3999 return scm_i_long2big (xx
);
4001 else if (SCM_BIGP (x
))
4002 /* FIXME: do we really need to normalize here? */
4003 return scm_i_normbig (scm_i_clonebig (x
, 0));
4004 else if (SCM_REALP (x
))
4005 return scm_make_real (-SCM_REAL_VALUE (x
));
4006 else if (SCM_COMPLEXP (x
))
4007 return scm_make_complex (-SCM_COMPLEX_REAL (x
),
4008 -SCM_COMPLEX_IMAG (x
));
4009 else if (SCM_FRACTIONP (x
))
4010 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
4011 SCM_FRACTION_DENOMINATOR (x
));
4013 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
4020 long int xx
= SCM_INUM (x
);
4021 long int yy
= SCM_INUM (y
);
4022 long int z
= xx
- yy
;
4023 if (SCM_FIXABLE (z
))
4024 return SCM_MAKINUM (z
);
4026 return scm_i_long2big (z
);
4028 else if (SCM_BIGP (y
))
4030 /* inum-x - big-y */
4031 long xx
= SCM_INUM (x
);
4034 return scm_i_clonebig (y
, 0);
4037 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
4038 SCM result
= scm_i_mkbig ();
4041 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
4044 /* x - y == -(y + -x) */
4045 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
4046 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
4048 scm_remember_upto_here_1 (y
);
4050 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
4051 /* we know the result will have to be a bignum */
4054 return scm_i_normbig (result
);
4057 else if (SCM_REALP (y
))
4059 long int xx
= SCM_INUM (x
);
4060 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
4062 else if (SCM_COMPLEXP (y
))
4064 long int xx
= SCM_INUM (x
);
4065 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
4066 - SCM_COMPLEX_IMAG (y
));
4068 else if (SCM_FRACTIONP (y
))
4069 /* a - b/c = (ac - b) / c */
4070 return scm_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4071 SCM_FRACTION_NUMERATOR (y
)),
4072 SCM_FRACTION_DENOMINATOR (y
));
4074 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4076 else if (SCM_BIGP (x
))
4080 /* big-x - inum-y */
4081 long yy
= SCM_INUM (y
);
4082 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4084 scm_remember_upto_here_1 (x
);
4086 return SCM_FIXABLE (-yy
) ? SCM_MAKINUM (-yy
) : scm_long2num (-yy
);
4089 SCM result
= scm_i_mkbig ();
4092 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
4094 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
4095 scm_remember_upto_here_1 (x
);
4097 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
4098 /* we know the result will have to be a bignum */
4101 return scm_i_normbig (result
);
4104 else if (SCM_BIGP (y
))
4106 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4107 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
4108 SCM result
= scm_i_mkbig ();
4109 mpz_sub (SCM_I_BIG_MPZ (result
),
4112 scm_remember_upto_here_2 (x
, y
);
4113 /* we know the result will have to be a bignum */
4114 if ((sgn_x
== 1) && (sgn_y
== -1))
4116 if ((sgn_x
== -1) && (sgn_y
== 1))
4118 return scm_i_normbig (result
);
4120 else if (SCM_REALP (y
))
4122 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
4123 scm_remember_upto_here_1 (x
);
4124 return scm_make_real (result
);
4126 else if (SCM_COMPLEXP (y
))
4128 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
4129 - SCM_COMPLEX_REAL (y
));
4130 scm_remember_upto_here_1 (x
);
4131 return scm_make_complex (real_part
, - SCM_COMPLEX_IMAG (y
));
4133 else if (SCM_FRACTIONP (y
))
4134 return scm_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4135 SCM_FRACTION_NUMERATOR (y
)),
4136 SCM_FRACTION_DENOMINATOR (y
));
4137 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4139 else if (SCM_REALP (x
))
4142 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
4143 else if (SCM_BIGP (y
))
4145 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
4146 scm_remember_upto_here_1 (x
);
4147 return scm_make_real (result
);
4149 else if (SCM_REALP (y
))
4150 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
4151 else if (SCM_COMPLEXP (y
))
4152 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
4153 -SCM_COMPLEX_IMAG (y
));
4154 else if (SCM_FRACTIONP (y
))
4155 return scm_make_real (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
4157 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4159 else if (SCM_COMPLEXP (x
))
4162 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
4163 SCM_COMPLEX_IMAG (x
));
4164 else if (SCM_BIGP (y
))
4166 double real_part
= (SCM_COMPLEX_REAL (x
)
4167 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
4168 scm_remember_upto_here_1 (x
);
4169 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (y
));
4171 else if (SCM_REALP (y
))
4172 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
4173 SCM_COMPLEX_IMAG (x
));
4174 else if (SCM_COMPLEXP (y
))
4175 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
4176 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
4177 else if (SCM_FRACTIONP (y
))
4178 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
4179 SCM_COMPLEX_IMAG (x
));
4181 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4183 else if (SCM_FRACTIONP (x
))
4186 /* a/b - c = (a - cb) / b */
4187 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
4188 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
4189 SCM_FRACTION_DENOMINATOR (x
));
4190 else if (SCM_BIGP (y
))
4191 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
4192 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
4193 SCM_FRACTION_DENOMINATOR (x
));
4194 else if (SCM_REALP (y
))
4195 return scm_make_real (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
4196 else if (SCM_COMPLEXP (y
))
4197 return scm_make_complex (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
4198 -SCM_COMPLEX_IMAG (y
));
4199 else if (SCM_FRACTIONP (y
))
4200 /* a/b - c/d = (ad - bc) / bd */
4201 return scm_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
4202 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
4203 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
4205 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4208 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
4213 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
4214 /* "Return the product of all arguments. If called without arguments,\n"
4218 scm_product (SCM x
, SCM y
)
4223 return SCM_MAKINUM (1L);
4224 else if (SCM_NUMBERP (x
))
4227 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
4239 case 0: return x
; break;
4240 case 1: return y
; break;
4245 long yy
= SCM_INUM (y
);
4247 SCM k
= SCM_MAKINUM (kk
);
4248 if ((kk
== SCM_INUM (k
)) && (kk
/ xx
== yy
))
4252 SCM result
= scm_i_long2big (xx
);
4253 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
4254 return scm_i_normbig (result
);
4257 else if (SCM_BIGP (y
))
4259 SCM result
= scm_i_mkbig ();
4260 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
4261 scm_remember_upto_here_1 (y
);
4264 else if (SCM_REALP (y
))
4265 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
4266 else if (SCM_COMPLEXP (y
))
4267 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
4268 xx
* SCM_COMPLEX_IMAG (y
));
4269 else if (SCM_FRACTIONP (y
))
4270 return scm_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
4271 SCM_FRACTION_DENOMINATOR (y
));
4273 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4275 else if (SCM_BIGP (x
))
4282 else if (SCM_BIGP (y
))
4284 SCM result
= scm_i_mkbig ();
4285 mpz_mul (SCM_I_BIG_MPZ (result
),
4288 scm_remember_upto_here_2 (x
, y
);
4291 else if (SCM_REALP (y
))
4293 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
4294 scm_remember_upto_here_1 (x
);
4295 return scm_make_real (result
);
4297 else if (SCM_COMPLEXP (y
))
4299 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
4300 scm_remember_upto_here_1 (x
);
4301 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
4302 z
* SCM_COMPLEX_IMAG (y
));
4304 else if (SCM_FRACTIONP (y
))
4305 return scm_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
4306 SCM_FRACTION_DENOMINATOR (y
));
4308 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4310 else if (SCM_REALP (x
))
4313 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
4314 else if (SCM_BIGP (y
))
4316 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
4317 scm_remember_upto_here_1 (y
);
4318 return scm_make_real (result
);
4320 else if (SCM_REALP (y
))
4321 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
4322 else if (SCM_COMPLEXP (y
))
4323 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
4324 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
4325 else if (SCM_FRACTIONP (y
))
4326 return scm_make_real (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
4328 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4330 else if (SCM_COMPLEXP (x
))
4333 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
4334 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
4335 else if (SCM_BIGP (y
))
4337 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4338 scm_remember_upto_here_1 (y
);
4339 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
4340 z
* SCM_COMPLEX_IMAG (x
));
4342 else if (SCM_REALP (y
))
4343 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
4344 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
4345 else if (SCM_COMPLEXP (y
))
4347 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
4348 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
4349 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
4350 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
4352 else if (SCM_FRACTIONP (y
))
4354 double yy
= scm_i_fraction2double (y
);
4355 return scm_make_complex (yy
* SCM_COMPLEX_REAL (x
),
4356 yy
* SCM_COMPLEX_IMAG (x
));
4359 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4361 else if (SCM_FRACTIONP (x
))
4364 return scm_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
4365 SCM_FRACTION_DENOMINATOR (x
));
4366 else if (SCM_BIGP (y
))
4367 return scm_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
4368 SCM_FRACTION_DENOMINATOR (x
));
4369 else if (SCM_REALP (y
))
4370 return scm_make_real (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
4371 else if (SCM_COMPLEXP (y
))
4373 double xx
= scm_i_fraction2double (x
);
4374 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
4375 xx
* SCM_COMPLEX_IMAG (y
));
4377 else if (SCM_FRACTIONP (y
))
4378 /* a/b * c/d = ac / bd */
4379 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
4380 SCM_FRACTION_NUMERATOR (y
)),
4381 scm_product (SCM_FRACTION_DENOMINATOR (x
),
4382 SCM_FRACTION_DENOMINATOR (y
)));
4384 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4387 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
4391 scm_num2dbl (SCM a
, const char *why
)
4392 #define FUNC_NAME why
4395 return (double) SCM_INUM (a
);
4396 else if (SCM_BIGP (a
))
4398 double result
= mpz_get_d (SCM_I_BIG_MPZ (a
));
4399 scm_remember_upto_here_1 (a
);
4402 else if (SCM_REALP (a
))
4403 return (SCM_REAL_VALUE (a
));
4404 else if (SCM_FRACTIONP (a
))
4405 return scm_i_fraction2double (a
);
4407 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
4411 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
4412 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
4413 #define ALLOW_DIVIDE_BY_ZERO
4414 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
4417 /* The code below for complex division is adapted from the GNU
4418 libstdc++, which adapted it from f2c's libF77, and is subject to
4421 /****************************************************************
4422 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
4424 Permission to use, copy, modify, and distribute this software
4425 and its documentation for any purpose and without fee is hereby
4426 granted, provided that the above copyright notice appear in all
4427 copies and that both that the copyright notice and this
4428 permission notice and warranty disclaimer appear in supporting
4429 documentation, and that the names of AT&T Bell Laboratories or
4430 Bellcore or any of their entities not be used in advertising or
4431 publicity pertaining to distribution of the software without
4432 specific, written prior permission.
4434 AT&T and Bellcore disclaim all warranties with regard to this
4435 software, including all implied warranties of merchantability
4436 and fitness. In no event shall AT&T or Bellcore be liable for
4437 any special, indirect or consequential damages or any damages
4438 whatsoever resulting from loss of use, data or profits, whether
4439 in an action of contract, negligence or other tortious action,
4440 arising out of or in connection with the use or performance of
4442 ****************************************************************/
4444 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
4445 /* Divide the first argument by the product of the remaining
4446 arguments. If called with one argument @var{z1}, 1/@var{z1} is
4448 #define FUNC_NAME s_divide
4450 scm_i_divide (SCM x
, SCM y
, int inexact
)
4457 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
4458 else if (SCM_INUMP (x
))
4460 long xx
= SCM_INUM (x
);
4461 if (xx
== 1 || xx
== -1)
4463 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4465 scm_num_overflow (s_divide
);
4470 return scm_make_real (1.0 / (double) xx
);
4471 else return scm_make_ratio (SCM_MAKINUM(1), x
);
4474 else if (SCM_BIGP (x
))
4477 return scm_make_real (1.0 / scm_i_big2dbl (x
));
4478 else return scm_make_ratio (SCM_MAKINUM(1), x
);
4480 else if (SCM_REALP (x
))
4482 double xx
= SCM_REAL_VALUE (x
);
4483 #ifndef ALLOW_DIVIDE_BY_ZERO
4485 scm_num_overflow (s_divide
);
4488 return scm_make_real (1.0 / xx
);
4490 else if (SCM_COMPLEXP (x
))
4492 double r
= SCM_COMPLEX_REAL (x
);
4493 double i
= SCM_COMPLEX_IMAG (x
);
4497 double d
= i
* (1.0 + t
* t
);
4498 return scm_make_complex (t
/ d
, -1.0 / d
);
4503 double d
= r
* (1.0 + t
* t
);
4504 return scm_make_complex (1.0 / d
, -t
/ d
);
4507 else if (SCM_FRACTIONP (x
))
4508 return scm_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
4509 SCM_FRACTION_NUMERATOR (x
));
4511 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
4516 long xx
= SCM_INUM (x
);
4519 long yy
= SCM_INUM (y
);
4522 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4523 scm_num_overflow (s_divide
);
4525 return scm_make_real ((double) xx
/ (double) yy
);
4528 else if (xx
% yy
!= 0)
4531 return scm_make_real ((double) xx
/ (double) yy
);
4532 else return scm_make_ratio (x
, y
);
4537 if (SCM_FIXABLE (z
))
4538 return SCM_MAKINUM (z
);
4540 return scm_i_long2big (z
);
4543 else if (SCM_BIGP (y
))
4546 return scm_make_real ((double) xx
/ scm_i_big2dbl (y
));
4547 else return scm_make_ratio (x
, y
);
4549 else if (SCM_REALP (y
))
4551 double yy
= SCM_REAL_VALUE (y
);
4552 #ifndef ALLOW_DIVIDE_BY_ZERO
4554 scm_num_overflow (s_divide
);
4557 return scm_make_real ((double) xx
/ yy
);
4559 else if (SCM_COMPLEXP (y
))
4562 complex_div
: /* y _must_ be a complex number */
4564 double r
= SCM_COMPLEX_REAL (y
);
4565 double i
= SCM_COMPLEX_IMAG (y
);
4569 double d
= i
* (1.0 + t
* t
);
4570 return scm_make_complex ((a
* t
) / d
, -a
/ d
);
4575 double d
= r
* (1.0 + t
* t
);
4576 return scm_make_complex (a
/ d
, -(a
* t
) / d
);
4580 else if (SCM_FRACTIONP (y
))
4581 /* a / b/c = ac / b */
4582 return scm_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4583 SCM_FRACTION_NUMERATOR (y
));
4585 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4587 else if (SCM_BIGP (x
))
4591 long int yy
= SCM_INUM (y
);
4594 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4595 scm_num_overflow (s_divide
);
4597 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4598 scm_remember_upto_here_1 (x
);
4599 return (sgn
== 0) ? scm_nan () : scm_inf ();
4606 /* FIXME: HMM, what are the relative performance issues here?
4607 We need to test. Is it faster on average to test
4608 divisible_p, then perform whichever operation, or is it
4609 faster to perform the integer div opportunistically and
4610 switch to real if there's a remainder? For now we take the
4611 middle ground: test, then if divisible, use the faster div
4614 long abs_yy
= yy
< 0 ? -yy
: yy
;
4615 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
4619 SCM result
= scm_i_mkbig ();
4620 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
4621 scm_remember_upto_here_1 (x
);
4623 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
4624 return scm_i_normbig (result
);
4629 return scm_make_real (scm_i_big2dbl (x
) / (double) yy
);
4630 else return scm_make_ratio (x
, y
);
4634 else if (SCM_BIGP (y
))
4636 int y_is_zero
= (mpz_sgn (SCM_I_BIG_MPZ (y
)) == 0);
4639 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4640 scm_num_overflow (s_divide
);
4642 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4643 scm_remember_upto_here_1 (x
);
4644 return (sgn
== 0) ? scm_nan () : scm_inf ();
4650 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
4654 SCM result
= scm_i_mkbig ();
4655 mpz_divexact (SCM_I_BIG_MPZ (result
),
4658 scm_remember_upto_here_2 (x
, y
);
4659 return scm_i_normbig (result
);
4665 double dbx
= mpz_get_d (SCM_I_BIG_MPZ (x
));
4666 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4667 scm_remember_upto_here_2 (x
, y
);
4668 return scm_make_real (dbx
/ dby
);
4670 else return scm_make_ratio (x
, y
);
4674 else if (SCM_REALP (y
))
4676 double yy
= SCM_REAL_VALUE (y
);
4677 #ifndef ALLOW_DIVIDE_BY_ZERO
4679 scm_num_overflow (s_divide
);
4682 return scm_make_real (scm_i_big2dbl (x
) / yy
);
4684 else if (SCM_COMPLEXP (y
))
4686 a
= scm_i_big2dbl (x
);
4689 else if (SCM_FRACTIONP (y
))
4690 return scm_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4691 SCM_FRACTION_NUMERATOR (y
));
4693 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4695 else if (SCM_REALP (x
))
4697 double rx
= SCM_REAL_VALUE (x
);
4700 long int yy
= SCM_INUM (y
);
4701 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4703 scm_num_overflow (s_divide
);
4706 return scm_make_real (rx
/ (double) yy
);
4708 else if (SCM_BIGP (y
))
4710 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4711 scm_remember_upto_here_1 (y
);
4712 return scm_make_real (rx
/ dby
);
4714 else if (SCM_REALP (y
))
4716 double yy
= SCM_REAL_VALUE (y
);
4717 #ifndef ALLOW_DIVIDE_BY_ZERO
4719 scm_num_overflow (s_divide
);
4722 return scm_make_real (rx
/ yy
);
4724 else if (SCM_COMPLEXP (y
))
4729 else if (SCM_FRACTIONP (y
))
4730 return scm_make_real (rx
/ scm_i_fraction2double (y
));
4732 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4734 else if (SCM_COMPLEXP (x
))
4736 double rx
= SCM_COMPLEX_REAL (x
);
4737 double ix
= SCM_COMPLEX_IMAG (x
);
4740 long int yy
= SCM_INUM (y
);
4741 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4743 scm_num_overflow (s_divide
);
4748 return scm_make_complex (rx
/ d
, ix
/ d
);
4751 else if (SCM_BIGP (y
))
4753 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4754 scm_remember_upto_here_1 (y
);
4755 return scm_make_complex (rx
/ dby
, ix
/ dby
);
4757 else if (SCM_REALP (y
))
4759 double yy
= SCM_REAL_VALUE (y
);
4760 #ifndef ALLOW_DIVIDE_BY_ZERO
4762 scm_num_overflow (s_divide
);
4765 return scm_make_complex (rx
/ yy
, ix
/ yy
);
4767 else if (SCM_COMPLEXP (y
))
4769 double ry
= SCM_COMPLEX_REAL (y
);
4770 double iy
= SCM_COMPLEX_IMAG (y
);
4774 double d
= iy
* (1.0 + t
* t
);
4775 return scm_make_complex ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
4780 double d
= ry
* (1.0 + t
* t
);
4781 return scm_make_complex ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
4784 else if (SCM_FRACTIONP (y
))
4786 double yy
= scm_i_fraction2double (y
);
4787 return scm_make_complex (rx
/ yy
, ix
/ yy
);
4790 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4792 else if (SCM_FRACTIONP (x
))
4796 long int yy
= SCM_INUM (y
);
4797 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4799 scm_num_overflow (s_divide
);
4802 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x
),
4803 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
4805 else if (SCM_BIGP (y
))
4807 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x
),
4808 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
4810 else if (SCM_REALP (y
))
4812 double yy
= SCM_REAL_VALUE (y
);
4813 #ifndef ALLOW_DIVIDE_BY_ZERO
4815 scm_num_overflow (s_divide
);
4818 return scm_make_real (scm_i_fraction2double (x
) / yy
);
4820 else if (SCM_COMPLEXP (y
))
4822 a
= scm_i_fraction2double (x
);
4825 else if (SCM_FRACTIONP (y
))
4826 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
4827 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
4829 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4832 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
4836 scm_divide (SCM x
, SCM y
)
4838 return scm_i_divide (x
, y
, 0);
4841 static SCM
scm_divide2real (SCM x
, SCM y
)
4843 return scm_i_divide (x
, y
, 1);
4849 scm_asinh (double x
)
4854 #define asinh scm_asinh
4855 return log (x
+ sqrt (x
* x
+ 1));
4858 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_dsubr
, (SCM (*)()) asinh
, g_asinh
);
4859 /* "Return the inverse hyperbolic sine of @var{x}."
4864 scm_acosh (double x
)
4869 #define acosh scm_acosh
4870 return log (x
+ sqrt (x
* x
- 1));
4873 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_dsubr
, (SCM (*)()) acosh
, g_acosh
);
4874 /* "Return the inverse hyperbolic cosine of @var{x}."
4879 scm_atanh (double x
)
4884 #define atanh scm_atanh
4885 return 0.5 * log ((1 + x
) / (1 - x
));
4888 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_dsubr
, (SCM (*)()) atanh
, g_atanh
);
4889 /* "Return the inverse hyperbolic tangent of @var{x}."
4893 /* XXX - eventually, we should remove this definition of scm_round and
4894 rename scm_round_number to scm_round. Likewise for scm_truncate
4895 and scm_truncate_number.
4899 scm_truncate (double x
)
4904 #define trunc scm_truncate
4912 scm_round (double x
)
4914 double plus_half
= x
+ 0.5;
4915 double result
= floor (plus_half
);
4916 /* Adjust so that the scm_round is towards even. */
4917 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
4922 SCM_DEFINE (scm_truncate_number
, "truncate", 1, 0, 0,
4924 "Round the number @var{x} towards zero.")
4925 #define FUNC_NAME s_scm_truncate_number
4927 if (SCM_FALSEP (scm_negative_p (x
)))
4928 return scm_floor (x
);
4930 return scm_ceiling (x
);
4934 static SCM exactly_one_half
;
4936 SCM_DEFINE (scm_round_number
, "round", 1, 0, 0,
4938 "Round the number @var{x} towards the nearest integer. "
4939 "When it is exactly halfway between two integers, "
4940 "round towards the even one.")
4941 #define FUNC_NAME s_scm_round_number
4943 SCM plus_half
= scm_sum (x
, exactly_one_half
);
4944 SCM result
= scm_floor (plus_half
);
4945 /* Adjust so that the scm_round is towards even. */
4946 if (!SCM_FALSEP (scm_num_eq_p (plus_half
, result
))
4947 && !SCM_FALSEP (scm_odd_p (result
)))
4948 return scm_difference (result
, SCM_MAKINUM (1));
4954 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
4956 "Round the number @var{x} towards minus infinity.")
4957 #define FUNC_NAME s_scm_floor
4959 if (SCM_INUMP (x
) || SCM_BIGP (x
))
4961 else if (SCM_REALP (x
))
4962 return scm_make_real (floor (SCM_REAL_VALUE (x
)));
4963 else if (SCM_FRACTIONP (x
))
4965 SCM q
= scm_quotient (SCM_FRACTION_NUMERATOR (x
),
4966 SCM_FRACTION_DENOMINATOR (x
));
4967 if (SCM_FALSEP (scm_negative_p (x
)))
4969 /* For positive x, rounding towards zero is correct. */
4974 /* For negative x, we need to return q-1 unless x is an
4975 integer. But fractions are never integer, per our
4977 return scm_difference (q
, SCM_MAKINUM (1));
4981 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
4985 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
4987 "Round the number @var{x} towards infinity.")
4988 #define FUNC_NAME s_scm_ceiling
4990 if (SCM_INUMP (x
) || SCM_BIGP (x
))
4992 else if (SCM_REALP (x
))
4993 return scm_make_real (ceil (SCM_REAL_VALUE (x
)));
4994 else if (SCM_FRACTIONP (x
))
4996 SCM q
= scm_quotient (SCM_FRACTION_NUMERATOR (x
),
4997 SCM_FRACTION_DENOMINATOR (x
));
4998 if (SCM_FALSEP (scm_positive_p (x
)))
5000 /* For negative x, rounding towards zero is correct. */
5005 /* For positive x, we need to return q+1 unless x is an
5006 integer. But fractions are never integer, per our
5008 return scm_sum (q
, SCM_MAKINUM (1));
5012 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
5016 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_dsubr
, (SCM (*)()) sqrt
, g_i_sqrt
);
5017 /* "Return the square root of the real number @var{x}."
5019 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_dsubr
, (SCM (*)()) fabs
, g_i_abs
);
5020 /* "Return the absolute value of the real number @var{x}."
5022 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_dsubr
, (SCM (*)()) exp
, g_i_exp
);
5023 /* "Return the @var{x}th power of e."
5025 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_dsubr
, (SCM (*)()) log
, g_i_log
);
5026 /* "Return the natural logarithm of the real number @var{x}."
5028 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_dsubr
, (SCM (*)()) sin
, g_i_sin
);
5029 /* "Return the sine of the real number @var{x}."
5031 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_dsubr
, (SCM (*)()) cos
, g_i_cos
);
5032 /* "Return the cosine of the real number @var{x}."
5034 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_dsubr
, (SCM (*)()) tan
, g_i_tan
);
5035 /* "Return the tangent of the real number @var{x}."
5037 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_dsubr
, (SCM (*)()) asin
, g_i_asin
);
5038 /* "Return the arc sine of the real number @var{x}."
5040 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_dsubr
, (SCM (*)()) acos
, g_i_acos
);
5041 /* "Return the arc cosine of the real number @var{x}."
5043 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_dsubr
, (SCM (*)()) atan
, g_i_atan
);
5044 /* "Return the arc tangent of the real number @var{x}."
5046 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_dsubr
, (SCM (*)()) sinh
, g_i_sinh
);
5047 /* "Return the hyperbolic sine of the real number @var{x}."
5049 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_dsubr
, (SCM (*)()) cosh
, g_i_cosh
);
5050 /* "Return the hyperbolic cosine of the real number @var{x}."
5052 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_dsubr
, (SCM (*)()) tanh
, g_i_tanh
);
5053 /* "Return the hyperbolic tangent of the real number @var{x}."
5061 static void scm_two_doubles (SCM x
,
5063 const char *sstring
,
5067 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
5070 xy
->x
= SCM_INUM (x
);
5071 else if (SCM_BIGP (x
))
5072 xy
->x
= scm_i_big2dbl (x
);
5073 else if (SCM_REALP (x
))
5074 xy
->x
= SCM_REAL_VALUE (x
);
5075 else if (SCM_FRACTIONP (x
))
5076 xy
->x
= scm_i_fraction2double (x
);
5078 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
5081 xy
->y
= SCM_INUM (y
);
5082 else if (SCM_BIGP (y
))
5083 xy
->y
= scm_i_big2dbl (y
);
5084 else if (SCM_REALP (y
))
5085 xy
->y
= SCM_REAL_VALUE (y
);
5086 else if (SCM_FRACTIONP (y
))
5087 xy
->y
= scm_i_fraction2double (y
);
5089 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
5093 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
5095 "Return @var{x} raised to the power of @var{y}. This\n"
5096 "procedure does not accept complex arguments.")
5097 #define FUNC_NAME s_scm_sys_expt
5100 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
5101 return scm_make_real (pow (xy
.x
, xy
.y
));
5106 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
5108 "Return the arc tangent of the two arguments @var{x} and\n"
5109 "@var{y}. This is similar to calculating the arc tangent of\n"
5110 "@var{x} / @var{y}, except that the signs of both arguments\n"
5111 "are used to determine the quadrant of the result. This\n"
5112 "procedure does not accept complex arguments.")
5113 #define FUNC_NAME s_scm_sys_atan2
5116 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
5117 return scm_make_real (atan2 (xy
.x
, xy
.y
));
5122 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
5123 (SCM real
, SCM imaginary
),
5124 "Return a complex number constructed of the given @var{real} and\n"
5125 "@var{imaginary} parts.")
5126 #define FUNC_NAME s_scm_make_rectangular
5129 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
5130 return scm_make_complex (xy
.x
, xy
.y
);
5136 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
5138 "Return the complex number @var{x} * e^(i * @var{y}).")
5139 #define FUNC_NAME s_scm_make_polar
5143 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
5145 sincos (xy
.y
, &s
, &c
);
5150 return scm_make_complex (xy
.x
* c
, xy
.x
* s
);
5155 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
5156 /* "Return the real part of the number @var{z}."
5159 scm_real_part (SCM z
)
5163 else if (SCM_BIGP (z
))
5165 else if (SCM_REALP (z
))
5167 else if (SCM_COMPLEXP (z
))
5168 return scm_make_real (SCM_COMPLEX_REAL (z
));
5169 else if (SCM_FRACTIONP (z
))
5172 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
5176 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
5177 /* "Return the imaginary part of the number @var{z}."
5180 scm_imag_part (SCM z
)
5184 else if (SCM_BIGP (z
))
5186 else if (SCM_REALP (z
))
5188 else if (SCM_COMPLEXP (z
))
5189 return scm_make_real (SCM_COMPLEX_IMAG (z
));
5190 else if (SCM_FRACTIONP (z
))
5193 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
5196 SCM_GPROC (s_numerator
, "numerator", 1, 0, 0, scm_numerator
, g_numerator
);
5197 /* "Return the numerator of the number @var{z}."
5200 scm_numerator (SCM z
)
5204 else if (SCM_BIGP (z
))
5206 else if (SCM_FRACTIONP (z
))
5208 scm_i_fraction_reduce (z
);
5209 return SCM_FRACTION_NUMERATOR (z
);
5211 else if (SCM_REALP (z
))
5212 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
5214 SCM_WTA_DISPATCH_1 (g_numerator
, z
, SCM_ARG1
, s_numerator
);
5218 SCM_GPROC (s_denominator
, "denominator", 1, 0, 0, scm_denominator
, g_denominator
);
5219 /* "Return the denominator of the number @var{z}."
5222 scm_denominator (SCM z
)
5225 return SCM_MAKINUM (1);
5226 else if (SCM_BIGP (z
))
5227 return SCM_MAKINUM (1);
5228 else if (SCM_FRACTIONP (z
))
5230 scm_i_fraction_reduce (z
);
5231 return SCM_FRACTION_DENOMINATOR (z
);
5233 else if (SCM_REALP (z
))
5234 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
5236 SCM_WTA_DISPATCH_1 (g_denominator
, z
, SCM_ARG1
, s_denominator
);
5239 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
5240 /* "Return the magnitude of the number @var{z}. This is the same as\n"
5241 * "@code{abs} for real arguments, but also allows complex numbers."
5244 scm_magnitude (SCM z
)
5248 long int zz
= SCM_INUM (z
);
5251 else if (SCM_POSFIXABLE (-zz
))
5252 return SCM_MAKINUM (-zz
);
5254 return scm_i_long2big (-zz
);
5256 else if (SCM_BIGP (z
))
5258 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
5259 scm_remember_upto_here_1 (z
);
5261 return scm_i_clonebig (z
, 0);
5265 else if (SCM_REALP (z
))
5266 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
5267 else if (SCM_COMPLEXP (z
))
5268 return scm_make_real (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
5269 else if (SCM_FRACTIONP (z
))
5271 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
5273 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
5274 SCM_FRACTION_DENOMINATOR (z
));
5277 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
5281 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
5282 /* "Return the angle of the complex number @var{z}."
5287 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
5288 scm_flo0 to save allocating a new flonum with scm_make_real each time.
5289 But if atan2 follows the floating point rounding mode, then the value
5290 is not a constant. Maybe it'd be close enough though. */
5293 if (SCM_INUM (z
) >= 0)
5296 return scm_make_real (atan2 (0.0, -1.0));
5298 else if (SCM_BIGP (z
))
5300 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
5301 scm_remember_upto_here_1 (z
);
5303 return scm_make_real (atan2 (0.0, -1.0));
5307 else if (SCM_REALP (z
))
5309 if (SCM_REAL_VALUE (z
) >= 0)
5312 return scm_make_real (atan2 (0.0, -1.0));
5314 else if (SCM_COMPLEXP (z
))
5315 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
5316 else if (SCM_FRACTIONP (z
))
5318 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
5320 else return scm_make_real (atan2 (0.0, -1.0));
5323 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
5327 SCM_GPROC (s_exact_to_inexact
, "exact->inexact", 1, 0, 0, scm_exact_to_inexact
, g_exact_to_inexact
);
5328 /* Convert the number @var{x} to its inexact representation.\n"
5331 scm_exact_to_inexact (SCM z
)
5334 return scm_make_real ((double) SCM_INUM (z
));
5335 else if (SCM_BIGP (z
))
5336 return scm_make_real (scm_i_big2dbl (z
));
5337 else if (SCM_FRACTIONP (z
))
5338 return scm_make_real (scm_i_fraction2double (z
));
5339 else if (SCM_INEXACTP (z
))
5342 SCM_WTA_DISPATCH_1 (g_exact_to_inexact
, z
, 1, s_exact_to_inexact
);
5346 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
5348 "Return an exact number that is numerically closest to @var{z}.")
5349 #define FUNC_NAME s_scm_inexact_to_exact
5353 else if (SCM_BIGP (z
))
5355 else if (SCM_REALP (z
))
5357 if (xisinf (SCM_REAL_VALUE (z
)) || xisnan (SCM_REAL_VALUE (z
)))
5358 SCM_OUT_OF_RANGE (1, z
);
5365 mpq_set_d (frac
, SCM_REAL_VALUE (z
));
5366 q
= scm_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
5367 scm_i_mpz2num (mpq_denref (frac
)));
5369 /* When scm_make_ratio throws, we leak the memory allocated
5376 else if (SCM_FRACTIONP (z
))
5379 SCM_WRONG_TYPE_ARG (1, z
);
5383 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
5385 "Return an exact number that is within @var{err} of @var{x}.")
5386 #define FUNC_NAME s_scm_rationalize
5390 else if (SCM_BIGP (x
))
5392 else if ((SCM_REALP (x
)) || SCM_FRACTIONP (x
))
5394 /* Use continued fractions to find closest ratio. All
5395 arithmetic is done with exact numbers.
5398 SCM ex
= scm_inexact_to_exact (x
);
5399 SCM int_part
= scm_floor (ex
);
5400 SCM tt
= SCM_MAKINUM (1);
5401 SCM a1
= SCM_MAKINUM (0), a2
= SCM_MAKINUM (1), a
= SCM_MAKINUM (0);
5402 SCM b1
= SCM_MAKINUM (1), b2
= SCM_MAKINUM (0), b
= SCM_MAKINUM (0);
5406 if (!SCM_FALSEP (scm_num_eq_p (ex
, int_part
)))
5409 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
5410 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
5412 /* We stop after a million iterations just to be absolutely sure
5413 that we don't go into an infinite loop. The process normally
5414 converges after less than a dozen iterations.
5417 err
= scm_abs (err
);
5418 while (++i
< 1000000)
5420 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
5421 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
5422 if (SCM_FALSEP (scm_zero_p (b
)) && /* b != 0 */
5424 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
5425 err
))) /* abs(x-a/b) <= err */
5427 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
5428 if (SCM_FALSEP (scm_exact_p (x
))
5429 || SCM_FALSEP (scm_exact_p (err
)))
5430 return scm_exact_to_inexact (res
);
5434 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
5436 tt
= scm_floor (rx
); /* tt = floor (rx) */
5442 scm_num_overflow (s_scm_rationalize
);
5445 SCM_WRONG_TYPE_ARG (1, x
);
5449 /* if you need to change this, change test-num2integral.c as well */
5450 #if SCM_SIZEOF_LONG_LONG != 0
5452 # define ULLONG_MAX ((unsigned long long) (-1))
5453 # define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
5454 # define LLONG_MIN (~LLONG_MAX)
5458 /* Parameters for creating integer conversion routines.
5460 Define the following preprocessor macros before including
5461 "libguile/num2integral.i.c":
5463 NUM2INTEGRAL - the name of the function for converting from a
5464 Scheme object to the integral type. This function will be
5465 defined when including "num2integral.i.c".
5467 INTEGRAL2NUM - the name of the function for converting from the
5468 integral type to a Scheme object. This function will be defined.
5470 INTEGRAL2BIG - the name of an internal function that createas a
5471 bignum from the integral type. This function will be defined.
5472 The name should start with "scm_i_".
5474 ITYPE - the name of the integral type.
5476 UNSIGNED - Define this to 1 when ITYPE is an unsigned type. Define
5479 UNSIGNED_ITYPE - the name of the the unsigned variant of the
5480 integral type. If you don't define this, it defaults to
5481 "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned
5484 SIZEOF_ITYPE - an expression giving the size of the integral type
5485 in bytes. This expression must be computable by the
5486 preprocessor. (SIZEOF_FOO values are calculated by configure.in
5491 #define NUM2INTEGRAL scm_num2short
5492 #define INTEGRAL2NUM scm_short2num
5493 #define INTEGRAL2BIG scm_i_short2big
5496 #define SIZEOF_ITYPE SIZEOF_SHORT
5497 #include "libguile/num2integral.i.c"
5499 #define NUM2INTEGRAL scm_num2ushort
5500 #define INTEGRAL2NUM scm_ushort2num
5501 #define INTEGRAL2BIG scm_i_ushort2big
5503 #define ITYPE unsigned short
5504 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT
5505 #include "libguile/num2integral.i.c"
5507 #define NUM2INTEGRAL scm_num2int
5508 #define INTEGRAL2NUM scm_int2num
5509 #define INTEGRAL2BIG scm_i_int2big
5512 #define SIZEOF_ITYPE SIZEOF_INT
5513 #include "libguile/num2integral.i.c"
5515 #define NUM2INTEGRAL scm_num2uint
5516 #define INTEGRAL2NUM scm_uint2num
5517 #define INTEGRAL2BIG scm_i_uint2big
5519 #define ITYPE unsigned int
5520 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT
5521 #include "libguile/num2integral.i.c"
5523 #define NUM2INTEGRAL scm_num2long
5524 #define INTEGRAL2NUM scm_long2num
5525 #define INTEGRAL2BIG scm_i_long2big
5528 #define SIZEOF_ITYPE SIZEOF_LONG
5529 #include "libguile/num2integral.i.c"
5531 #define NUM2INTEGRAL scm_num2ulong
5532 #define INTEGRAL2NUM scm_ulong2num
5533 #define INTEGRAL2BIG scm_i_ulong2big
5535 #define ITYPE unsigned long
5536 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG
5537 #include "libguile/num2integral.i.c"
5539 #define NUM2INTEGRAL scm_num2ptrdiff
5540 #define INTEGRAL2NUM scm_ptrdiff2num
5541 #define INTEGRAL2BIG scm_i_ptrdiff2big
5543 #define ITYPE scm_t_ptrdiff
5544 #define UNSIGNED_ITYPE size_t
5545 #define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF
5546 #include "libguile/num2integral.i.c"
5548 #define NUM2INTEGRAL scm_num2size
5549 #define INTEGRAL2NUM scm_size2num
5550 #define INTEGRAL2BIG scm_i_size2big
5552 #define ITYPE size_t
5553 #define SIZEOF_ITYPE SIZEOF_SIZE_T
5554 #include "libguile/num2integral.i.c"
5556 #if SCM_SIZEOF_LONG_LONG != 0
5558 #ifndef ULONG_LONG_MAX
5559 #define ULONG_LONG_MAX (~0ULL)
5562 #define NUM2INTEGRAL scm_num2long_long
5563 #define INTEGRAL2NUM scm_long_long2num
5564 #define INTEGRAL2BIG scm_i_long_long2big
5566 #define ITYPE long long
5567 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
5568 #include "libguile/num2integral.i.c"
5570 #define NUM2INTEGRAL scm_num2ulong_long
5571 #define INTEGRAL2NUM scm_ulong_long2num
5572 #define INTEGRAL2BIG scm_i_ulong_long2big
5574 #define ITYPE unsigned long long
5575 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG
5576 #include "libguile/num2integral.i.c"
5578 #endif /* SCM_SIZEOF_LONG_LONG != 0 */
5580 #define NUM2FLOAT scm_num2float
5581 #define FLOAT2NUM scm_float2num
5583 #include "libguile/num2float.i.c"
5585 #define NUM2FLOAT scm_num2double
5586 #define FLOAT2NUM scm_double2num
5587 #define FTYPE double
5588 #include "libguile/num2float.i.c"
5593 #define SIZE_MAX ((size_t) (-1))
5596 #define PTRDIFF_MIN \
5597 ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 \
5598 << ((sizeof (scm_t_ptrdiff) * SCM_CHAR_BIT) - 1)))
5601 #define PTRDIFF_MAX (~ PTRDIFF_MIN)
5604 #define CHECK(type, v) \
5607 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
5627 CHECK (ptrdiff
, -1);
5629 CHECK (short, SHRT_MAX
);
5630 CHECK (short, SHRT_MIN
);
5631 CHECK (ushort
, USHRT_MAX
);
5632 CHECK (int, INT_MAX
);
5633 CHECK (int, INT_MIN
);
5634 CHECK (uint
, UINT_MAX
);
5635 CHECK (long, LONG_MAX
);
5636 CHECK (long, LONG_MIN
);
5637 CHECK (ulong
, ULONG_MAX
);
5638 CHECK (size
, SIZE_MAX
);
5639 CHECK (ptrdiff
, PTRDIFF_MAX
);
5640 CHECK (ptrdiff
, PTRDIFF_MIN
);
5642 #if SCM_SIZEOF_LONG_LONG != 0
5643 CHECK (long_long
, 0LL);
5644 CHECK (ulong_long
, 0ULL);
5645 CHECK (long_long
, -1LL);
5646 CHECK (long_long
, LLONG_MAX
);
5647 CHECK (long_long
, LLONG_MIN
);
5648 CHECK (ulong_long
, ULLONG_MAX
);
5655 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
5656 if (!SCM_FALSEP (data)) abort();
5659 check_body (void *data
)
5661 SCM num
= *(SCM
*) data
;
5662 scm_num2ulong (num
, 1, NULL
);
5664 return SCM_UNSPECIFIED
;
5668 check_handler (void *data
, SCM tag
, SCM throw_args
)
5670 SCM
*num
= (SCM
*) data
;
5673 return SCM_UNSPECIFIED
;
5676 SCM_DEFINE (scm_sys_check_number_conversions
, "%check-number-conversions", 0, 0, 0,
5678 "Number conversion sanity checking.")
5679 #define FUNC_NAME s_scm_sys_check_number_conversions
5681 SCM data
= SCM_MAKINUM (-1);
5683 data
= scm_int2num (INT_MIN
);
5685 data
= scm_ulong2num (ULONG_MAX
);
5686 data
= scm_difference (SCM_INUM0
, data
);
5688 data
= scm_ulong2num (ULONG_MAX
);
5689 data
= scm_sum (SCM_MAKINUM (1), data
); data
= scm_difference (SCM_INUM0
, data
);
5691 data
= scm_int2num (-10000); data
= scm_product (data
, data
); data
= scm_product (data
, data
);
5694 return SCM_UNSPECIFIED
;
5703 mpz_init_set_si (z_negative_one
, -1);
5705 /* It may be possible to tune the performance of some algorithms by using
5706 * the following constants to avoid the creation of bignums. Please, before
5707 * using these values, remember the two rules of program optimization:
5708 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
5709 scm_c_define ("most-positive-fixnum",
5710 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
5711 scm_c_define ("most-negative-fixnum",
5712 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
5714 scm_add_feature ("complex");
5715 scm_add_feature ("inexact");
5716 scm_flo0
= scm_make_real (0.0);
5718 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
5720 { /* determine floating point precision */
5722 double fsum
= 1.0 + f
;
5725 if (++scm_dblprec
> 20)
5733 scm_dblprec
= scm_dblprec
- 1;
5735 #endif /* DBL_DIG */
5741 exactly_one_half
= scm_permanent_object (scm_divide (SCM_MAKINUM (1),
5743 #include "libguile/numbers.x"