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)
127 /* For reference, sparc solaris 7 has infinities (IEEE) but doesn't have
128 isinf. It does have finite and isnan though, hence the use of those.
129 fpclass would be a possibility on that system too. */
133 #if defined (HAVE_ISINF)
135 #elif defined (HAVE_FINITE) && defined (HAVE_ISNAN)
136 return (! (finite (x
) || isnan (x
)));
145 #if defined (HAVE_ISNAN)
154 static mpz_t z_negative_one
;
158 SCM_C_INLINE_KEYWORD SCM
161 /* Return a newly created bignum. */
162 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
163 mpz_init (SCM_I_BIG_MPZ (z
));
167 SCM_C_INLINE_KEYWORD
static SCM
168 scm_i_clonebig (SCM src_big
, int same_sign_p
)
170 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
171 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
172 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
174 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
178 SCM_C_INLINE_KEYWORD
int
179 scm_i_bigcmp (SCM x
, SCM y
)
181 /* Return neg if x < y, pos if x > y, and 0 if x == y */
182 /* presume we already know x and y are bignums */
183 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
184 scm_remember_upto_here_2 (x
, y
);
188 SCM_C_INLINE_KEYWORD SCM
189 scm_i_dbl2big (double d
)
191 /* results are only defined if d is an integer */
192 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
193 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
197 /* Convert a integer in double representation to a SCM number. */
199 SCM_C_INLINE_KEYWORD SCM
200 scm_i_dbl2num (double u
)
202 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
203 powers of 2, so there's no rounding when making "double" values
204 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
205 get rounded on a 64-bit machine, hence the "+1".
207 The use of floor() to force to an integer value ensures we get a
208 "numerically closest" value without depending on how a
209 double->long cast or how mpz_set_d will round. For reference,
210 double->long probably follows the hardware rounding mode,
211 mpz_set_d truncates towards zero. */
213 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
214 representable as a double? */
216 if (u
< (double) (SCM_MOST_POSITIVE_FIXNUM
+1)
217 && u
>= (double) SCM_MOST_NEGATIVE_FIXNUM
)
218 return SCM_MAKINUM ((long) u
);
220 return scm_i_dbl2big (u
);
223 /* scm_i_big2dbl() rounds to the closest representable double, in accordance
224 with R5RS exact->inexact.
226 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
227 (ie. it truncates towards zero), then adjust to get the closest double by
228 examining the next lower bit and adding 1 if necessary.
230 Note that bignums exactly half way between representable doubles are
231 rounded to the next higher absolute value (ie. away from zero). This
232 seems like an adequate interpretation of R5RS "numerically closest", and
233 it's easier and faster than a full "nearest-even" style.
235 The bit test is done on the absolute value of the mpz_t, which means we
236 must use mpz_getlimbn. mpz_tstbit is not right, it treats negatives as
239 Prior to GMP 4.2, the rounding done by mpz_get_d was unspecified. It
240 happened to follow the hardware rounding mode, but on the absolute value
241 of its operand. This is not what we want, so we put the high
242 DBL_MANT_DIG bits into a temporary. This extra init/clear is a slowdown,
243 but doesn't matter too much since it's only for older GMP. */
246 scm_i_big2dbl (SCM b
)
251 bits
= mpz_sizeinbase (SCM_I_BIG_MPZ (b
), 2);
253 #if __GNU_MP_VERSION < 4 \
254 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2)
256 /* GMP prior to 4.2, force truncate towards zero */
258 if (bits
> DBL_MANT_DIG
)
260 size_t shift
= bits
- DBL_MANT_DIG
;
261 mpz_init2 (tmp
, DBL_MANT_DIG
);
262 mpz_tdiv_q_2exp (tmp
, SCM_I_BIG_MPZ (b
), shift
);
263 result
= ldexp (mpz_get_d (tmp
), shift
);
268 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
273 result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
276 if (bits
> DBL_MANT_DIG
)
278 unsigned long pos
= bits
- DBL_MANT_DIG
- 1;
279 /* test bit number "pos" in absolute value */
280 if (mpz_getlimbn (SCM_I_BIG_MPZ (b
), pos
/ GMP_NUMB_BITS
)
281 & ((mp_limb_t
) 1 << (pos
% GMP_NUMB_BITS
)))
283 result
+= ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b
)), pos
+ 1);
287 scm_remember_upto_here_1 (b
);
291 SCM_C_INLINE_KEYWORD SCM
292 scm_i_normbig (SCM b
)
294 /* convert a big back to a fixnum if it'll fit */
295 /* presume b is a bignum */
296 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
298 long val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
299 if (SCM_FIXABLE (val
))
300 b
= SCM_MAKINUM (val
);
305 static SCM_C_INLINE_KEYWORD SCM
306 scm_i_mpz2num (mpz_t b
)
308 /* convert a mpz number to a SCM number. */
309 if (mpz_fits_slong_p (b
))
311 long val
= mpz_get_si (b
);
312 if (SCM_FIXABLE (val
))
313 return SCM_MAKINUM (val
);
317 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
318 mpz_init_set (SCM_I_BIG_MPZ (z
), b
);
323 /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
324 static SCM
scm_divide2real (SCM x
, SCM y
);
327 scm_make_ratio (SCM numerator
, SCM denominator
)
328 #define FUNC_NAME "make-ratio"
330 /* First make sure the arguments are proper.
332 if (SCM_INUMP (denominator
))
334 if (SCM_EQ_P (denominator
, SCM_INUM0
))
335 scm_num_overflow ("make-ratio");
336 if (SCM_EQ_P (denominator
, SCM_MAKINUM(1)))
341 if (!(SCM_BIGP(denominator
)))
342 SCM_WRONG_TYPE_ARG (2, denominator
);
344 if (!SCM_INUMP (numerator
) && !SCM_BIGP (numerator
))
345 SCM_WRONG_TYPE_ARG (1, numerator
);
347 /* Then flip signs so that the denominator is positive.
349 if (SCM_NFALSEP (scm_negative_p (denominator
)))
351 numerator
= scm_difference (numerator
, SCM_UNDEFINED
);
352 denominator
= scm_difference (denominator
, SCM_UNDEFINED
);
355 /* Now consider for each of the four fixnum/bignum combinations
356 whether the rational number is really an integer.
358 if (SCM_INUMP (numerator
))
360 long x
= SCM_INUM (numerator
);
361 if (SCM_EQ_P (numerator
, SCM_INUM0
))
363 if (SCM_INUMP (denominator
))
366 y
= SCM_INUM (denominator
);
368 return SCM_MAKINUM(1);
370 return SCM_MAKINUM (x
/ y
);
374 /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
375 of that value for the denominator, as a bignum. Apart from
376 that case, abs(bignum) > abs(inum) so inum/bignum is not an
378 if (x
== SCM_MOST_NEGATIVE_FIXNUM
379 && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator
),
380 - SCM_MOST_NEGATIVE_FIXNUM
) == 0)
381 return SCM_MAKINUM(-1);
384 else if (SCM_BIGP (numerator
))
386 if (SCM_INUMP (denominator
))
388 long yy
= SCM_INUM (denominator
);
389 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator
), yy
))
390 return scm_divide (numerator
, denominator
);
394 if (SCM_EQ_P (numerator
, denominator
))
395 return SCM_MAKINUM(1);
396 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator
),
397 SCM_I_BIG_MPZ (denominator
)))
398 return scm_divide(numerator
, denominator
);
402 /* No, it's a proper fraction.
404 return scm_double_cell (scm_tc16_fraction
,
405 SCM_UNPACK (numerator
),
406 SCM_UNPACK (denominator
), 0);
410 static void scm_i_fraction_reduce (SCM z
)
412 if (!(SCM_FRACTION_REDUCED (z
)))
415 divisor
= scm_gcd (SCM_FRACTION_NUMERATOR (z
), SCM_FRACTION_DENOMINATOR (z
));
416 if (!(SCM_EQ_P (divisor
, SCM_MAKINUM(1))))
419 SCM_FRACTION_SET_NUMERATOR (z
, scm_divide (SCM_FRACTION_NUMERATOR (z
), divisor
));
420 SCM_FRACTION_SET_DENOMINATOR (z
, scm_divide (SCM_FRACTION_DENOMINATOR (z
), divisor
));
422 SCM_FRACTION_REDUCED_SET (z
);
427 scm_i_fraction2double (SCM z
)
429 return scm_num2dbl (scm_divide2real (SCM_FRACTION_NUMERATOR (z
),
430 SCM_FRACTION_DENOMINATOR (z
)),
434 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
436 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
438 #define FUNC_NAME s_scm_exact_p
444 if (SCM_FRACTIONP (x
))
448 SCM_WRONG_TYPE_ARG (1, x
);
453 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
455 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
457 #define FUNC_NAME s_scm_odd_p
461 long val
= SCM_INUM (n
);
462 return SCM_BOOL ((val
& 1L) != 0);
464 else if (SCM_BIGP (n
))
466 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
467 scm_remember_upto_here_1 (n
);
468 return SCM_BOOL (odd_p
);
470 else if (!SCM_FALSEP (scm_inf_p (n
)))
472 else if (SCM_REALP (n
))
474 double rem
= fabs (fmod (SCM_REAL_VALUE(n
), 2.0));
480 SCM_WRONG_TYPE_ARG (1, n
);
483 SCM_WRONG_TYPE_ARG (1, n
);
488 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
490 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
492 #define FUNC_NAME s_scm_even_p
496 long val
= SCM_INUM (n
);
497 return SCM_BOOL ((val
& 1L) == 0);
499 else if (SCM_BIGP (n
))
501 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
502 scm_remember_upto_here_1 (n
);
503 return SCM_BOOL (even_p
);
505 else if (!SCM_FALSEP (scm_inf_p (n
)))
507 else if (SCM_REALP (n
))
509 double rem
= fabs (fmod (SCM_REAL_VALUE(n
), 2.0));
515 SCM_WRONG_TYPE_ARG (1, n
);
518 SCM_WRONG_TYPE_ARG (1, n
);
522 SCM_DEFINE (scm_inf_p
, "inf?", 1, 0, 0,
524 "Return @code{#t} if @var{n} is infinite, @code{#f}\n"
526 #define FUNC_NAME s_scm_inf_p
529 return SCM_BOOL (xisinf (SCM_REAL_VALUE (n
)));
530 else if (SCM_COMPLEXP (n
))
531 return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n
))
532 || xisinf (SCM_COMPLEX_IMAG (n
)));
538 SCM_DEFINE (scm_nan_p
, "nan?", 1, 0, 0,
540 "Return @code{#t} if @var{n} is a NaN, @code{#f}\n"
542 #define FUNC_NAME s_scm_nan_p
545 return SCM_BOOL (xisnan (SCM_REAL_VALUE (n
)));
546 else if (SCM_COMPLEXP (n
))
547 return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n
))
548 || xisnan (SCM_COMPLEX_IMAG (n
)));
554 /* Guile's idea of infinity. */
555 static double guile_Inf
;
557 /* Guile's idea of not a number. */
558 static double guile_NaN
;
561 guile_ieee_init (void)
563 #if defined (HAVE_ISINF) || defined (HAVE_FINITE)
565 /* Some version of gcc on some old version of Linux used to crash when
566 trying to make Inf and NaN. */
569 /* C99 INFINITY, when available.
570 FIXME: The standard allows for INFINITY to be something that overflows
571 at compile time. We ought to have a configure test to check for that
572 before trying to use it. (But in practice we believe this is not a
573 problem on any system guile is likely to target.) */
574 guile_Inf
= INFINITY
;
577 extern unsigned int DINFINITY
[2];
578 guile_Inf
= (*(X_CAST(double *, DINFINITY
)));
585 if (guile_Inf
== tmp
)
593 #if defined (HAVE_ISNAN)
596 /* C99 NAN, when available */
600 extern unsigned int DQNAN
[2];
601 guile_NaN
= (*(X_CAST(double *, DQNAN
)));
603 guile_NaN
= guile_Inf
/ guile_Inf
;
609 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
612 #define FUNC_NAME s_scm_inf
614 static int initialized
= 0;
620 return scm_make_real (guile_Inf
);
624 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
627 #define FUNC_NAME s_scm_nan
629 static int initialized
= 0;
635 return scm_make_real (guile_NaN
);
640 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
642 "Return the absolute value of @var{x}.")
647 long int xx
= SCM_INUM (x
);
650 else if (SCM_POSFIXABLE (-xx
))
651 return SCM_MAKINUM (-xx
);
653 return scm_i_long2big (-xx
);
655 else if (SCM_BIGP (x
))
657 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
659 return scm_i_clonebig (x
, 0);
663 else if (SCM_REALP (x
))
665 /* note that if x is a NaN then xx<0 is false so we return x unchanged */
666 double xx
= SCM_REAL_VALUE (x
);
668 return scm_make_real (-xx
);
672 else if (SCM_FRACTIONP (x
))
674 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (x
))))
676 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
677 SCM_FRACTION_DENOMINATOR (x
));
680 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
685 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
686 /* "Return the quotient of the numbers @var{x} and @var{y}."
689 scm_quotient (SCM x
, SCM y
)
693 long xx
= SCM_INUM (x
);
696 long yy
= SCM_INUM (y
);
698 scm_num_overflow (s_quotient
);
703 return SCM_MAKINUM (z
);
705 return scm_i_long2big (z
);
708 else if (SCM_BIGP (y
))
710 if ((SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
)
711 && (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
712 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
714 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
715 scm_remember_upto_here_1 (y
);
716 return SCM_MAKINUM (-1);
719 return SCM_MAKINUM (0);
722 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
724 else if (SCM_BIGP (x
))
728 long yy
= SCM_INUM (y
);
730 scm_num_overflow (s_quotient
);
735 SCM result
= scm_i_mkbig ();
738 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result
),
741 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
744 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
745 scm_remember_upto_here_1 (x
);
746 return scm_i_normbig (result
);
749 else if (SCM_BIGP (y
))
751 SCM result
= scm_i_mkbig ();
752 mpz_tdiv_q (SCM_I_BIG_MPZ (result
),
755 scm_remember_upto_here_2 (x
, y
);
756 return scm_i_normbig (result
);
759 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
762 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
765 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
766 /* "Return the remainder of the numbers @var{x} and @var{y}.\n"
768 * "(remainder 13 4) @result{} 1\n"
769 * "(remainder -13 4) @result{} -1\n"
773 scm_remainder (SCM x
, SCM y
)
779 long yy
= SCM_INUM (y
);
781 scm_num_overflow (s_remainder
);
784 long z
= SCM_INUM (x
) % yy
;
785 return SCM_MAKINUM (z
);
788 else if (SCM_BIGP (y
))
790 if ((SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
)
791 && (mpz_cmp_ui (SCM_I_BIG_MPZ (y
),
792 - SCM_MOST_NEGATIVE_FIXNUM
) == 0))
794 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
795 scm_remember_upto_here_1 (y
);
796 return SCM_MAKINUM (0);
802 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
804 else if (SCM_BIGP (x
))
808 long yy
= SCM_INUM (y
);
810 scm_num_overflow (s_remainder
);
813 SCM result
= scm_i_mkbig ();
816 mpz_tdiv_r_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ(x
), yy
);
817 scm_remember_upto_here_1 (x
);
818 return scm_i_normbig (result
);
821 else if (SCM_BIGP (y
))
823 SCM result
= scm_i_mkbig ();
824 mpz_tdiv_r (SCM_I_BIG_MPZ (result
),
827 scm_remember_upto_here_2 (x
, y
);
828 return scm_i_normbig (result
);
831 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
834 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
838 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
839 /* "Return the modulo of the numbers @var{x} and @var{y}.\n"
841 * "(modulo 13 4) @result{} 1\n"
842 * "(modulo -13 4) @result{} 3\n"
846 scm_modulo (SCM x
, SCM y
)
850 long xx
= SCM_INUM (x
);
853 long yy
= SCM_INUM (y
);
855 scm_num_overflow (s_modulo
);
858 /* FIXME: I think this may be a bug on some arches -- results
859 of % with negative second arg are undefined... */
877 return SCM_MAKINUM (result
);
880 else if (SCM_BIGP (y
))
882 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
889 SCM pos_y
= scm_i_clonebig (y
, 0);
890 /* do this after the last scm_op */
891 mpz_init_set_si (z_x
, xx
);
892 result
= pos_y
; /* re-use this bignum */
893 mpz_mod (SCM_I_BIG_MPZ (result
),
895 SCM_I_BIG_MPZ (pos_y
));
896 scm_remember_upto_here_1 (pos_y
);
900 result
= scm_i_mkbig ();
901 /* do this after the last scm_op */
902 mpz_init_set_si (z_x
, xx
);
903 mpz_mod (SCM_I_BIG_MPZ (result
),
906 scm_remember_upto_here_1 (y
);
909 if ((sgn_y
< 0) && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
910 mpz_add (SCM_I_BIG_MPZ (result
),
912 SCM_I_BIG_MPZ (result
));
913 scm_remember_upto_here_1 (y
);
914 /* and do this before the next one */
916 return scm_i_normbig (result
);
920 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
922 else if (SCM_BIGP (x
))
926 long yy
= SCM_INUM (y
);
928 scm_num_overflow (s_modulo
);
931 SCM result
= scm_i_mkbig ();
932 mpz_mod_ui (SCM_I_BIG_MPZ (result
),
934 (yy
< 0) ? - yy
: yy
);
935 scm_remember_upto_here_1 (x
);
936 if ((yy
< 0) && (mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0))
937 mpz_sub_ui (SCM_I_BIG_MPZ (result
),
938 SCM_I_BIG_MPZ (result
),
940 return scm_i_normbig (result
);
943 else if (SCM_BIGP (y
))
946 SCM result
= scm_i_mkbig ();
947 int y_sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
948 SCM pos_y
= scm_i_clonebig (y
, y_sgn
>= 0);
949 mpz_mod (SCM_I_BIG_MPZ (result
),
951 SCM_I_BIG_MPZ (pos_y
));
953 scm_remember_upto_here_1 (x
);
954 if ((y_sgn
< 0) && (mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0))
955 mpz_add (SCM_I_BIG_MPZ (result
),
957 SCM_I_BIG_MPZ (result
));
958 scm_remember_upto_here_2 (y
, pos_y
);
959 return scm_i_normbig (result
);
963 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
966 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
969 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
970 /* "Return the greatest common divisor of all arguments.\n"
971 * "If called without arguments, 0 is returned."
974 scm_gcd (SCM x
, SCM y
)
977 return SCM_UNBNDP (x
) ? SCM_INUM0
: x
;
983 long xx
= SCM_INUM (x
);
984 long yy
= SCM_INUM (y
);
985 long u
= xx
< 0 ? -xx
: xx
;
986 long v
= yy
< 0 ? -yy
: yy
;
996 /* Determine a common factor 2^k */
997 while (!(1 & (u
| v
)))
1003 /* Now, any factor 2^n can be eliminated */
1023 return (SCM_POSFIXABLE (result
)
1024 ? SCM_MAKINUM (result
)
1025 : scm_i_long2big (result
));
1027 else if (SCM_BIGP (y
))
1033 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
1035 else if (SCM_BIGP (x
))
1039 unsigned long result
;
1047 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
1048 scm_remember_upto_here_1 (x
);
1049 return (SCM_POSFIXABLE (result
)
1050 ? SCM_MAKINUM (result
)
1051 : scm_ulong2num (result
));
1053 else if (SCM_BIGP (y
))
1055 SCM result
= scm_i_mkbig ();
1056 mpz_gcd (SCM_I_BIG_MPZ (result
),
1059 scm_remember_upto_here_2 (x
, y
);
1060 return scm_i_normbig (result
);
1063 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
1066 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
1069 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
1070 /* "Return the least common multiple of the arguments.\n"
1071 * "If called without arguments, 1 is returned."
1074 scm_lcm (SCM n1
, SCM n2
)
1076 if (SCM_UNBNDP (n2
))
1078 if (SCM_UNBNDP (n1
))
1079 return SCM_MAKINUM (1L);
1080 n2
= SCM_MAKINUM (1L);
1083 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
1084 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
1085 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
1086 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
1092 SCM d
= scm_gcd (n1
, n2
);
1093 if (SCM_EQ_P (d
, SCM_INUM0
))
1096 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
1100 /* inum n1, big n2 */
1103 SCM result
= scm_i_mkbig ();
1104 long nn1
= SCM_INUM (n1
);
1105 if (nn1
== 0) return SCM_INUM0
;
1106 if (nn1
< 0) nn1
= - nn1
;
1107 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
1108 scm_remember_upto_here_1 (n2
);
1123 SCM result
= scm_i_mkbig ();
1124 mpz_lcm(SCM_I_BIG_MPZ (result
),
1126 SCM_I_BIG_MPZ (n2
));
1127 scm_remember_upto_here_2(n1
, n2
);
1128 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
1134 #ifndef scm_long2num
1135 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
1137 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
1140 /* Emulating 2's complement bignums with sign magnitude arithmetic:
1145 + + + x (map digit:logand X Y)
1146 + - + x (map digit:logand X (lognot (+ -1 Y)))
1147 - + + y (map digit:logand (lognot (+ -1 X)) Y)
1148 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
1153 + + + (map digit:logior X Y)
1154 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
1155 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
1156 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
1161 + + + (map digit:logxor X Y)
1162 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
1163 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
1164 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
1169 + + (any digit:logand X Y)
1170 + - (any digit:logand X (lognot (+ -1 Y)))
1171 - + (any digit:logand (lognot (+ -1 X)) Y)
1176 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
1178 "Return the bitwise AND of the integer arguments.\n\n"
1180 "(logand) @result{} -1\n"
1181 "(logand 7) @result{} 7\n"
1182 "(logand #b111 #b011 #b001) @result{} 1\n"
1184 #define FUNC_NAME s_scm_logand
1188 if (SCM_UNBNDP (n2
))
1190 if (SCM_UNBNDP (n1
))
1191 return SCM_MAKINUM (-1);
1192 else if (!SCM_NUMBERP (n1
))
1193 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1194 else if (SCM_NUMBERP (n1
))
1197 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1202 nn1
= SCM_INUM (n1
);
1205 long nn2
= SCM_INUM (n2
);
1206 return SCM_MAKINUM (nn1
& nn2
);
1208 else if SCM_BIGP (n2
)
1214 SCM result_z
= scm_i_mkbig ();
1216 mpz_init_set_si (nn1_z
, nn1
);
1217 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
1218 scm_remember_upto_here_1 (n2
);
1220 return scm_i_normbig (result_z
);
1224 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1226 else if (SCM_BIGP (n1
))
1231 nn1
= SCM_INUM (n1
);
1234 else if (SCM_BIGP (n2
))
1236 SCM result_z
= scm_i_mkbig ();
1237 mpz_and (SCM_I_BIG_MPZ (result_z
),
1239 SCM_I_BIG_MPZ (n2
));
1240 scm_remember_upto_here_2 (n1
, n2
);
1241 return scm_i_normbig (result_z
);
1244 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1247 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1252 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
1254 "Return the bitwise OR of the integer arguments.\n\n"
1256 "(logior) @result{} 0\n"
1257 "(logior 7) @result{} 7\n"
1258 "(logior #b000 #b001 #b011) @result{} 3\n"
1260 #define FUNC_NAME s_scm_logior
1264 if (SCM_UNBNDP (n2
))
1266 if (SCM_UNBNDP (n1
))
1268 else if (SCM_NUMBERP (n1
))
1271 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1276 nn1
= SCM_INUM (n1
);
1279 long nn2
= SCM_INUM (n2
);
1280 return SCM_MAKINUM (nn1
| nn2
);
1282 else if (SCM_BIGP (n2
))
1288 SCM result_z
= scm_i_mkbig ();
1290 mpz_init_set_si (nn1_z
, nn1
);
1291 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
1292 scm_remember_upto_here_1 (n2
);
1298 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1300 else if (SCM_BIGP (n1
))
1305 nn1
= SCM_INUM (n1
);
1308 else if (SCM_BIGP (n2
))
1310 SCM result_z
= scm_i_mkbig ();
1311 mpz_ior (SCM_I_BIG_MPZ (result_z
),
1313 SCM_I_BIG_MPZ (n2
));
1314 scm_remember_upto_here_2 (n1
, n2
);
1318 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1321 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1326 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
1328 "Return the bitwise XOR of the integer arguments. A bit is\n"
1329 "set in the result if it is set in an odd number of arguments.\n"
1331 "(logxor) @result{} 0\n"
1332 "(logxor 7) @result{} 7\n"
1333 "(logxor #b000 #b001 #b011) @result{} 2\n"
1334 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
1336 #define FUNC_NAME s_scm_logxor
1340 if (SCM_UNBNDP (n2
))
1342 if (SCM_UNBNDP (n1
))
1344 else if (SCM_NUMBERP (n1
))
1347 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1352 nn1
= SCM_INUM (n1
);
1355 long nn2
= SCM_INUM (n2
);
1356 return SCM_MAKINUM (nn1
^ nn2
);
1358 else if (SCM_BIGP (n2
))
1362 SCM result_z
= scm_i_mkbig ();
1364 mpz_init_set_si (nn1_z
, nn1
);
1365 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
1366 scm_remember_upto_here_1 (n2
);
1368 return scm_i_normbig (result_z
);
1372 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1374 else if (SCM_BIGP (n1
))
1379 nn1
= SCM_INUM (n1
);
1382 else if (SCM_BIGP (n2
))
1384 SCM result_z
= scm_i_mkbig ();
1385 mpz_xor (SCM_I_BIG_MPZ (result_z
),
1387 SCM_I_BIG_MPZ (n2
));
1388 scm_remember_upto_here_2 (n1
, n2
);
1389 return scm_i_normbig (result_z
);
1392 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1395 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1400 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
1403 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
1404 "(logtest #b0100 #b1011) @result{} #f\n"
1405 "(logtest #b0100 #b0111) @result{} #t\n"
1407 #define FUNC_NAME s_scm_logtest
1416 long nk
= SCM_INUM (k
);
1417 return SCM_BOOL (nj
& nk
);
1419 else if (SCM_BIGP (k
))
1427 mpz_init_set_si (nj_z
, nj
);
1428 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
1429 scm_remember_upto_here_1 (k
);
1430 result
= SCM_BOOL (mpz_sgn (nj_z
) != 0);
1436 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1438 else if (SCM_BIGP (j
))
1446 else if (SCM_BIGP (k
))
1450 mpz_init (result_z
);
1454 scm_remember_upto_here_2 (j
, k
);
1455 result
= SCM_BOOL (mpz_sgn (result_z
) != 0);
1456 mpz_clear (result_z
);
1460 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1463 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
1468 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
1471 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1472 "(logbit? 0 #b1101) @result{} #t\n"
1473 "(logbit? 1 #b1101) @result{} #f\n"
1474 "(logbit? 2 #b1101) @result{} #t\n"
1475 "(logbit? 3 #b1101) @result{} #t\n"
1476 "(logbit? 4 #b1101) @result{} #f\n"
1478 #define FUNC_NAME s_scm_logbit_p
1480 unsigned long int iindex
;
1482 SCM_VALIDATE_INUM_MIN (SCM_ARG1
, index
, 0);
1483 iindex
= (unsigned long int) SCM_INUM (index
);
1487 /* bits above what's in an inum follow the sign bit */
1488 iindex
= min (iindex
, LONG_BIT
-1);
1489 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1491 else if (SCM_BIGP (j
))
1493 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
1494 scm_remember_upto_here_1 (j
);
1495 return SCM_BOOL (val
);
1498 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1503 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1505 "Return the integer which is the ones-complement of the integer\n"
1509 "(number->string (lognot #b10000000) 2)\n"
1510 " @result{} \"-10000001\"\n"
1511 "(number->string (lognot #b0) 2)\n"
1512 " @result{} \"-1\"\n"
1514 #define FUNC_NAME s_scm_lognot
1516 if (SCM_INUMP (n
)) {
1517 /* No overflow here, just need to toggle all the bits making up the inum.
1518 Enhancement: No need to strip the tag and add it back, could just xor
1519 a block of 1 bits, if that worked with the various debug versions of
1521 return SCM_MAKINUM (~ SCM_INUM (n
));
1523 } else if (SCM_BIGP (n
)) {
1524 SCM result
= scm_i_mkbig ();
1525 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
1526 scm_remember_upto_here_1 (n
);
1530 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1535 /* returns 0 if IN is not an integer. OUT must already be
1538 coerce_to_big (SCM in
, mpz_t out
)
1541 mpz_set (out
, SCM_I_BIG_MPZ (in
));
1542 else if (SCM_INUMP (in
))
1543 mpz_set_si (out
, SCM_INUM (in
));
1550 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
1551 (SCM n
, SCM k
, SCM m
),
1552 "Return @var{n} raised to the integer exponent\n"
1553 "@var{k}, modulo @var{m}.\n"
1556 "(modulo-expt 2 3 5)\n"
1559 #define FUNC_NAME s_scm_modulo_expt
1565 /* There are two classes of error we might encounter --
1566 1) Math errors, which we'll report by calling scm_num_overflow,
1568 2) wrong-type errors, which of course we'll report by calling
1570 We don't report those errors immediately, however; instead we do
1571 some cleanup first. These variables tell us which error (if
1572 any) we should report after cleaning up.
1574 int report_overflow
= 0;
1576 int position_of_wrong_type
= 0;
1577 SCM value_of_wrong_type
= SCM_INUM0
;
1579 SCM result
= SCM_UNDEFINED
;
1585 if (SCM_EQ_P (m
, SCM_INUM0
))
1587 report_overflow
= 1;
1591 if (!coerce_to_big (n
, n_tmp
))
1593 value_of_wrong_type
= n
;
1594 position_of_wrong_type
= 1;
1598 if (!coerce_to_big (k
, k_tmp
))
1600 value_of_wrong_type
= k
;
1601 position_of_wrong_type
= 2;
1605 if (!coerce_to_big (m
, m_tmp
))
1607 value_of_wrong_type
= m
;
1608 position_of_wrong_type
= 3;
1612 /* if the exponent K is negative, and we simply call mpz_powm, we
1613 will get a divide-by-zero exception when an inverse 1/n mod m
1614 doesn't exist (or is not unique). Since exceptions are hard to
1615 handle, we'll attempt the inversion "by hand" -- that way, we get
1616 a simple failure code, which is easy to handle. */
1618 if (-1 == mpz_sgn (k_tmp
))
1620 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
1622 report_overflow
= 1;
1625 mpz_neg (k_tmp
, k_tmp
);
1628 result
= scm_i_mkbig ();
1629 mpz_powm (SCM_I_BIG_MPZ (result
),
1634 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
1635 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
1642 if (report_overflow
)
1643 scm_num_overflow (FUNC_NAME
);
1645 if (position_of_wrong_type
)
1646 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
1647 value_of_wrong_type
);
1649 return scm_i_normbig (result
);
1653 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1655 "Return @var{n} raised to the non-negative integer exponent\n"
1659 "(integer-expt 2 5)\n"
1661 "(integer-expt -3 3)\n"
1664 #define FUNC_NAME s_scm_integer_expt
1667 SCM z_i2
= SCM_BOOL_F
;
1669 SCM acc
= SCM_MAKINUM (1L);
1671 /* 0^0 == 1 according to R5RS */
1672 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1673 return SCM_FALSEP (scm_zero_p(k
)) ? n
: acc
;
1674 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1675 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1679 else if (SCM_BIGP (k
))
1681 z_i2
= scm_i_clonebig (k
, 1);
1682 scm_remember_upto_here_1 (k
);
1685 else if (SCM_REALP (k
))
1687 double r
= SCM_REAL_VALUE (k
);
1689 SCM_WRONG_TYPE_ARG (2, k
);
1690 if ((r
> SCM_MOST_POSITIVE_FIXNUM
) || (r
< SCM_MOST_NEGATIVE_FIXNUM
))
1692 z_i2
= scm_i_mkbig ();
1693 mpz_set_d (SCM_I_BIG_MPZ (z_i2
), r
);
1702 SCM_WRONG_TYPE_ARG (2, k
);
1706 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
1708 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
1709 n
= scm_divide (n
, SCM_UNDEFINED
);
1713 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
1717 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
1719 return scm_product (acc
, n
);
1721 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
1722 acc
= scm_product (acc
, n
);
1723 n
= scm_product (n
, n
);
1724 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
1732 n
= scm_divide (n
, SCM_UNDEFINED
);
1739 return scm_product (acc
, n
);
1741 acc
= scm_product (acc
, n
);
1742 n
= scm_product (n
, n
);
1749 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1751 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
1752 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
1754 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
1755 "@var{cnt} is negative it's a division, rounded towards negative\n"
1756 "infinity. (Note that this is not the same rounding as\n"
1757 "@code{quotient} does.)\n"
1759 "With @var{n} viewed as an infinite precision twos complement,\n"
1760 "@code{ash} means a left shift introducing zero bits, or a right\n"
1761 "shift dropping bits.\n"
1764 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1765 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
1767 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
1768 "(ash -23 -2) @result{} -6\n"
1770 #define FUNC_NAME s_scm_ash
1774 SCM_VALIDATE_INUM (2, cnt
);
1776 bits_to_shift
= SCM_INUM (cnt
);
1778 if (bits_to_shift
< 0)
1780 /* Shift right by abs(cnt) bits. This is realized as a division
1781 by div:=2^abs(cnt). However, to guarantee the floor
1782 rounding, negative values require some special treatment.
1784 SCM div
= scm_integer_expt (SCM_MAKINUM (2),
1785 SCM_MAKINUM (-bits_to_shift
));
1787 /* scm_quotient assumes its arguments are integers, but it's legal to (ash 1/2 -1) */
1788 if (SCM_FALSEP (scm_negative_p (n
)))
1789 return scm_quotient (n
, div
);
1791 return scm_sum (SCM_MAKINUM (-1L),
1792 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1795 /* Shift left is done by multiplication with 2^CNT */
1796 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
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 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
1831 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
1833 /* Since we emulate two's complement encoded numbers, this
1834 * special case requires us to produce a result that has
1835 * more bits than can be stored in a fixnum.
1837 SCM result
= scm_i_long2big (in
);
1838 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
1843 /* mask down to requisite bits */
1844 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
1845 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1847 else if (SCM_BIGP (n
))
1852 result
= SCM_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
1856 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
1857 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
1858 such bits into a ulong. */
1859 result
= scm_i_mkbig ();
1860 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
1861 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
1862 result
= scm_i_normbig (result
);
1864 scm_remember_upto_here_1 (n
);
1868 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1873 static const char scm_logtab
[] = {
1874 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1877 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1879 "Return the number of bits in integer @var{n}. If integer is\n"
1880 "positive, the 1-bits in its binary representation are counted.\n"
1881 "If negative, the 0-bits in its two's-complement binary\n"
1882 "representation are counted. If 0, 0 is returned.\n"
1885 "(logcount #b10101010)\n"
1892 #define FUNC_NAME s_scm_logcount
1896 unsigned long int c
= 0;
1897 long int nn
= SCM_INUM (n
);
1902 c
+= scm_logtab
[15 & nn
];
1905 return SCM_MAKINUM (c
);
1907 else if (SCM_BIGP (n
))
1909 unsigned long count
;
1910 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
1911 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
1913 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
1914 scm_remember_upto_here_1 (n
);
1915 return SCM_MAKINUM (count
);
1918 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1923 static const char scm_ilentab
[] = {
1924 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1928 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1930 "Return the number of bits necessary to represent @var{n}.\n"
1933 "(integer-length #b10101010)\n"
1935 "(integer-length 0)\n"
1937 "(integer-length #b1111)\n"
1940 #define FUNC_NAME s_scm_integer_length
1944 unsigned long int c
= 0;
1946 long int nn
= SCM_INUM (n
);
1952 l
= scm_ilentab
[15 & nn
];
1955 return SCM_MAKINUM (c
- 4 + l
);
1957 else if (SCM_BIGP (n
))
1959 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
1960 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
1961 1 too big, so check for that and adjust. */
1962 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
1963 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
1964 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
1965 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
1967 scm_remember_upto_here_1 (n
);
1968 return SCM_MAKINUM (size
);
1971 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1975 /*** NUMBERS -> STRINGS ***/
1977 static const double fx
[] =
1978 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1979 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1980 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1981 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1984 idbl2str (double f
, char *a
)
1986 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1992 #ifdef HAVE_COPYSIGN
1993 double sgn
= copysign (1.0, f
);
1999 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
2005 strcpy (a
, "-inf.0");
2007 strcpy (a
, "+inf.0");
2010 else if (xisnan (f
))
2012 strcpy (a
, "+nan.0");
2022 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
2023 make-uniform-vector, from causing infinite loops. */
2027 if (exp
-- < DBL_MIN_10_EXP
)
2038 if (exp
++ > DBL_MAX_10_EXP
)
2058 if (f
+ fx
[wp
] >= 10.0)
2065 dpt
= (exp
+ 9999) % 3;
2069 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2094 if (f
+ fx
[wp
] >= 1.0)
2108 if ((dpt
> 4) && (exp
> 6))
2110 d
= (a
[0] == '-' ? 2 : 1);
2111 for (i
= ch
++; i
> d
; i
--)
2124 if (a
[ch
- 1] == '.')
2125 a
[ch
++] = '0'; /* trailing zero */
2134 for (i
= 10; i
<= exp
; i
*= 10);
2135 for (i
/= 10; i
; i
/= 10)
2137 a
[ch
++] = exp
/ i
+ '0';
2146 iflo2str (SCM flt
, char *str
)
2149 if (SCM_REALP (flt
))
2150 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2153 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2154 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2156 double imag
= SCM_COMPLEX_IMAG (flt
);
2157 /* Don't output a '+' for negative numbers or for Inf and
2158 NaN. They will provide their own sign. */
2159 if (0 <= imag
&& !xisinf (imag
) && !xisnan (imag
))
2161 i
+= idbl2str (imag
, &str
[i
]);
2168 /* convert a long to a string (unterminated). returns the number of
2169 characters in the result.
2171 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2173 scm_iint2str (long num
, int rad
, char *p
)
2177 unsigned long n
= (num
< 0) ? -num
: num
;
2179 for (n
/= rad
; n
> 0; n
/= rad
)
2196 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2201 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2203 "Return a string holding the external representation of the\n"
2204 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2205 "inexact, a radix of 10 will be used.")
2206 #define FUNC_NAME s_scm_number_to_string
2210 if (SCM_UNBNDP (radix
))
2214 SCM_VALIDATE_INUM (2, radix
);
2215 base
= SCM_INUM (radix
);
2216 /* FIXME: ask if range limit was OK, and if so, document */
2217 SCM_ASSERT_RANGE (2, radix
, (base
>= 2) && (base
<= 36));
2222 char num_buf
[SCM_INTBUFLEN
];
2223 size_t length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2224 return scm_mem2string (num_buf
, length
);
2226 else if (SCM_BIGP (n
))
2228 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
2229 scm_remember_upto_here_1 (n
);
2230 return scm_take0str (str
);
2232 else if (SCM_FRACTIONP (n
))
2234 scm_i_fraction_reduce (n
);
2235 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
2236 scm_mem2string ("/", 1),
2237 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
2239 else if (SCM_INEXACTP (n
))
2241 char num_buf
[FLOBUFLEN
];
2242 return scm_mem2string (num_buf
, iflo2str (n
, num_buf
));
2245 SCM_WRONG_TYPE_ARG (1, n
);
2250 /* These print routines used to be stubbed here so that scm_repl.c
2251 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
2254 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2256 char num_buf
[FLOBUFLEN
];
2257 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2262 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2265 char num_buf
[FLOBUFLEN
];
2266 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2271 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2274 scm_i_fraction_reduce (sexp
);
2275 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
2276 scm_lfwrite (SCM_STRING_CHARS (str
), SCM_STRING_LENGTH (str
), port
);
2277 scm_remember_upto_here_1 (str
);
2282 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2284 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
2285 scm_remember_upto_here_1 (exp
);
2286 scm_lfwrite (str
, (size_t) strlen (str
), port
);
2290 /*** END nums->strs ***/
2293 /*** STRINGS -> NUMBERS ***/
2295 /* The following functions implement the conversion from strings to numbers.
2296 * The implementation somehow follows the grammar for numbers as it is given
2297 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
2298 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
2299 * points should be noted about the implementation:
2300 * * Each function keeps a local index variable 'idx' that points at the
2301 * current position within the parsed string. The global index is only
2302 * updated if the function could parse the corresponding syntactic unit
2304 * * Similarly, the functions keep track of indicators of inexactness ('#',
2305 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
2306 * global exactness information is only updated after each part has been
2307 * successfully parsed.
2308 * * Sequences of digits are parsed into temporary variables holding fixnums.
2309 * Only if these fixnums would overflow, the result variables are updated
2310 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
2311 * the temporary variables holding the fixnums are cleared, and the process
2312 * starts over again. If for example fixnums were able to store five decimal
2313 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
2314 * and the result was computed as 12345 * 100000 + 67890. In other words,
2315 * only every five digits two bignum operations were performed.
2318 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
2320 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
2322 /* In non ASCII-style encodings the following macro might not work. */
2323 #define XDIGIT2UINT(d) \
2324 (isdigit ((int) (unsigned char) d) \
2326 : tolower ((int) (unsigned char) d) - 'a' + 10)
2329 mem2uinteger (const char* mem
, size_t len
, unsigned int *p_idx
,
2330 unsigned int radix
, enum t_exactness
*p_exactness
)
2332 unsigned int idx
= *p_idx
;
2333 unsigned int hash_seen
= 0;
2334 scm_t_bits shift
= 1;
2336 unsigned int digit_value
;
2344 if (!isxdigit ((int) (unsigned char) c
))
2346 digit_value
= XDIGIT2UINT (c
);
2347 if (digit_value
>= radix
)
2351 result
= SCM_MAKINUM (digit_value
);
2355 if (isxdigit ((int) (unsigned char) c
))
2359 digit_value
= XDIGIT2UINT (c
);
2360 if (digit_value
>= radix
)
2372 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
2374 result
= scm_product (result
, SCM_MAKINUM (shift
));
2376 result
= scm_sum (result
, SCM_MAKINUM (add
));
2383 shift
= shift
* radix
;
2384 add
= add
* radix
+ digit_value
;
2389 result
= scm_product (result
, SCM_MAKINUM (shift
));
2391 result
= scm_sum (result
, SCM_MAKINUM (add
));
2395 *p_exactness
= INEXACT
;
2401 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2402 * covers the parts of the rules that start at a potential point. The value
2403 * of the digits up to the point have been parsed by the caller and are given
2404 * in variable result. The content of *p_exactness indicates, whether a hash
2405 * has already been seen in the digits before the point.
2408 /* In non ASCII-style encodings the following macro might not work. */
2409 #define DIGIT2UINT(d) ((d) - '0')
2412 mem2decimal_from_point (SCM result
, const char* mem
, size_t len
,
2413 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
2415 unsigned int idx
= *p_idx
;
2416 enum t_exactness x
= *p_exactness
;
2421 if (mem
[idx
] == '.')
2423 scm_t_bits shift
= 1;
2425 unsigned int digit_value
;
2426 SCM big_shift
= SCM_MAKINUM (1);
2432 if (isdigit ((int) (unsigned char) c
))
2437 digit_value
= DIGIT2UINT (c
);
2448 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
2450 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2451 result
= scm_product (result
, SCM_MAKINUM (shift
));
2453 result
= scm_sum (result
, SCM_MAKINUM (add
));
2461 add
= add
* 10 + digit_value
;
2467 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2468 result
= scm_product (result
, SCM_MAKINUM (shift
));
2469 result
= scm_sum (result
, SCM_MAKINUM (add
));
2472 result
= scm_divide (result
, big_shift
);
2474 /* We've seen a decimal point, thus the value is implicitly inexact. */
2486 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2513 if (!isdigit ((int) (unsigned char) c
))
2517 exponent
= DIGIT2UINT (c
);
2521 if (isdigit ((int) (unsigned char) c
))
2524 if (exponent
<= SCM_MAXEXP
)
2525 exponent
= exponent
* 10 + DIGIT2UINT (c
);
2531 if (exponent
> SCM_MAXEXP
)
2533 size_t exp_len
= idx
- start
;
2534 SCM exp_string
= scm_mem2string (&mem
[start
], exp_len
);
2535 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
2536 scm_out_of_range ("string->number", exp_num
);
2539 e
= scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent
));
2541 result
= scm_product (result
, e
);
2543 result
= scm_divide2real (result
, e
);
2545 /* We've seen an exponent, thus the value is implicitly inexact. */
2563 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2566 mem2ureal (const char* mem
, size_t len
, unsigned int *p_idx
,
2567 unsigned int radix
, enum t_exactness
*p_exactness
)
2569 unsigned int idx
= *p_idx
;
2575 if (idx
+5 <= len
&& !strncmp (mem
+idx
, "inf.0", 5))
2581 if (idx
+4 < len
&& !strncmp (mem
+idx
, "nan.", 4))
2583 enum t_exactness x
= EXACT
;
2585 /* Cobble up the fractional part. We might want to set the
2586 NaN's mantissa from it. */
2588 mem2uinteger (mem
, len
, &idx
, 10, &x
);
2593 if (mem
[idx
] == '.')
2597 else if (idx
+ 1 == len
)
2599 else if (!isdigit ((int) (unsigned char) mem
[idx
+ 1]))
2602 result
= mem2decimal_from_point (SCM_MAKINUM (0), mem
, len
,
2603 p_idx
, p_exactness
);
2607 enum t_exactness x
= EXACT
;
2610 uinteger
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2611 if (SCM_FALSEP (uinteger
))
2616 else if (mem
[idx
] == '/')
2622 divisor
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2623 if (SCM_FALSEP (divisor
))
2626 /* both are int/big here, I assume */
2627 result
= scm_make_ratio (uinteger
, divisor
);
2629 else if (radix
== 10)
2631 result
= mem2decimal_from_point (uinteger
, mem
, len
, &idx
, &x
);
2632 if (SCM_FALSEP (result
))
2643 /* When returning an inexact zero, make sure it is represented as a
2644 floating point value so that we can change its sign.
2646 if (SCM_EQ_P (result
, SCM_MAKINUM(0)) && *p_exactness
== INEXACT
)
2647 result
= scm_make_real (0.0);
2653 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2656 mem2complex (const char* mem
, size_t len
, unsigned int idx
,
2657 unsigned int radix
, enum t_exactness
*p_exactness
)
2681 ureal
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2682 if (SCM_FALSEP (ureal
))
2684 /* input must be either +i or -i */
2689 if (mem
[idx
] == 'i' || mem
[idx
] == 'I')
2695 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign
));
2702 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2703 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
2712 /* either +<ureal>i or -<ureal>i */
2719 return scm_make_rectangular (SCM_MAKINUM (0), ureal
);
2722 /* polar input: <real>@<real>. */
2747 angle
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2748 if (SCM_FALSEP (angle
))
2753 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2754 angle
= scm_difference (angle
, SCM_UNDEFINED
);
2756 result
= scm_make_polar (ureal
, angle
);
2761 /* expecting input matching <real>[+-]<ureal>?i */
2768 int sign
= (c
== '+') ? 1 : -1;
2769 SCM imag
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2771 if (SCM_FALSEP (imag
))
2772 imag
= SCM_MAKINUM (sign
);
2773 else if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2774 imag
= scm_difference (imag
, SCM_UNDEFINED
);
2778 if (mem
[idx
] != 'i' && mem
[idx
] != 'I')
2785 return scm_make_rectangular (ureal
, imag
);
2794 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2796 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
2799 scm_i_mem2number (const char* mem
, size_t len
, unsigned int default_radix
)
2801 unsigned int idx
= 0;
2802 unsigned int radix
= NO_RADIX
;
2803 enum t_exactness forced_x
= NO_EXACTNESS
;
2804 enum t_exactness implicit_x
= EXACT
;
2807 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2808 while (idx
+ 2 < len
&& mem
[idx
] == '#')
2810 switch (mem
[idx
+ 1])
2813 if (radix
!= NO_RADIX
)
2818 if (radix
!= NO_RADIX
)
2823 if (forced_x
!= NO_EXACTNESS
)
2828 if (forced_x
!= NO_EXACTNESS
)
2833 if (radix
!= NO_RADIX
)
2838 if (radix
!= NO_RADIX
)
2848 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2849 if (radix
== NO_RADIX
)
2850 result
= mem2complex (mem
, len
, idx
, default_radix
, &implicit_x
);
2852 result
= mem2complex (mem
, len
, idx
, (unsigned int) radix
, &implicit_x
);
2854 if (SCM_FALSEP (result
))
2860 if (SCM_INEXACTP (result
))
2861 return scm_inexact_to_exact (result
);
2865 if (SCM_INEXACTP (result
))
2868 return scm_exact_to_inexact (result
);
2871 if (implicit_x
== INEXACT
)
2873 if (SCM_INEXACTP (result
))
2876 return scm_exact_to_inexact (result
);
2884 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2885 (SCM string
, SCM radix
),
2886 "Return a number of the maximally precise representation\n"
2887 "expressed by the given @var{string}. @var{radix} must be an\n"
2888 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2889 "is a default radix that may be overridden by an explicit radix\n"
2890 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2891 "supplied, then the default radix is 10. If string is not a\n"
2892 "syntactically valid notation for a number, then\n"
2893 "@code{string->number} returns @code{#f}.")
2894 #define FUNC_NAME s_scm_string_to_number
2898 SCM_VALIDATE_STRING (1, string
);
2899 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix
,2,10, base
);
2900 answer
= scm_i_mem2number (SCM_STRING_CHARS (string
),
2901 SCM_STRING_LENGTH (string
),
2903 return scm_return_first (answer
, string
);
2908 /*** END strs->nums ***/
2912 scm_make_real (double x
)
2914 SCM z
= scm_double_cell (scm_tc16_real
, 0, 0, 0);
2916 SCM_REAL_VALUE (z
) = x
;
2922 scm_make_complex (double x
, double y
)
2925 return scm_make_real (x
);
2929 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_gc_malloc (sizeof (scm_t_complex
),
2931 SCM_COMPLEX_REAL (z
) = x
;
2932 SCM_COMPLEX_IMAG (z
) = y
;
2939 scm_bigequal (SCM x
, SCM y
)
2941 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2942 scm_remember_upto_here_2 (x
, y
);
2943 return SCM_BOOL (0 == result
);
2947 scm_real_equalp (SCM x
, SCM y
)
2949 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2953 scm_complex_equalp (SCM x
, SCM y
)
2955 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2956 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2960 scm_i_fraction_equalp (SCM x
, SCM y
)
2962 scm_i_fraction_reduce (x
);
2963 scm_i_fraction_reduce (y
);
2964 if (SCM_FALSEP (scm_equal_p (SCM_FRACTION_NUMERATOR (x
),
2965 SCM_FRACTION_NUMERATOR (y
)))
2966 || SCM_FALSEP (scm_equal_p (SCM_FRACTION_DENOMINATOR (x
),
2967 SCM_FRACTION_DENOMINATOR (y
))))
2974 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2975 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2976 * "else. Note that the sets of complex, real, rational and\n"
2977 * "integer values form subsets of the set of numbers, i. e. the\n"
2978 * "predicate will be fulfilled for any number."
2980 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2982 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2983 "otherwise. Note that the sets of real, rational and integer\n"
2984 "values form subsets of the set of complex numbers, i. e. the\n"
2985 "predicate will also be fulfilled if @var{x} is a real,\n"
2986 "rational or integer number.")
2987 #define FUNC_NAME s_scm_number_p
2989 return SCM_BOOL (SCM_NUMBERP (x
));
2994 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
2996 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
2997 "otherwise. Note that the set of integer values forms a subset of\n"
2998 "the set of real numbers, i. e. the predicate will also be\n"
2999 "fulfilled if @var{x} is an integer number.")
3000 #define FUNC_NAME s_scm_real_p
3002 /* we can't represent irrational numbers. */
3003 return scm_rational_p (x
);
3007 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
3009 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
3010 "otherwise. Note that the set of integer values forms a subset of\n"
3011 "the set of rational numbers, i. e. the predicate will also be\n"
3012 "fulfilled if @var{x} is an integer number.")
3013 #define FUNC_NAME s_scm_rational_p
3017 else if (SCM_IMP (x
))
3019 else if (SCM_BIGP (x
))
3021 else if (SCM_FRACTIONP (x
))
3023 else if (SCM_REALP (x
))
3024 /* due to their limited precision, all floating point numbers are
3025 rational as well. */
3033 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
3035 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
3037 #define FUNC_NAME s_scm_integer_p
3046 if (!SCM_INEXACTP (x
))
3048 if (SCM_COMPLEXP (x
))
3050 r
= SCM_REAL_VALUE (x
);
3058 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
3060 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
3062 #define FUNC_NAME s_scm_inexact_p
3064 if (SCM_INEXACTP (x
))
3066 if (SCM_NUMBERP (x
))
3068 SCM_WRONG_TYPE_ARG (1, x
);
3073 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
3074 /* "Return @code{#t} if all parameters are numerically equal." */
3076 scm_num_eq_p (SCM x
, SCM y
)
3081 long xx
= SCM_INUM (x
);
3084 long yy
= SCM_INUM (y
);
3085 return SCM_BOOL (xx
== yy
);
3087 else if (SCM_BIGP (y
))
3089 else if (SCM_REALP (y
))
3090 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
3091 else if (SCM_COMPLEXP (y
))
3092 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
3093 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3094 else if (SCM_FRACTIONP (y
))
3097 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3099 else if (SCM_BIGP (x
))
3103 else if (SCM_BIGP (y
))
3105 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3106 scm_remember_upto_here_2 (x
, y
);
3107 return SCM_BOOL (0 == cmp
);
3109 else if (SCM_REALP (y
))
3112 if (xisnan (SCM_REAL_VALUE (y
)))
3114 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
3115 scm_remember_upto_here_1 (x
);
3116 return SCM_BOOL (0 == cmp
);
3118 else if (SCM_COMPLEXP (y
))
3121 if (0.0 != SCM_COMPLEX_IMAG (y
))
3123 if (xisnan (SCM_COMPLEX_REAL (y
)))
3125 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
3126 scm_remember_upto_here_1 (x
);
3127 return SCM_BOOL (0 == cmp
);
3129 else if (SCM_FRACTIONP (y
))
3132 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3134 else if (SCM_REALP (x
))
3137 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3138 else if (SCM_BIGP (y
))
3141 if (xisnan (SCM_REAL_VALUE (x
)))
3143 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
3144 scm_remember_upto_here_1 (y
);
3145 return SCM_BOOL (0 == cmp
);
3147 else if (SCM_REALP (y
))
3148 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3149 else if (SCM_COMPLEXP (y
))
3150 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3151 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3152 else if (SCM_FRACTIONP (y
))
3154 double xx
= SCM_REAL_VALUE (x
);
3158 return SCM_BOOL (xx
< 0.0);
3159 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
3163 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3165 else if (SCM_COMPLEXP (x
))
3168 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3169 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3170 else if (SCM_BIGP (y
))
3173 if (0.0 != SCM_COMPLEX_IMAG (x
))
3175 if (xisnan (SCM_COMPLEX_REAL (x
)))
3177 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
3178 scm_remember_upto_here_1 (y
);
3179 return SCM_BOOL (0 == cmp
);
3181 else if (SCM_REALP (y
))
3182 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3183 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3184 else if (SCM_COMPLEXP (y
))
3185 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3186 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3187 else if (SCM_FRACTIONP (y
))
3190 if (SCM_COMPLEX_IMAG (x
) != 0.0)
3192 xx
= SCM_COMPLEX_REAL (x
);
3196 return SCM_BOOL (xx
< 0.0);
3197 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
3201 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3203 else if (SCM_FRACTIONP (x
))
3207 else if (SCM_BIGP (y
))
3209 else if (SCM_REALP (y
))
3211 double yy
= SCM_REAL_VALUE (y
);
3215 return SCM_BOOL (0.0 < yy
);
3216 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
3219 else if (SCM_COMPLEXP (y
))
3222 if (SCM_COMPLEX_IMAG (y
) != 0.0)
3224 yy
= SCM_COMPLEX_REAL (y
);
3228 return SCM_BOOL (0.0 < yy
);
3229 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
3232 else if (SCM_FRACTIONP (y
))
3233 return scm_i_fraction_equalp (x
, y
);
3235 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3238 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3242 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
3243 done are good for inums, but for bignums an answer can almost always be
3244 had by just examining a few high bits of the operands, as done by GMP in
3245 mpq_cmp. flonum/frac compares likewise, but with the slight complication
3246 of the float exponent to take into account. */
3248 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3249 /* "Return @code{#t} if the list of parameters is monotonically\n"
3253 scm_less_p (SCM x
, SCM y
)
3258 long xx
= SCM_INUM (x
);
3261 long yy
= SCM_INUM (y
);
3262 return SCM_BOOL (xx
< yy
);
3264 else if (SCM_BIGP (y
))
3266 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3267 scm_remember_upto_here_1 (y
);
3268 return SCM_BOOL (sgn
> 0);
3270 else if (SCM_REALP (y
))
3271 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3272 else if (SCM_FRACTIONP (y
))
3274 /* "x < a/b" becomes "x*b < a" */
3276 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
3277 y
= SCM_FRACTION_NUMERATOR (y
);
3281 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3283 else if (SCM_BIGP (x
))
3287 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3288 scm_remember_upto_here_1 (x
);
3289 return SCM_BOOL (sgn
< 0);
3291 else if (SCM_BIGP (y
))
3293 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3294 scm_remember_upto_here_2 (x
, y
);
3295 return SCM_BOOL (cmp
< 0);
3297 else if (SCM_REALP (y
))
3300 if (xisnan (SCM_REAL_VALUE (y
)))
3302 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
3303 scm_remember_upto_here_1 (x
);
3304 return SCM_BOOL (cmp
< 0);
3306 else if (SCM_FRACTIONP (y
))
3309 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3311 else if (SCM_REALP (x
))
3314 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3315 else if (SCM_BIGP (y
))
3318 if (xisnan (SCM_REAL_VALUE (x
)))
3320 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
3321 scm_remember_upto_here_1 (y
);
3322 return SCM_BOOL (cmp
> 0);
3324 else if (SCM_REALP (y
))
3325 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3326 else if (SCM_FRACTIONP (y
))
3328 double xx
= SCM_REAL_VALUE (x
);
3332 return SCM_BOOL (xx
< 0.0);
3333 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
3337 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3339 else if (SCM_FRACTIONP (x
))
3341 if (SCM_INUMP (y
) || SCM_BIGP (y
))
3343 /* "a/b < y" becomes "a < y*b" */
3344 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
3345 x
= SCM_FRACTION_NUMERATOR (x
);
3348 else if (SCM_REALP (y
))
3350 double yy
= SCM_REAL_VALUE (y
);
3354 return SCM_BOOL (0.0 < yy
);
3355 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
3358 else if (SCM_FRACTIONP (y
))
3360 /* "a/b < c/d" becomes "a*d < c*b" */
3361 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
3362 SCM_FRACTION_DENOMINATOR (y
));
3363 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
3364 SCM_FRACTION_DENOMINATOR (x
));
3370 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3373 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3377 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3378 /* "Return @code{#t} if the list of parameters is monotonically\n"
3381 #define FUNC_NAME s_scm_gr_p
3383 scm_gr_p (SCM x
, SCM y
)
3385 if (!SCM_NUMBERP (x
))
3386 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3387 else if (!SCM_NUMBERP (y
))
3388 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3390 return scm_less_p (y
, x
);
3395 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3396 /* "Return @code{#t} if the list of parameters is monotonically\n"
3399 #define FUNC_NAME s_scm_leq_p
3401 scm_leq_p (SCM x
, SCM y
)
3403 if (!SCM_NUMBERP (x
))
3404 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3405 else if (!SCM_NUMBERP (y
))
3406 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3407 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
3410 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3415 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3416 /* "Return @code{#t} if the list of parameters is monotonically\n"
3419 #define FUNC_NAME s_scm_geq_p
3421 scm_geq_p (SCM x
, SCM y
)
3423 if (!SCM_NUMBERP (x
))
3424 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3425 else if (!SCM_NUMBERP (y
))
3426 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3427 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
3430 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3435 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3436 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3443 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3444 else if (SCM_BIGP (z
))
3446 else if (SCM_REALP (z
))
3447 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3448 else if (SCM_COMPLEXP (z
))
3449 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3450 && SCM_COMPLEX_IMAG (z
) == 0.0);
3451 else if (SCM_FRACTIONP (z
))
3454 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3458 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3459 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3463 scm_positive_p (SCM x
)
3466 return SCM_BOOL (SCM_INUM (x
) > 0);
3467 else if (SCM_BIGP (x
))
3469 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3470 scm_remember_upto_here_1 (x
);
3471 return SCM_BOOL (sgn
> 0);
3473 else if (SCM_REALP (x
))
3474 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3475 else if (SCM_FRACTIONP (x
))
3476 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
3478 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3482 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3483 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3487 scm_negative_p (SCM x
)
3490 return SCM_BOOL (SCM_INUM (x
) < 0);
3491 else if (SCM_BIGP (x
))
3493 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3494 scm_remember_upto_here_1 (x
);
3495 return SCM_BOOL (sgn
< 0);
3497 else if (SCM_REALP (x
))
3498 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3499 else if (SCM_FRACTIONP (x
))
3500 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
3502 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3506 /* scm_min and scm_max return an inexact when either argument is inexact, as
3507 required by r5rs. On that basis, for exact/inexact combinations the
3508 exact is converted to inexact to compare and possibly return. This is
3509 unlike scm_less_p above which takes some trouble to preserve all bits in
3510 its test, such trouble is not required for min and max. */
3512 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3513 /* "Return the maximum of all parameter values."
3516 scm_max (SCM x
, SCM y
)
3521 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
3522 else if (SCM_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
3525 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3530 long xx
= SCM_INUM (x
);
3533 long yy
= SCM_INUM (y
);
3534 return (xx
< yy
) ? y
: x
;
3536 else if (SCM_BIGP (y
))
3538 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3539 scm_remember_upto_here_1 (y
);
3540 return (sgn
< 0) ? x
: y
;
3542 else if (SCM_REALP (y
))
3545 /* if y==NaN then ">" is false and we return NaN */
3546 return (z
> SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3548 else if (SCM_FRACTIONP (y
))
3551 return (SCM_FALSEP (scm_less_p (x
, y
)) ? x
: y
);
3554 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3556 else if (SCM_BIGP (x
))
3560 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3561 scm_remember_upto_here_1 (x
);
3562 return (sgn
< 0) ? y
: x
;
3564 else if (SCM_BIGP (y
))
3566 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3567 scm_remember_upto_here_2 (x
, y
);
3568 return (cmp
> 0) ? x
: y
;
3570 else if (SCM_REALP (y
))
3572 /* if y==NaN then xx>yy is false, so we return the NaN y */
3575 xx
= scm_i_big2dbl (x
);
3576 yy
= SCM_REAL_VALUE (y
);
3577 return (xx
> yy
? scm_make_real (xx
) : y
);
3579 else if (SCM_FRACTIONP (y
))
3584 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3586 else if (SCM_REALP (x
))
3590 double z
= SCM_INUM (y
);
3591 /* if x==NaN then "<" is false and we return NaN */
3592 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3594 else if (SCM_BIGP (y
))
3599 else if (SCM_REALP (y
))
3601 /* if x==NaN then our explicit check means we return NaN
3602 if y==NaN then ">" is false and we return NaN
3603 calling isnan is unavoidable, since it's the only way to know
3604 which of x or y causes any compares to be false */
3605 double xx
= SCM_REAL_VALUE (x
);
3606 return (xisnan (xx
) || xx
> SCM_REAL_VALUE (y
)) ? x
: y
;
3608 else if (SCM_FRACTIONP (y
))
3610 double yy
= scm_i_fraction2double (y
);
3611 double xx
= SCM_REAL_VALUE (x
);
3612 return (xx
< yy
) ? scm_make_real (yy
) : x
;
3615 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3617 else if (SCM_FRACTIONP (x
))
3623 else if (SCM_BIGP (y
))
3627 else if (SCM_REALP (y
))
3629 double xx
= scm_i_fraction2double (x
);
3630 return (xx
< SCM_REAL_VALUE (y
)) ? y
: scm_make_real (xx
);
3632 else if (SCM_FRACTIONP (y
))
3637 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3640 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3644 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3645 /* "Return the minium of all parameter values."
3648 scm_min (SCM x
, SCM y
)
3653 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
3654 else if (SCM_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
3657 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3662 long xx
= SCM_INUM (x
);
3665 long yy
= SCM_INUM (y
);
3666 return (xx
< yy
) ? x
: y
;
3668 else if (SCM_BIGP (y
))
3670 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3671 scm_remember_upto_here_1 (y
);
3672 return (sgn
< 0) ? y
: x
;
3674 else if (SCM_REALP (y
))
3677 /* if y==NaN then "<" is false and we return NaN */
3678 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3680 else if (SCM_FRACTIONP (y
))
3683 return (SCM_FALSEP (scm_less_p (x
, y
)) ? y
: x
);
3686 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3688 else if (SCM_BIGP (x
))
3692 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3693 scm_remember_upto_here_1 (x
);
3694 return (sgn
< 0) ? x
: y
;
3696 else if (SCM_BIGP (y
))
3698 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3699 scm_remember_upto_here_2 (x
, y
);
3700 return (cmp
> 0) ? y
: x
;
3702 else if (SCM_REALP (y
))
3704 /* if y==NaN then xx<yy is false, so we return the NaN y */
3707 xx
= scm_i_big2dbl (x
);
3708 yy
= SCM_REAL_VALUE (y
);
3709 return (xx
< yy
? scm_make_real (xx
) : y
);
3711 else if (SCM_FRACTIONP (y
))
3716 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3718 else if (SCM_REALP (x
))
3722 double z
= SCM_INUM (y
);
3723 /* if x==NaN then "<" is false and we return NaN */
3724 return (z
< SCM_REAL_VALUE (x
)) ? scm_make_real (z
) : x
;
3726 else if (SCM_BIGP (y
))
3731 else if (SCM_REALP (y
))
3733 /* if x==NaN then our explicit check means we return NaN
3734 if y==NaN then "<" is false and we return NaN
3735 calling isnan is unavoidable, since it's the only way to know
3736 which of x or y causes any compares to be false */
3737 double xx
= SCM_REAL_VALUE (x
);
3738 return (xisnan (xx
) || xx
< SCM_REAL_VALUE (y
)) ? x
: y
;
3740 else if (SCM_FRACTIONP (y
))
3742 double yy
= scm_i_fraction2double (y
);
3743 double xx
= SCM_REAL_VALUE (x
);
3744 return (yy
< xx
) ? scm_make_real (yy
) : x
;
3747 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3749 else if (SCM_FRACTIONP (x
))
3755 else if (SCM_BIGP (y
))
3759 else if (SCM_REALP (y
))
3761 double xx
= scm_i_fraction2double (x
);
3762 return (SCM_REAL_VALUE (y
) < xx
) ? y
: scm_make_real (xx
);
3764 else if (SCM_FRACTIONP (y
))
3769 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3772 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3776 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3777 /* "Return the sum of all parameter values. Return 0 if called without\n"
3781 scm_sum (SCM x
, SCM y
)
3785 if (SCM_NUMBERP (x
)) return x
;
3786 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
3787 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3794 long xx
= SCM_INUM (x
);
3795 long yy
= SCM_INUM (y
);
3796 long int z
= xx
+ yy
;
3797 return SCM_FIXABLE (z
) ? SCM_MAKINUM (z
) : scm_i_long2big (z
);
3799 else if (SCM_BIGP (y
))
3804 else if (SCM_REALP (y
))
3806 long int xx
= SCM_INUM (x
);
3807 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3809 else if (SCM_COMPLEXP (y
))
3811 long int xx
= SCM_INUM (x
);
3812 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3813 SCM_COMPLEX_IMAG (y
));
3815 else if (SCM_FRACTIONP (y
))
3816 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
3817 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
3818 SCM_FRACTION_DENOMINATOR (y
));
3820 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3821 } else if (SCM_BIGP (x
))
3828 inum
= SCM_INUM (y
);
3831 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3834 SCM result
= scm_i_mkbig ();
3835 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
3836 scm_remember_upto_here_1 (x
);
3837 /* we know the result will have to be a bignum */
3840 return scm_i_normbig (result
);
3844 SCM result
= scm_i_mkbig ();
3845 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
3846 scm_remember_upto_here_1 (x
);
3847 /* we know the result will have to be a bignum */
3850 return scm_i_normbig (result
);
3853 else if (SCM_BIGP (y
))
3855 SCM result
= scm_i_mkbig ();
3856 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3857 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3858 mpz_add (SCM_I_BIG_MPZ (result
),
3861 scm_remember_upto_here_2 (x
, y
);
3862 /* we know the result will have to be a bignum */
3865 return scm_i_normbig (result
);
3867 else if (SCM_REALP (y
))
3869 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
3870 scm_remember_upto_here_1 (x
);
3871 return scm_make_real (result
);
3873 else if (SCM_COMPLEXP (y
))
3875 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
3876 + SCM_COMPLEX_REAL (y
));
3877 scm_remember_upto_here_1 (x
);
3878 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (y
));
3880 else if (SCM_FRACTIONP (y
))
3881 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
3882 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
3883 SCM_FRACTION_DENOMINATOR (y
));
3885 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3887 else if (SCM_REALP (x
))
3890 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3891 else if (SCM_BIGP (y
))
3893 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
3894 scm_remember_upto_here_1 (y
);
3895 return scm_make_real (result
);
3897 else if (SCM_REALP (y
))
3898 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3899 else if (SCM_COMPLEXP (y
))
3900 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3901 SCM_COMPLEX_IMAG (y
));
3902 else if (SCM_FRACTIONP (y
))
3903 return scm_make_real (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
3905 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3907 else if (SCM_COMPLEXP (x
))
3910 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3911 SCM_COMPLEX_IMAG (x
));
3912 else if (SCM_BIGP (y
))
3914 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
3915 + SCM_COMPLEX_REAL (x
));
3916 scm_remember_upto_here_1 (y
);
3917 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (x
));
3919 else if (SCM_REALP (y
))
3920 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3921 SCM_COMPLEX_IMAG (x
));
3922 else if (SCM_COMPLEXP (y
))
3923 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3924 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3925 else if (SCM_FRACTIONP (y
))
3926 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
3927 SCM_COMPLEX_IMAG (x
));
3929 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3931 else if (SCM_FRACTIONP (x
))
3934 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
3935 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
3936 SCM_FRACTION_DENOMINATOR (x
));
3937 else if (SCM_BIGP (y
))
3938 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
3939 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
3940 SCM_FRACTION_DENOMINATOR (x
));
3941 else if (SCM_REALP (y
))
3942 return scm_make_real (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
3943 else if (SCM_COMPLEXP (y
))
3944 return scm_make_complex (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
3945 SCM_COMPLEX_IMAG (y
));
3946 else if (SCM_FRACTIONP (y
))
3947 /* a/b + c/d = (ad + bc) / bd */
3948 return scm_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
3949 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
3950 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
3952 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3955 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3959 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3960 /* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3961 * the sum of all but the first argument are subtracted from the first
3963 #define FUNC_NAME s_difference
3965 scm_difference (SCM x
, SCM y
)
3970 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3974 long xx
= -SCM_INUM (x
);
3975 if (SCM_FIXABLE (xx
))
3976 return SCM_MAKINUM (xx
);
3978 return scm_i_long2big (xx
);
3980 else if (SCM_BIGP (x
))
3981 /* FIXME: do we really need to normalize here? */
3982 return scm_i_normbig (scm_i_clonebig (x
, 0));
3983 else if (SCM_REALP (x
))
3984 return scm_make_real (-SCM_REAL_VALUE (x
));
3985 else if (SCM_COMPLEXP (x
))
3986 return scm_make_complex (-SCM_COMPLEX_REAL (x
),
3987 -SCM_COMPLEX_IMAG (x
));
3988 else if (SCM_FRACTIONP (x
))
3989 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
3990 SCM_FRACTION_DENOMINATOR (x
));
3992 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3999 long int xx
= SCM_INUM (x
);
4000 long int yy
= SCM_INUM (y
);
4001 long int z
= xx
- yy
;
4002 if (SCM_FIXABLE (z
))
4003 return SCM_MAKINUM (z
);
4005 return scm_i_long2big (z
);
4007 else if (SCM_BIGP (y
))
4009 /* inum-x - big-y */
4010 long xx
= SCM_INUM (x
);
4013 return scm_i_clonebig (y
, 0);
4016 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
4017 SCM result
= scm_i_mkbig ();
4020 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
4023 /* x - y == -(y + -x) */
4024 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
4025 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
4027 scm_remember_upto_here_1 (y
);
4029 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
4030 /* we know the result will have to be a bignum */
4033 return scm_i_normbig (result
);
4036 else if (SCM_REALP (y
))
4038 long int xx
= SCM_INUM (x
);
4039 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
4041 else if (SCM_COMPLEXP (y
))
4043 long int xx
= SCM_INUM (x
);
4044 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
4045 - SCM_COMPLEX_IMAG (y
));
4047 else if (SCM_FRACTIONP (y
))
4048 /* a - b/c = (ac - b) / c */
4049 return scm_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4050 SCM_FRACTION_NUMERATOR (y
)),
4051 SCM_FRACTION_DENOMINATOR (y
));
4053 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4055 else if (SCM_BIGP (x
))
4059 /* big-x - inum-y */
4060 long yy
= SCM_INUM (y
);
4061 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4063 scm_remember_upto_here_1 (x
);
4065 return SCM_FIXABLE (-yy
) ? SCM_MAKINUM (-yy
) : scm_long2num (-yy
);
4068 SCM result
= scm_i_mkbig ();
4071 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
4073 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
4074 scm_remember_upto_here_1 (x
);
4076 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
4077 /* we know the result will have to be a bignum */
4080 return scm_i_normbig (result
);
4083 else if (SCM_BIGP (y
))
4085 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4086 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
4087 SCM result
= scm_i_mkbig ();
4088 mpz_sub (SCM_I_BIG_MPZ (result
),
4091 scm_remember_upto_here_2 (x
, y
);
4092 /* we know the result will have to be a bignum */
4093 if ((sgn_x
== 1) && (sgn_y
== -1))
4095 if ((sgn_x
== -1) && (sgn_y
== 1))
4097 return scm_i_normbig (result
);
4099 else if (SCM_REALP (y
))
4101 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
4102 scm_remember_upto_here_1 (x
);
4103 return scm_make_real (result
);
4105 else if (SCM_COMPLEXP (y
))
4107 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
4108 - SCM_COMPLEX_REAL (y
));
4109 scm_remember_upto_here_1 (x
);
4110 return scm_make_complex (real_part
, - SCM_COMPLEX_IMAG (y
));
4112 else if (SCM_FRACTIONP (y
))
4113 return scm_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4114 SCM_FRACTION_NUMERATOR (y
)),
4115 SCM_FRACTION_DENOMINATOR (y
));
4116 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4118 else if (SCM_REALP (x
))
4121 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
4122 else if (SCM_BIGP (y
))
4124 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
4125 scm_remember_upto_here_1 (x
);
4126 return scm_make_real (result
);
4128 else if (SCM_REALP (y
))
4129 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
4130 else if (SCM_COMPLEXP (y
))
4131 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
4132 -SCM_COMPLEX_IMAG (y
));
4133 else if (SCM_FRACTIONP (y
))
4134 return scm_make_real (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
4136 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4138 else if (SCM_COMPLEXP (x
))
4141 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
4142 SCM_COMPLEX_IMAG (x
));
4143 else if (SCM_BIGP (y
))
4145 double real_part
= (SCM_COMPLEX_REAL (x
)
4146 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
4147 scm_remember_upto_here_1 (x
);
4148 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (y
));
4150 else if (SCM_REALP (y
))
4151 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
4152 SCM_COMPLEX_IMAG (x
));
4153 else if (SCM_COMPLEXP (y
))
4154 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
4155 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
4156 else if (SCM_FRACTIONP (y
))
4157 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
4158 SCM_COMPLEX_IMAG (x
));
4160 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4162 else if (SCM_FRACTIONP (x
))
4165 /* a/b - c = (a - cb) / b */
4166 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
4167 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
4168 SCM_FRACTION_DENOMINATOR (x
));
4169 else if (SCM_BIGP (y
))
4170 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
4171 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
4172 SCM_FRACTION_DENOMINATOR (x
));
4173 else if (SCM_REALP (y
))
4174 return scm_make_real (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
4175 else if (SCM_COMPLEXP (y
))
4176 return scm_make_complex (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
4177 -SCM_COMPLEX_IMAG (y
));
4178 else if (SCM_FRACTIONP (y
))
4179 /* a/b - c/d = (ad - bc) / bd */
4180 return scm_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
4181 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
4182 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
4184 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4187 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
4192 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
4193 /* "Return the product of all arguments. If called without arguments,\n"
4197 scm_product (SCM x
, SCM y
)
4202 return SCM_MAKINUM (1L);
4203 else if (SCM_NUMBERP (x
))
4206 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
4218 case 0: return x
; break;
4219 case 1: return y
; break;
4224 long yy
= SCM_INUM (y
);
4226 SCM k
= SCM_MAKINUM (kk
);
4227 if ((kk
== SCM_INUM (k
)) && (kk
/ xx
== yy
))
4231 SCM result
= scm_i_long2big (xx
);
4232 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
4233 return scm_i_normbig (result
);
4236 else if (SCM_BIGP (y
))
4238 SCM result
= scm_i_mkbig ();
4239 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
4240 scm_remember_upto_here_1 (y
);
4243 else if (SCM_REALP (y
))
4244 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
4245 else if (SCM_COMPLEXP (y
))
4246 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
4247 xx
* SCM_COMPLEX_IMAG (y
));
4248 else if (SCM_FRACTIONP (y
))
4249 return scm_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
4250 SCM_FRACTION_DENOMINATOR (y
));
4252 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4254 else if (SCM_BIGP (x
))
4261 else if (SCM_BIGP (y
))
4263 SCM result
= scm_i_mkbig ();
4264 mpz_mul (SCM_I_BIG_MPZ (result
),
4267 scm_remember_upto_here_2 (x
, y
);
4270 else if (SCM_REALP (y
))
4272 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
4273 scm_remember_upto_here_1 (x
);
4274 return scm_make_real (result
);
4276 else if (SCM_COMPLEXP (y
))
4278 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
4279 scm_remember_upto_here_1 (x
);
4280 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
4281 z
* SCM_COMPLEX_IMAG (y
));
4283 else if (SCM_FRACTIONP (y
))
4284 return scm_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
4285 SCM_FRACTION_DENOMINATOR (y
));
4287 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4289 else if (SCM_REALP (x
))
4292 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
4293 else if (SCM_BIGP (y
))
4295 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
4296 scm_remember_upto_here_1 (y
);
4297 return scm_make_real (result
);
4299 else if (SCM_REALP (y
))
4300 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
4301 else if (SCM_COMPLEXP (y
))
4302 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
4303 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
4304 else if (SCM_FRACTIONP (y
))
4305 return scm_make_real (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
4307 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4309 else if (SCM_COMPLEXP (x
))
4312 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
4313 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
4314 else if (SCM_BIGP (y
))
4316 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4317 scm_remember_upto_here_1 (y
);
4318 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
4319 z
* SCM_COMPLEX_IMAG (x
));
4321 else if (SCM_REALP (y
))
4322 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
4323 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
4324 else if (SCM_COMPLEXP (y
))
4326 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
4327 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
4328 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
4329 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
4331 else if (SCM_FRACTIONP (y
))
4333 double yy
= scm_i_fraction2double (y
);
4334 return scm_make_complex (yy
* SCM_COMPLEX_REAL (x
),
4335 yy
* SCM_COMPLEX_IMAG (x
));
4338 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4340 else if (SCM_FRACTIONP (x
))
4343 return scm_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
4344 SCM_FRACTION_DENOMINATOR (x
));
4345 else if (SCM_BIGP (y
))
4346 return scm_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
4347 SCM_FRACTION_DENOMINATOR (x
));
4348 else if (SCM_REALP (y
))
4349 return scm_make_real (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
4350 else if (SCM_COMPLEXP (y
))
4352 double xx
= scm_i_fraction2double (x
);
4353 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
4354 xx
* SCM_COMPLEX_IMAG (y
));
4356 else if (SCM_FRACTIONP (y
))
4357 /* a/b * c/d = ac / bd */
4358 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
4359 SCM_FRACTION_NUMERATOR (y
)),
4360 scm_product (SCM_FRACTION_DENOMINATOR (x
),
4361 SCM_FRACTION_DENOMINATOR (y
)));
4363 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4366 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
4370 scm_num2dbl (SCM a
, const char *why
)
4371 #define FUNC_NAME why
4374 return (double) SCM_INUM (a
);
4375 else if (SCM_BIGP (a
))
4377 double result
= mpz_get_d (SCM_I_BIG_MPZ (a
));
4378 scm_remember_upto_here_1 (a
);
4381 else if (SCM_REALP (a
))
4382 return (SCM_REAL_VALUE (a
));
4383 else if (SCM_FRACTIONP (a
))
4384 return scm_i_fraction2double (a
);
4386 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
4390 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
4391 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
4392 #define ALLOW_DIVIDE_BY_ZERO
4393 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
4396 /* The code below for complex division is adapted from the GNU
4397 libstdc++, which adapted it from f2c's libF77, and is subject to
4400 /****************************************************************
4401 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
4403 Permission to use, copy, modify, and distribute this software
4404 and its documentation for any purpose and without fee is hereby
4405 granted, provided that the above copyright notice appear in all
4406 copies and that both that the copyright notice and this
4407 permission notice and warranty disclaimer appear in supporting
4408 documentation, and that the names of AT&T Bell Laboratories or
4409 Bellcore or any of their entities not be used in advertising or
4410 publicity pertaining to distribution of the software without
4411 specific, written prior permission.
4413 AT&T and Bellcore disclaim all warranties with regard to this
4414 software, including all implied warranties of merchantability
4415 and fitness. In no event shall AT&T or Bellcore be liable for
4416 any special, indirect or consequential damages or any damages
4417 whatsoever resulting from loss of use, data or profits, whether
4418 in an action of contract, negligence or other tortious action,
4419 arising out of or in connection with the use or performance of
4421 ****************************************************************/
4423 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
4424 /* Divide the first argument by the product of the remaining
4425 arguments. If called with one argument @var{z1}, 1/@var{z1} is
4427 #define FUNC_NAME s_divide
4429 scm_i_divide (SCM x
, SCM y
, int inexact
)
4436 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
4437 else if (SCM_INUMP (x
))
4439 long xx
= SCM_INUM (x
);
4440 if (xx
== 1 || xx
== -1)
4442 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4444 scm_num_overflow (s_divide
);
4449 return scm_make_real (1.0 / (double) xx
);
4450 else return scm_make_ratio (SCM_MAKINUM(1), x
);
4453 else if (SCM_BIGP (x
))
4456 return scm_make_real (1.0 / scm_i_big2dbl (x
));
4457 else return scm_make_ratio (SCM_MAKINUM(1), x
);
4459 else if (SCM_REALP (x
))
4461 double xx
= SCM_REAL_VALUE (x
);
4462 #ifndef ALLOW_DIVIDE_BY_ZERO
4464 scm_num_overflow (s_divide
);
4467 return scm_make_real (1.0 / xx
);
4469 else if (SCM_COMPLEXP (x
))
4471 double r
= SCM_COMPLEX_REAL (x
);
4472 double i
= SCM_COMPLEX_IMAG (x
);
4476 double d
= i
* (1.0 + t
* t
);
4477 return scm_make_complex (t
/ d
, -1.0 / d
);
4482 double d
= r
* (1.0 + t
* t
);
4483 return scm_make_complex (1.0 / d
, -t
/ d
);
4486 else if (SCM_FRACTIONP (x
))
4487 return scm_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
4488 SCM_FRACTION_NUMERATOR (x
));
4490 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
4495 long xx
= SCM_INUM (x
);
4498 long yy
= SCM_INUM (y
);
4501 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4502 scm_num_overflow (s_divide
);
4504 return scm_make_real ((double) xx
/ (double) yy
);
4507 else if (xx
% yy
!= 0)
4510 return scm_make_real ((double) xx
/ (double) yy
);
4511 else return scm_make_ratio (x
, y
);
4516 if (SCM_FIXABLE (z
))
4517 return SCM_MAKINUM (z
);
4519 return scm_i_long2big (z
);
4522 else if (SCM_BIGP (y
))
4525 return scm_make_real ((double) xx
/ scm_i_big2dbl (y
));
4526 else return scm_make_ratio (x
, y
);
4528 else if (SCM_REALP (y
))
4530 double yy
= SCM_REAL_VALUE (y
);
4531 #ifndef ALLOW_DIVIDE_BY_ZERO
4533 scm_num_overflow (s_divide
);
4536 return scm_make_real ((double) xx
/ yy
);
4538 else if (SCM_COMPLEXP (y
))
4541 complex_div
: /* y _must_ be a complex number */
4543 double r
= SCM_COMPLEX_REAL (y
);
4544 double i
= SCM_COMPLEX_IMAG (y
);
4548 double d
= i
* (1.0 + t
* t
);
4549 return scm_make_complex ((a
* t
) / d
, -a
/ d
);
4554 double d
= r
* (1.0 + t
* t
);
4555 return scm_make_complex (a
/ d
, -(a
* t
) / d
);
4559 else if (SCM_FRACTIONP (y
))
4560 /* a / b/c = ac / b */
4561 return scm_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4562 SCM_FRACTION_NUMERATOR (y
));
4564 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4566 else if (SCM_BIGP (x
))
4570 long int yy
= SCM_INUM (y
);
4573 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4574 scm_num_overflow (s_divide
);
4576 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4577 scm_remember_upto_here_1 (x
);
4578 return (sgn
== 0) ? scm_nan () : scm_inf ();
4585 /* FIXME: HMM, what are the relative performance issues here?
4586 We need to test. Is it faster on average to test
4587 divisible_p, then perform whichever operation, or is it
4588 faster to perform the integer div opportunistically and
4589 switch to real if there's a remainder? For now we take the
4590 middle ground: test, then if divisible, use the faster div
4593 long abs_yy
= yy
< 0 ? -yy
: yy
;
4594 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
4598 SCM result
= scm_i_mkbig ();
4599 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
4600 scm_remember_upto_here_1 (x
);
4602 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
4603 return scm_i_normbig (result
);
4608 return scm_make_real (scm_i_big2dbl (x
) / (double) yy
);
4609 else return scm_make_ratio (x
, y
);
4613 else if (SCM_BIGP (y
))
4615 int y_is_zero
= (mpz_sgn (SCM_I_BIG_MPZ (y
)) == 0);
4618 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4619 scm_num_overflow (s_divide
);
4621 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4622 scm_remember_upto_here_1 (x
);
4623 return (sgn
== 0) ? scm_nan () : scm_inf ();
4629 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
4633 SCM result
= scm_i_mkbig ();
4634 mpz_divexact (SCM_I_BIG_MPZ (result
),
4637 scm_remember_upto_here_2 (x
, y
);
4638 return scm_i_normbig (result
);
4644 double dbx
= mpz_get_d (SCM_I_BIG_MPZ (x
));
4645 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4646 scm_remember_upto_here_2 (x
, y
);
4647 return scm_make_real (dbx
/ dby
);
4649 else return scm_make_ratio (x
, y
);
4653 else if (SCM_REALP (y
))
4655 double yy
= SCM_REAL_VALUE (y
);
4656 #ifndef ALLOW_DIVIDE_BY_ZERO
4658 scm_num_overflow (s_divide
);
4661 return scm_make_real (scm_i_big2dbl (x
) / yy
);
4663 else if (SCM_COMPLEXP (y
))
4665 a
= scm_i_big2dbl (x
);
4668 else if (SCM_FRACTIONP (y
))
4669 return scm_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4670 SCM_FRACTION_NUMERATOR (y
));
4672 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4674 else if (SCM_REALP (x
))
4676 double rx
= SCM_REAL_VALUE (x
);
4679 long int yy
= SCM_INUM (y
);
4680 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4682 scm_num_overflow (s_divide
);
4685 return scm_make_real (rx
/ (double) yy
);
4687 else if (SCM_BIGP (y
))
4689 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4690 scm_remember_upto_here_1 (y
);
4691 return scm_make_real (rx
/ dby
);
4693 else if (SCM_REALP (y
))
4695 double yy
= SCM_REAL_VALUE (y
);
4696 #ifndef ALLOW_DIVIDE_BY_ZERO
4698 scm_num_overflow (s_divide
);
4701 return scm_make_real (rx
/ yy
);
4703 else if (SCM_COMPLEXP (y
))
4708 else if (SCM_FRACTIONP (y
))
4709 return scm_make_real (rx
/ scm_i_fraction2double (y
));
4711 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4713 else if (SCM_COMPLEXP (x
))
4715 double rx
= SCM_COMPLEX_REAL (x
);
4716 double ix
= SCM_COMPLEX_IMAG (x
);
4719 long int yy
= SCM_INUM (y
);
4720 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4722 scm_num_overflow (s_divide
);
4727 return scm_make_complex (rx
/ d
, ix
/ d
);
4730 else if (SCM_BIGP (y
))
4732 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4733 scm_remember_upto_here_1 (y
);
4734 return scm_make_complex (rx
/ dby
, ix
/ dby
);
4736 else if (SCM_REALP (y
))
4738 double yy
= SCM_REAL_VALUE (y
);
4739 #ifndef ALLOW_DIVIDE_BY_ZERO
4741 scm_num_overflow (s_divide
);
4744 return scm_make_complex (rx
/ yy
, ix
/ yy
);
4746 else if (SCM_COMPLEXP (y
))
4748 double ry
= SCM_COMPLEX_REAL (y
);
4749 double iy
= SCM_COMPLEX_IMAG (y
);
4753 double d
= iy
* (1.0 + t
* t
);
4754 return scm_make_complex ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
4759 double d
= ry
* (1.0 + t
* t
);
4760 return scm_make_complex ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
4763 else if (SCM_FRACTIONP (y
))
4765 double yy
= scm_i_fraction2double (y
);
4766 return scm_make_complex (rx
/ yy
, ix
/ yy
);
4769 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4771 else if (SCM_FRACTIONP (x
))
4775 long int yy
= SCM_INUM (y
);
4776 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4778 scm_num_overflow (s_divide
);
4781 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x
),
4782 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
4784 else if (SCM_BIGP (y
))
4786 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x
),
4787 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
4789 else if (SCM_REALP (y
))
4791 double yy
= SCM_REAL_VALUE (y
);
4792 #ifndef ALLOW_DIVIDE_BY_ZERO
4794 scm_num_overflow (s_divide
);
4797 return scm_make_real (scm_i_fraction2double (x
) / yy
);
4799 else if (SCM_COMPLEXP (y
))
4801 a
= scm_i_fraction2double (x
);
4804 else if (SCM_FRACTIONP (y
))
4805 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
4806 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
4808 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4811 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
4815 scm_divide (SCM x
, SCM y
)
4817 return scm_i_divide (x
, y
, 0);
4820 static SCM
scm_divide2real (SCM x
, SCM y
)
4822 return scm_i_divide (x
, y
, 1);
4828 scm_asinh (double x
)
4833 #define asinh scm_asinh
4834 return log (x
+ sqrt (x
* x
+ 1));
4837 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_dsubr
, (SCM (*)()) asinh
, g_asinh
);
4838 /* "Return the inverse hyperbolic sine of @var{x}."
4843 scm_acosh (double x
)
4848 #define acosh scm_acosh
4849 return log (x
+ sqrt (x
* x
- 1));
4852 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_dsubr
, (SCM (*)()) acosh
, g_acosh
);
4853 /* "Return the inverse hyperbolic cosine of @var{x}."
4858 scm_atanh (double x
)
4863 #define atanh scm_atanh
4864 return 0.5 * log ((1 + x
) / (1 - x
));
4867 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_dsubr
, (SCM (*)()) atanh
, g_atanh
);
4868 /* "Return the inverse hyperbolic tangent of @var{x}."
4872 /* XXX - eventually, we should remove this definition of scm_round and
4873 rename scm_round_number to scm_round. Likewise for scm_truncate
4874 and scm_truncate_number.
4878 scm_truncate (double x
)
4883 #define trunc scm_truncate
4890 /* scm_round is done using floor(x+0.5) to round to nearest and with
4891 half-way case (ie. when x is an integer plus 0.5) going upwards. Then
4892 half-way cases are identified and adjusted down if the round-upwards
4893 didn't give the desired even integer.
4895 "plus_half == result" identifies a half-way case. If plus_half, which is
4896 x + 0.5, is an integer then x must be an integer plus 0.5.
4898 An odd "result" value is identified with result/2 != floor(result/2).
4899 This is done with plus_half, since that value is ready for use sooner in
4900 a pipelined cpu, and we're already requiring plus_half == result.
4902 Note however that we need to be careful when x is big and already an
4903 integer. In that case "x+0.5" may round to an adjacent integer, causing
4904 us to return such a value, incorrectly. For instance if the hardware is
4905 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
4906 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
4907 returned. Or if the hardware is in round-upwards mode, then other bigger
4908 values like say x == 2^128 will see x+0.5 rounding up to the next higher
4909 representable value, 2^128+2^76 (or whatever), again incorrect.
4911 These bad roundings of x+0.5 are avoided by testing at the start whether
4912 x is already an integer. If it is then clearly that's the desired result
4913 already. And if it's not then the exponent must be small enough to allow
4914 an 0.5 to be represented, and hence added without a bad rounding. */
4917 scm_round (double x
)
4919 double plus_half
, result
;
4924 plus_half
= x
+ 0.5;
4925 result
= floor (plus_half
);
4926 /* Adjust so that the scm_round is towards even. */
4927 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
4932 SCM_DEFINE (scm_truncate_number
, "truncate", 1, 0, 0,
4934 "Round the number @var{x} towards zero.")
4935 #define FUNC_NAME s_scm_truncate_number
4937 if (SCM_FALSEP (scm_negative_p (x
)))
4938 return scm_floor (x
);
4940 return scm_ceiling (x
);
4944 static SCM exactly_one_half
;
4946 SCM_DEFINE (scm_round_number
, "round", 1, 0, 0,
4948 "Round the number @var{x} towards the nearest integer. "
4949 "When it is exactly halfway between two integers, "
4950 "round towards the even one.")
4951 #define FUNC_NAME s_scm_round_number
4953 SCM plus_half
= scm_sum (x
, exactly_one_half
);
4954 SCM result
= scm_floor (plus_half
);
4955 /* Adjust so that the scm_round is towards even. */
4956 if (!SCM_FALSEP (scm_num_eq_p (plus_half
, result
))
4957 && !SCM_FALSEP (scm_odd_p (result
)))
4958 return scm_difference (result
, SCM_MAKINUM (1));
4964 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
4966 "Round the number @var{x} towards minus infinity.")
4967 #define FUNC_NAME s_scm_floor
4969 if (SCM_INUMP (x
) || SCM_BIGP (x
))
4971 else if (SCM_REALP (x
))
4972 return scm_make_real (floor (SCM_REAL_VALUE (x
)));
4973 else if (SCM_FRACTIONP (x
))
4975 SCM q
= scm_quotient (SCM_FRACTION_NUMERATOR (x
),
4976 SCM_FRACTION_DENOMINATOR (x
));
4977 if (SCM_FALSEP (scm_negative_p (x
)))
4979 /* For positive x, rounding towards zero is correct. */
4984 /* For negative x, we need to return q-1 unless x is an
4985 integer. But fractions are never integer, per our
4987 return scm_difference (q
, SCM_MAKINUM (1));
4991 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
4995 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
4997 "Round the number @var{x} towards infinity.")
4998 #define FUNC_NAME s_scm_ceiling
5000 if (SCM_INUMP (x
) || SCM_BIGP (x
))
5002 else if (SCM_REALP (x
))
5003 return scm_make_real (ceil (SCM_REAL_VALUE (x
)));
5004 else if (SCM_FRACTIONP (x
))
5006 SCM q
= scm_quotient (SCM_FRACTION_NUMERATOR (x
),
5007 SCM_FRACTION_DENOMINATOR (x
));
5008 if (SCM_FALSEP (scm_positive_p (x
)))
5010 /* For negative x, rounding towards zero is correct. */
5015 /* For positive x, we need to return q+1 unless x is an
5016 integer. But fractions are never integer, per our
5018 return scm_sum (q
, SCM_MAKINUM (1));
5022 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
5026 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_dsubr
, (SCM (*)()) sqrt
, g_i_sqrt
);
5027 /* "Return the square root of the real number @var{x}."
5029 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_dsubr
, (SCM (*)()) fabs
, g_i_abs
);
5030 /* "Return the absolute value of the real number @var{x}."
5032 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_dsubr
, (SCM (*)()) exp
, g_i_exp
);
5033 /* "Return the @var{x}th power of e."
5035 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_dsubr
, (SCM (*)()) log
, g_i_log
);
5036 /* "Return the natural logarithm of the real number @var{x}."
5038 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_dsubr
, (SCM (*)()) sin
, g_i_sin
);
5039 /* "Return the sine of the real number @var{x}."
5041 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_dsubr
, (SCM (*)()) cos
, g_i_cos
);
5042 /* "Return the cosine of the real number @var{x}."
5044 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_dsubr
, (SCM (*)()) tan
, g_i_tan
);
5045 /* "Return the tangent of the real number @var{x}."
5047 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_dsubr
, (SCM (*)()) asin
, g_i_asin
);
5048 /* "Return the arc sine of the real number @var{x}."
5050 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_dsubr
, (SCM (*)()) acos
, g_i_acos
);
5051 /* "Return the arc cosine of the real number @var{x}."
5053 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_dsubr
, (SCM (*)()) atan
, g_i_atan
);
5054 /* "Return the arc tangent of the real number @var{x}."
5056 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_dsubr
, (SCM (*)()) sinh
, g_i_sinh
);
5057 /* "Return the hyperbolic sine of the real number @var{x}."
5059 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_dsubr
, (SCM (*)()) cosh
, g_i_cosh
);
5060 /* "Return the hyperbolic cosine of the real number @var{x}."
5062 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_dsubr
, (SCM (*)()) tanh
, g_i_tanh
);
5063 /* "Return the hyperbolic tangent of the real number @var{x}."
5071 static void scm_two_doubles (SCM x
,
5073 const char *sstring
,
5077 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
5080 xy
->x
= SCM_INUM (x
);
5081 else if (SCM_BIGP (x
))
5082 xy
->x
= scm_i_big2dbl (x
);
5083 else if (SCM_REALP (x
))
5084 xy
->x
= SCM_REAL_VALUE (x
);
5085 else if (SCM_FRACTIONP (x
))
5086 xy
->x
= scm_i_fraction2double (x
);
5088 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
5091 xy
->y
= SCM_INUM (y
);
5092 else if (SCM_BIGP (y
))
5093 xy
->y
= scm_i_big2dbl (y
);
5094 else if (SCM_REALP (y
))
5095 xy
->y
= SCM_REAL_VALUE (y
);
5096 else if (SCM_FRACTIONP (y
))
5097 xy
->y
= scm_i_fraction2double (y
);
5099 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
5103 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
5105 "Return @var{x} raised to the power of @var{y}. This\n"
5106 "procedure does not accept complex arguments.")
5107 #define FUNC_NAME s_scm_sys_expt
5110 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
5111 return scm_make_real (pow (xy
.x
, xy
.y
));
5116 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
5118 "Return the arc tangent of the two arguments @var{x} and\n"
5119 "@var{y}. This is similar to calculating the arc tangent of\n"
5120 "@var{x} / @var{y}, except that the signs of both arguments\n"
5121 "are used to determine the quadrant of the result. This\n"
5122 "procedure does not accept complex arguments.")
5123 #define FUNC_NAME s_scm_sys_atan2
5126 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
5127 return scm_make_real (atan2 (xy
.x
, xy
.y
));
5132 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
5133 (SCM real
, SCM imaginary
),
5134 "Return a complex number constructed of the given @var{real} and\n"
5135 "@var{imaginary} parts.")
5136 #define FUNC_NAME s_scm_make_rectangular
5139 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
5140 return scm_make_complex (xy
.x
, xy
.y
);
5146 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
5148 "Return the complex number @var{x} * e^(i * @var{y}).")
5149 #define FUNC_NAME s_scm_make_polar
5153 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
5155 sincos (xy
.y
, &s
, &c
);
5160 return scm_make_complex (xy
.x
* c
, xy
.x
* s
);
5165 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
5166 /* "Return the real part of the number @var{z}."
5169 scm_real_part (SCM z
)
5173 else if (SCM_BIGP (z
))
5175 else if (SCM_REALP (z
))
5177 else if (SCM_COMPLEXP (z
))
5178 return scm_make_real (SCM_COMPLEX_REAL (z
));
5179 else if (SCM_FRACTIONP (z
))
5182 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
5186 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
5187 /* "Return the imaginary part of the number @var{z}."
5190 scm_imag_part (SCM z
)
5194 else if (SCM_BIGP (z
))
5196 else if (SCM_REALP (z
))
5198 else if (SCM_COMPLEXP (z
))
5199 return scm_make_real (SCM_COMPLEX_IMAG (z
));
5200 else if (SCM_FRACTIONP (z
))
5203 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
5206 SCM_GPROC (s_numerator
, "numerator", 1, 0, 0, scm_numerator
, g_numerator
);
5207 /* "Return the numerator of the number @var{z}."
5210 scm_numerator (SCM z
)
5214 else if (SCM_BIGP (z
))
5216 else if (SCM_FRACTIONP (z
))
5218 scm_i_fraction_reduce (z
);
5219 return SCM_FRACTION_NUMERATOR (z
);
5221 else if (SCM_REALP (z
))
5222 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
5224 SCM_WTA_DISPATCH_1 (g_numerator
, z
, SCM_ARG1
, s_numerator
);
5228 SCM_GPROC (s_denominator
, "denominator", 1, 0, 0, scm_denominator
, g_denominator
);
5229 /* "Return the denominator of the number @var{z}."
5232 scm_denominator (SCM z
)
5235 return SCM_MAKINUM (1);
5236 else if (SCM_BIGP (z
))
5237 return SCM_MAKINUM (1);
5238 else if (SCM_FRACTIONP (z
))
5240 scm_i_fraction_reduce (z
);
5241 return SCM_FRACTION_DENOMINATOR (z
);
5243 else if (SCM_REALP (z
))
5244 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
5246 SCM_WTA_DISPATCH_1 (g_denominator
, z
, SCM_ARG1
, s_denominator
);
5249 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
5250 /* "Return the magnitude of the number @var{z}. This is the same as\n"
5251 * "@code{abs} for real arguments, but also allows complex numbers."
5254 scm_magnitude (SCM z
)
5258 long int zz
= SCM_INUM (z
);
5261 else if (SCM_POSFIXABLE (-zz
))
5262 return SCM_MAKINUM (-zz
);
5264 return scm_i_long2big (-zz
);
5266 else if (SCM_BIGP (z
))
5268 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
5269 scm_remember_upto_here_1 (z
);
5271 return scm_i_clonebig (z
, 0);
5275 else if (SCM_REALP (z
))
5276 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
5277 else if (SCM_COMPLEXP (z
))
5278 return scm_make_real (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
5279 else if (SCM_FRACTIONP (z
))
5281 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
5283 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
5284 SCM_FRACTION_DENOMINATOR (z
));
5287 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
5291 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
5292 /* "Return the angle of the complex number @var{z}."
5297 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
5298 scm_flo0 to save allocating a new flonum with scm_make_real each time.
5299 But if atan2 follows the floating point rounding mode, then the value
5300 is not a constant. Maybe it'd be close enough though. */
5303 if (SCM_INUM (z
) >= 0)
5306 return scm_make_real (atan2 (0.0, -1.0));
5308 else if (SCM_BIGP (z
))
5310 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
5311 scm_remember_upto_here_1 (z
);
5313 return scm_make_real (atan2 (0.0, -1.0));
5317 else if (SCM_REALP (z
))
5319 if (SCM_REAL_VALUE (z
) >= 0)
5322 return scm_make_real (atan2 (0.0, -1.0));
5324 else if (SCM_COMPLEXP (z
))
5325 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
5326 else if (SCM_FRACTIONP (z
))
5328 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
5330 else return scm_make_real (atan2 (0.0, -1.0));
5333 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
5337 SCM_GPROC (s_exact_to_inexact
, "exact->inexact", 1, 0, 0, scm_exact_to_inexact
, g_exact_to_inexact
);
5338 /* Convert the number @var{x} to its inexact representation.\n"
5341 scm_exact_to_inexact (SCM z
)
5344 return scm_make_real ((double) SCM_INUM (z
));
5345 else if (SCM_BIGP (z
))
5346 return scm_make_real (scm_i_big2dbl (z
));
5347 else if (SCM_FRACTIONP (z
))
5348 return scm_make_real (scm_i_fraction2double (z
));
5349 else if (SCM_INEXACTP (z
))
5352 SCM_WTA_DISPATCH_1 (g_exact_to_inexact
, z
, 1, s_exact_to_inexact
);
5356 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
5358 "Return an exact number that is numerically closest to @var{z}.")
5359 #define FUNC_NAME s_scm_inexact_to_exact
5363 else if (SCM_BIGP (z
))
5365 else if (SCM_REALP (z
))
5367 if (xisinf (SCM_REAL_VALUE (z
)) || xisnan (SCM_REAL_VALUE (z
)))
5368 SCM_OUT_OF_RANGE (1, z
);
5375 mpq_set_d (frac
, SCM_REAL_VALUE (z
));
5376 q
= scm_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
5377 scm_i_mpz2num (mpq_denref (frac
)));
5379 /* When scm_make_ratio throws, we leak the memory allocated
5386 else if (SCM_FRACTIONP (z
))
5389 SCM_WRONG_TYPE_ARG (1, z
);
5393 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
5395 "Return an exact number that is within @var{err} of @var{x}.")
5396 #define FUNC_NAME s_scm_rationalize
5400 else if (SCM_BIGP (x
))
5402 else if ((SCM_REALP (x
)) || SCM_FRACTIONP (x
))
5404 /* Use continued fractions to find closest ratio. All
5405 arithmetic is done with exact numbers.
5408 SCM ex
= scm_inexact_to_exact (x
);
5409 SCM int_part
= scm_floor (ex
);
5410 SCM tt
= SCM_MAKINUM (1);
5411 SCM a1
= SCM_MAKINUM (0), a2
= SCM_MAKINUM (1), a
= SCM_MAKINUM (0);
5412 SCM b1
= SCM_MAKINUM (1), b2
= SCM_MAKINUM (0), b
= SCM_MAKINUM (0);
5416 if (!SCM_FALSEP (scm_num_eq_p (ex
, int_part
)))
5419 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
5420 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
5422 /* We stop after a million iterations just to be absolutely sure
5423 that we don't go into an infinite loop. The process normally
5424 converges after less than a dozen iterations.
5427 err
= scm_abs (err
);
5428 while (++i
< 1000000)
5430 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
5431 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
5432 if (SCM_FALSEP (scm_zero_p (b
)) && /* b != 0 */
5434 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
5435 err
))) /* abs(x-a/b) <= err */
5437 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
5438 if (SCM_FALSEP (scm_exact_p (x
))
5439 || SCM_FALSEP (scm_exact_p (err
)))
5440 return scm_exact_to_inexact (res
);
5444 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
5446 tt
= scm_floor (rx
); /* tt = floor (rx) */
5452 scm_num_overflow (s_scm_rationalize
);
5455 SCM_WRONG_TYPE_ARG (1, x
);
5459 /* if you need to change this, change test-num2integral.c as well */
5460 #if SCM_SIZEOF_LONG_LONG != 0
5462 # define ULLONG_MAX ((unsigned long long) (-1))
5463 # define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
5464 # define LLONG_MIN (~LLONG_MAX)
5468 /* Parameters for creating integer conversion routines.
5470 Define the following preprocessor macros before including
5471 "libguile/num2integral.i.c":
5473 NUM2INTEGRAL - the name of the function for converting from a
5474 Scheme object to the integral type. This function will be
5475 defined when including "num2integral.i.c".
5477 INTEGRAL2NUM - the name of the function for converting from the
5478 integral type to a Scheme object. This function will be defined.
5480 INTEGRAL2BIG - the name of an internal function that createas a
5481 bignum from the integral type. This function will be defined.
5482 The name should start with "scm_i_".
5484 ITYPE - the name of the integral type.
5486 UNSIGNED - Define this to 1 when ITYPE is an unsigned type. Define
5489 UNSIGNED_ITYPE - the name of the the unsigned variant of the
5490 integral type. If you don't define this, it defaults to
5491 "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned
5494 SIZEOF_ITYPE - an expression giving the size of the integral type
5495 in bytes. This expression must be computable by the
5496 preprocessor. (SIZEOF_FOO values are calculated by configure.in
5501 #define NUM2INTEGRAL scm_num2short
5502 #define INTEGRAL2NUM scm_short2num
5503 #define INTEGRAL2BIG scm_i_short2big
5506 #define SIZEOF_ITYPE SIZEOF_SHORT
5507 #include "libguile/num2integral.i.c"
5509 #define NUM2INTEGRAL scm_num2ushort
5510 #define INTEGRAL2NUM scm_ushort2num
5511 #define INTEGRAL2BIG scm_i_ushort2big
5513 #define ITYPE unsigned short
5514 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT
5515 #include "libguile/num2integral.i.c"
5517 #define NUM2INTEGRAL scm_num2int
5518 #define INTEGRAL2NUM scm_int2num
5519 #define INTEGRAL2BIG scm_i_int2big
5522 #define SIZEOF_ITYPE SIZEOF_INT
5523 #include "libguile/num2integral.i.c"
5525 #define NUM2INTEGRAL scm_num2uint
5526 #define INTEGRAL2NUM scm_uint2num
5527 #define INTEGRAL2BIG scm_i_uint2big
5529 #define ITYPE unsigned int
5530 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT
5531 #include "libguile/num2integral.i.c"
5533 #define NUM2INTEGRAL scm_num2long
5534 #define INTEGRAL2NUM scm_long2num
5535 #define INTEGRAL2BIG scm_i_long2big
5538 #define SIZEOF_ITYPE SIZEOF_LONG
5539 #include "libguile/num2integral.i.c"
5541 #define NUM2INTEGRAL scm_num2ulong
5542 #define INTEGRAL2NUM scm_ulong2num
5543 #define INTEGRAL2BIG scm_i_ulong2big
5545 #define ITYPE unsigned long
5546 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG
5547 #include "libguile/num2integral.i.c"
5549 #define NUM2INTEGRAL scm_num2ptrdiff
5550 #define INTEGRAL2NUM scm_ptrdiff2num
5551 #define INTEGRAL2BIG scm_i_ptrdiff2big
5553 #define ITYPE scm_t_ptrdiff
5554 #define UNSIGNED_ITYPE size_t
5555 #define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF
5556 #include "libguile/num2integral.i.c"
5558 #define NUM2INTEGRAL scm_num2size
5559 #define INTEGRAL2NUM scm_size2num
5560 #define INTEGRAL2BIG scm_i_size2big
5562 #define ITYPE size_t
5563 #define SIZEOF_ITYPE SIZEOF_SIZE_T
5564 #include "libguile/num2integral.i.c"
5566 #if SCM_SIZEOF_LONG_LONG != 0
5568 #ifndef ULONG_LONG_MAX
5569 #define ULONG_LONG_MAX (~0ULL)
5572 #define NUM2INTEGRAL scm_num2long_long
5573 #define INTEGRAL2NUM scm_long_long2num
5574 #define INTEGRAL2BIG scm_i_long_long2big
5576 #define ITYPE long long
5577 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
5578 #include "libguile/num2integral.i.c"
5580 #define NUM2INTEGRAL scm_num2ulong_long
5581 #define INTEGRAL2NUM scm_ulong_long2num
5582 #define INTEGRAL2BIG scm_i_ulong_long2big
5584 #define ITYPE unsigned long long
5585 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG
5586 #include "libguile/num2integral.i.c"
5588 #endif /* SCM_SIZEOF_LONG_LONG != 0 */
5590 #define NUM2FLOAT scm_num2float
5591 #define FLOAT2NUM scm_float2num
5593 #include "libguile/num2float.i.c"
5595 #define NUM2FLOAT scm_num2double
5596 #define FLOAT2NUM scm_double2num
5597 #define FTYPE double
5598 #include "libguile/num2float.i.c"
5603 #define SIZE_MAX ((size_t) (-1))
5606 #define PTRDIFF_MIN \
5607 ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 \
5608 << ((sizeof (scm_t_ptrdiff) * SCM_CHAR_BIT) - 1)))
5611 #define PTRDIFF_MAX (~ PTRDIFF_MIN)
5614 #define CHECK(type, v) \
5617 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
5637 CHECK (ptrdiff
, -1);
5639 CHECK (short, SHRT_MAX
);
5640 CHECK (short, SHRT_MIN
);
5641 CHECK (ushort
, USHRT_MAX
);
5642 CHECK (int, INT_MAX
);
5643 CHECK (int, INT_MIN
);
5644 CHECK (uint
, UINT_MAX
);
5645 CHECK (long, LONG_MAX
);
5646 CHECK (long, LONG_MIN
);
5647 CHECK (ulong
, ULONG_MAX
);
5648 CHECK (size
, SIZE_MAX
);
5649 CHECK (ptrdiff
, PTRDIFF_MAX
);
5650 CHECK (ptrdiff
, PTRDIFF_MIN
);
5652 #if SCM_SIZEOF_LONG_LONG != 0
5653 CHECK (long_long
, 0LL);
5654 CHECK (ulong_long
, 0ULL);
5655 CHECK (long_long
, -1LL);
5656 CHECK (long_long
, LLONG_MAX
);
5657 CHECK (long_long
, LLONG_MIN
);
5658 CHECK (ulong_long
, ULLONG_MAX
);
5665 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
5666 if (!SCM_FALSEP (data)) abort();
5669 check_body (void *data
)
5671 SCM num
= *(SCM
*) data
;
5672 scm_num2ulong (num
, 1, NULL
);
5674 return SCM_UNSPECIFIED
;
5678 check_handler (void *data
, SCM tag
, SCM throw_args
)
5680 SCM
*num
= (SCM
*) data
;
5683 return SCM_UNSPECIFIED
;
5686 SCM_DEFINE (scm_sys_check_number_conversions
, "%check-number-conversions", 0, 0, 0,
5688 "Number conversion sanity checking.")
5689 #define FUNC_NAME s_scm_sys_check_number_conversions
5691 SCM data
= SCM_MAKINUM (-1);
5693 data
= scm_int2num (INT_MIN
);
5695 data
= scm_ulong2num (ULONG_MAX
);
5696 data
= scm_difference (SCM_INUM0
, data
);
5698 data
= scm_ulong2num (ULONG_MAX
);
5699 data
= scm_sum (SCM_MAKINUM (1), data
); data
= scm_difference (SCM_INUM0
, data
);
5701 data
= scm_int2num (-10000); data
= scm_product (data
, data
); data
= scm_product (data
, data
);
5704 return SCM_UNSPECIFIED
;
5713 mpz_init_set_si (z_negative_one
, -1);
5715 /* It may be possible to tune the performance of some algorithms by using
5716 * the following constants to avoid the creation of bignums. Please, before
5717 * using these values, remember the two rules of program optimization:
5718 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
5719 scm_c_define ("most-positive-fixnum",
5720 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
5721 scm_c_define ("most-negative-fixnum",
5722 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
5724 scm_add_feature ("complex");
5725 scm_add_feature ("inexact");
5726 scm_flo0
= scm_make_real (0.0);
5728 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
5730 { /* determine floating point precision */
5732 double fsum
= 1.0 + f
;
5735 if (++scm_dblprec
> 20)
5743 scm_dblprec
= scm_dblprec
- 1;
5745 #endif /* DBL_DIG */
5751 exactly_one_half
= scm_permanent_object (scm_divide (SCM_MAKINUM (1),
5753 #include "libguile/numbers.x"