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
);
1486 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1487 else if (SCM_BIGP (j
))
1489 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
1490 scm_remember_upto_here_1 (j
);
1491 return SCM_BOOL (val
);
1494 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1499 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1501 "Return the integer which is the ones-complement of the integer\n"
1505 "(number->string (lognot #b10000000) 2)\n"
1506 " @result{} \"-10000001\"\n"
1507 "(number->string (lognot #b0) 2)\n"
1508 " @result{} \"-1\"\n"
1510 #define FUNC_NAME s_scm_lognot
1512 if (SCM_INUMP (n
)) {
1513 /* No overflow here, just need to toggle all the bits making up the inum.
1514 Enhancement: No need to strip the tag and add it back, could just xor
1515 a block of 1 bits, if that worked with the various debug versions of
1517 return SCM_MAKINUM (~ SCM_INUM (n
));
1519 } else if (SCM_BIGP (n
)) {
1520 SCM result
= scm_i_mkbig ();
1521 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
1522 scm_remember_upto_here_1 (n
);
1526 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1531 /* returns 0 if IN is not an integer. OUT must already be
1534 coerce_to_big (SCM in
, mpz_t out
)
1537 mpz_set (out
, SCM_I_BIG_MPZ (in
));
1538 else if (SCM_INUMP (in
))
1539 mpz_set_si (out
, SCM_INUM (in
));
1546 SCM_DEFINE (scm_modulo_expt
, "modulo-expt", 3, 0, 0,
1547 (SCM n
, SCM k
, SCM m
),
1548 "Return @var{n} raised to the integer exponent\n"
1549 "@var{k}, modulo @var{m}.\n"
1552 "(modulo-expt 2 3 5)\n"
1555 #define FUNC_NAME s_scm_modulo_expt
1561 /* There are two classes of error we might encounter --
1562 1) Math errors, which we'll report by calling scm_num_overflow,
1564 2) wrong-type errors, which of course we'll report by calling
1566 We don't report those errors immediately, however; instead we do
1567 some cleanup first. These variables tell us which error (if
1568 any) we should report after cleaning up.
1570 int report_overflow
= 0;
1572 int position_of_wrong_type
= 0;
1573 SCM value_of_wrong_type
= SCM_INUM0
;
1575 SCM result
= SCM_UNDEFINED
;
1581 if (SCM_EQ_P (m
, SCM_INUM0
))
1583 report_overflow
= 1;
1587 if (!coerce_to_big (n
, n_tmp
))
1589 value_of_wrong_type
= n
;
1590 position_of_wrong_type
= 1;
1594 if (!coerce_to_big (k
, k_tmp
))
1596 value_of_wrong_type
= k
;
1597 position_of_wrong_type
= 2;
1601 if (!coerce_to_big (m
, m_tmp
))
1603 value_of_wrong_type
= m
;
1604 position_of_wrong_type
= 3;
1608 /* if the exponent K is negative, and we simply call mpz_powm, we
1609 will get a divide-by-zero exception when an inverse 1/n mod m
1610 doesn't exist (or is not unique). Since exceptions are hard to
1611 handle, we'll attempt the inversion "by hand" -- that way, we get
1612 a simple failure code, which is easy to handle. */
1614 if (-1 == mpz_sgn (k_tmp
))
1616 if (!mpz_invert (n_tmp
, n_tmp
, m_tmp
))
1618 report_overflow
= 1;
1621 mpz_neg (k_tmp
, k_tmp
);
1624 result
= scm_i_mkbig ();
1625 mpz_powm (SCM_I_BIG_MPZ (result
),
1630 if (mpz_sgn (m_tmp
) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
1631 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), m_tmp
);
1638 if (report_overflow
)
1639 scm_num_overflow (FUNC_NAME
);
1641 if (position_of_wrong_type
)
1642 SCM_WRONG_TYPE_ARG (position_of_wrong_type
,
1643 value_of_wrong_type
);
1645 return scm_i_normbig (result
);
1649 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1651 "Return @var{n} raised to the non-negative integer exponent\n"
1655 "(integer-expt 2 5)\n"
1657 "(integer-expt -3 3)\n"
1660 #define FUNC_NAME s_scm_integer_expt
1663 SCM z_i2
= SCM_BOOL_F
;
1665 SCM acc
= SCM_MAKINUM (1L);
1667 /* 0^0 == 1 according to R5RS */
1668 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1669 return SCM_FALSEP (scm_zero_p(k
)) ? n
: acc
;
1670 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1671 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1675 else if (SCM_BIGP (k
))
1677 z_i2
= scm_i_clonebig (k
, 1);
1678 scm_remember_upto_here_1 (k
);
1681 else if (SCM_REALP (k
))
1683 double r
= SCM_REAL_VALUE (k
);
1685 SCM_WRONG_TYPE_ARG (2, k
);
1686 if ((r
> SCM_MOST_POSITIVE_FIXNUM
) || (r
< SCM_MOST_NEGATIVE_FIXNUM
))
1688 z_i2
= scm_i_mkbig ();
1689 mpz_set_d (SCM_I_BIG_MPZ (z_i2
), r
);
1698 SCM_WRONG_TYPE_ARG (2, k
);
1702 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
1704 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
1705 n
= scm_divide (n
, SCM_UNDEFINED
);
1709 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
1713 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
1715 return scm_product (acc
, n
);
1717 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
1718 acc
= scm_product (acc
, n
);
1719 n
= scm_product (n
, n
);
1720 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
1728 n
= scm_divide (n
, SCM_UNDEFINED
);
1735 return scm_product (acc
, n
);
1737 acc
= scm_product (acc
, n
);
1738 n
= scm_product (n
, n
);
1745 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1747 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
1748 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
1750 "This is effectively a multiplication by 2^@var{cnt}, and when\n"
1751 "@var{cnt} is negative it's a division, rounded towards negative\n"
1752 "infinity. (Note that this is not the same rounding as\n"
1753 "@code{quotient} does.)\n"
1755 "With @var{n} viewed as an infinite precision twos complement,\n"
1756 "@code{ash} means a left shift introducing zero bits, or a right\n"
1757 "shift dropping bits.\n"
1760 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1761 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
1763 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
1764 "(ash -23 -2) @result{} -6\n"
1766 #define FUNC_NAME s_scm_ash
1770 SCM_VALIDATE_INUM (2, cnt
);
1772 bits_to_shift
= SCM_INUM (cnt
);
1774 if (bits_to_shift
< 0)
1776 /* Shift right by abs(cnt) bits. This is realized as a division
1777 by div:=2^abs(cnt). However, to guarantee the floor
1778 rounding, negative values require some special treatment.
1780 SCM div
= scm_integer_expt (SCM_MAKINUM (2),
1781 SCM_MAKINUM (-bits_to_shift
));
1783 /* scm_quotient assumes its arguments are integers, but it's legal to (ash 1/2 -1) */
1784 if (SCM_FALSEP (scm_negative_p (n
)))
1785 return scm_quotient (n
, div
);
1787 return scm_sum (SCM_MAKINUM (-1L),
1788 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1791 /* Shift left is done by multiplication with 2^CNT */
1792 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1797 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1798 (SCM n
, SCM start
, SCM end
),
1799 "Return the integer composed of the @var{start} (inclusive)\n"
1800 "through @var{end} (exclusive) bits of @var{n}. The\n"
1801 "@var{start}th bit becomes the 0-th bit in the result.\n"
1804 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1805 " @result{} \"1010\"\n"
1806 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1807 " @result{} \"10110\"\n"
1809 #define FUNC_NAME s_scm_bit_extract
1811 unsigned long int istart
, iend
, bits
;
1812 SCM_VALIDATE_INUM_MIN_COPY (2, start
,0, istart
);
1813 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1814 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1816 /* how many bits to keep */
1817 bits
= iend
- istart
;
1821 long int in
= SCM_INUM (n
);
1823 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
1824 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
1825 in
= SCM_SRS (in
, min (istart
, SCM_I_FIXNUM_BIT
-1));
1827 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
1829 /* Since we emulate two's complement encoded numbers, this
1830 * special case requires us to produce a result that has
1831 * more bits than can be stored in a fixnum.
1833 SCM result
= scm_i_long2big (in
);
1834 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
),
1839 /* mask down to requisite bits */
1840 bits
= min (bits
, SCM_I_FIXNUM_BIT
);
1841 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1843 else if (SCM_BIGP (n
))
1848 result
= SCM_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n
), istart
));
1852 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
1853 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
1854 such bits into a ulong. */
1855 result
= scm_i_mkbig ();
1856 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(n
), istart
);
1857 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result
), SCM_I_BIG_MPZ(result
), bits
);
1858 result
= scm_i_normbig (result
);
1860 scm_remember_upto_here_1 (n
);
1864 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1869 static const char scm_logtab
[] = {
1870 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1873 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1875 "Return the number of bits in integer @var{n}. If integer is\n"
1876 "positive, the 1-bits in its binary representation are counted.\n"
1877 "If negative, the 0-bits in its two's-complement binary\n"
1878 "representation are counted. If 0, 0 is returned.\n"
1881 "(logcount #b10101010)\n"
1888 #define FUNC_NAME s_scm_logcount
1892 unsigned long int c
= 0;
1893 long int nn
= SCM_INUM (n
);
1898 c
+= scm_logtab
[15 & nn
];
1901 return SCM_MAKINUM (c
);
1903 else if (SCM_BIGP (n
))
1905 unsigned long count
;
1906 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
1907 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
1909 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
1910 scm_remember_upto_here_1 (n
);
1911 return SCM_MAKINUM (count
);
1914 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1919 static const char scm_ilentab
[] = {
1920 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1924 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1926 "Return the number of bits necessary to represent @var{n}.\n"
1929 "(integer-length #b10101010)\n"
1931 "(integer-length 0)\n"
1933 "(integer-length #b1111)\n"
1936 #define FUNC_NAME s_scm_integer_length
1940 unsigned long int c
= 0;
1942 long int nn
= SCM_INUM (n
);
1948 l
= scm_ilentab
[15 & nn
];
1951 return SCM_MAKINUM (c
- 4 + l
);
1953 else if (SCM_BIGP (n
))
1955 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
1956 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
1957 1 too big, so check for that and adjust. */
1958 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
1959 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
1960 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
1961 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
1963 scm_remember_upto_here_1 (n
);
1964 return SCM_MAKINUM (size
);
1967 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1971 /*** NUMBERS -> STRINGS ***/
1973 static const double fx
[] =
1974 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1975 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1976 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1977 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1980 idbl2str (double f
, char *a
)
1982 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1988 #ifdef HAVE_COPYSIGN
1989 double sgn
= copysign (1.0, f
);
1995 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
2001 strcpy (a
, "-inf.0");
2003 strcpy (a
, "+inf.0");
2006 else if (xisnan (f
))
2008 strcpy (a
, "+nan.0");
2018 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
2019 make-uniform-vector, from causing infinite loops. */
2023 if (exp
-- < DBL_MIN_10_EXP
)
2034 if (exp
++ > DBL_MAX_10_EXP
)
2054 if (f
+ fx
[wp
] >= 10.0)
2061 dpt
= (exp
+ 9999) % 3;
2065 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2090 if (f
+ fx
[wp
] >= 1.0)
2104 if ((dpt
> 4) && (exp
> 6))
2106 d
= (a
[0] == '-' ? 2 : 1);
2107 for (i
= ch
++; i
> d
; i
--)
2120 if (a
[ch
- 1] == '.')
2121 a
[ch
++] = '0'; /* trailing zero */
2130 for (i
= 10; i
<= exp
; i
*= 10);
2131 for (i
/= 10; i
; i
/= 10)
2133 a
[ch
++] = exp
/ i
+ '0';
2142 iflo2str (SCM flt
, char *str
)
2145 if (SCM_REALP (flt
))
2146 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2149 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2150 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2152 double imag
= SCM_COMPLEX_IMAG (flt
);
2153 /* Don't output a '+' for negative numbers or for Inf and
2154 NaN. They will provide their own sign. */
2155 if (0 <= imag
&& !xisinf (imag
) && !xisnan (imag
))
2157 i
+= idbl2str (imag
, &str
[i
]);
2164 /* convert a long to a string (unterminated). returns the number of
2165 characters in the result.
2167 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2169 scm_iint2str (long num
, int rad
, char *p
)
2173 unsigned long n
= (num
< 0) ? -num
: num
;
2175 for (n
/= rad
; n
> 0; n
/= rad
)
2192 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2197 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2199 "Return a string holding the external representation of the\n"
2200 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2201 "inexact, a radix of 10 will be used.")
2202 #define FUNC_NAME s_scm_number_to_string
2206 if (SCM_UNBNDP (radix
))
2210 SCM_VALIDATE_INUM (2, radix
);
2211 base
= SCM_INUM (radix
);
2212 /* FIXME: ask if range limit was OK, and if so, document */
2213 SCM_ASSERT_RANGE (2, radix
, (base
>= 2) && (base
<= 36));
2218 char num_buf
[SCM_INTBUFLEN
];
2219 size_t length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2220 return scm_mem2string (num_buf
, length
);
2222 else if (SCM_BIGP (n
))
2224 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
2225 scm_remember_upto_here_1 (n
);
2226 return scm_take0str (str
);
2228 else if (SCM_FRACTIONP (n
))
2230 scm_i_fraction_reduce (n
);
2231 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n
), radix
),
2232 scm_mem2string ("/", 1),
2233 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n
), radix
)));
2235 else if (SCM_INEXACTP (n
))
2237 char num_buf
[FLOBUFLEN
];
2238 return scm_mem2string (num_buf
, iflo2str (n
, num_buf
));
2241 SCM_WRONG_TYPE_ARG (1, n
);
2246 /* These print routines used to be stubbed here so that scm_repl.c
2247 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
2250 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2252 char num_buf
[FLOBUFLEN
];
2253 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2258 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2261 char num_buf
[FLOBUFLEN
];
2262 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2267 scm_i_print_fraction (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2270 scm_i_fraction_reduce (sexp
);
2271 str
= scm_number_to_string (sexp
, SCM_UNDEFINED
);
2272 scm_lfwrite (SCM_STRING_CHARS (str
), SCM_STRING_LENGTH (str
), port
);
2273 scm_remember_upto_here_1 (str
);
2278 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2280 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
2281 scm_remember_upto_here_1 (exp
);
2282 scm_lfwrite (str
, (size_t) strlen (str
), port
);
2286 /*** END nums->strs ***/
2289 /*** STRINGS -> NUMBERS ***/
2291 /* The following functions implement the conversion from strings to numbers.
2292 * The implementation somehow follows the grammar for numbers as it is given
2293 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
2294 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
2295 * points should be noted about the implementation:
2296 * * Each function keeps a local index variable 'idx' that points at the
2297 * current position within the parsed string. The global index is only
2298 * updated if the function could parse the corresponding syntactic unit
2300 * * Similarly, the functions keep track of indicators of inexactness ('#',
2301 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
2302 * global exactness information is only updated after each part has been
2303 * successfully parsed.
2304 * * Sequences of digits are parsed into temporary variables holding fixnums.
2305 * Only if these fixnums would overflow, the result variables are updated
2306 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
2307 * the temporary variables holding the fixnums are cleared, and the process
2308 * starts over again. If for example fixnums were able to store five decimal
2309 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
2310 * and the result was computed as 12345 * 100000 + 67890. In other words,
2311 * only every five digits two bignum operations were performed.
2314 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
2316 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
2318 /* In non ASCII-style encodings the following macro might not work. */
2319 #define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
2322 mem2uinteger (const char* mem
, size_t len
, unsigned int *p_idx
,
2323 unsigned int radix
, enum t_exactness
*p_exactness
)
2325 unsigned int idx
= *p_idx
;
2326 unsigned int hash_seen
= 0;
2327 scm_t_bits shift
= 1;
2329 unsigned int digit_value
;
2339 digit_value
= XDIGIT2UINT (c
);
2340 if (digit_value
>= radix
)
2344 result
= SCM_MAKINUM (digit_value
);
2352 digit_value
= XDIGIT2UINT (c
);
2353 if (digit_value
>= radix
)
2365 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
2367 result
= scm_product (result
, SCM_MAKINUM (shift
));
2369 result
= scm_sum (result
, SCM_MAKINUM (add
));
2376 shift
= shift
* radix
;
2377 add
= add
* radix
+ digit_value
;
2382 result
= scm_product (result
, SCM_MAKINUM (shift
));
2384 result
= scm_sum (result
, SCM_MAKINUM (add
));
2388 *p_exactness
= INEXACT
;
2394 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2395 * covers the parts of the rules that start at a potential point. The value
2396 * of the digits up to the point have been parsed by the caller and are given
2397 * in variable result. The content of *p_exactness indicates, whether a hash
2398 * has already been seen in the digits before the point.
2401 /* In non ASCII-style encodings the following macro might not work. */
2402 #define DIGIT2UINT(d) ((d) - '0')
2405 mem2decimal_from_point (SCM result
, const char* mem
, size_t len
,
2406 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
2408 unsigned int idx
= *p_idx
;
2409 enum t_exactness x
= *p_exactness
;
2414 if (mem
[idx
] == '.')
2416 scm_t_bits shift
= 1;
2418 unsigned int digit_value
;
2419 SCM big_shift
= SCM_MAKINUM (1);
2430 digit_value
= DIGIT2UINT (c
);
2441 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
2443 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2444 result
= scm_product (result
, SCM_MAKINUM (shift
));
2446 result
= scm_sum (result
, SCM_MAKINUM (add
));
2454 add
= add
* 10 + digit_value
;
2460 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2461 result
= scm_product (result
, SCM_MAKINUM (shift
));
2462 result
= scm_sum (result
, SCM_MAKINUM (add
));
2465 result
= scm_divide (result
, big_shift
);
2467 /* We've seen a decimal point, thus the value is implicitly inexact. */
2479 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2510 exponent
= DIGIT2UINT (c
);
2517 if (exponent
<= SCM_MAXEXP
)
2518 exponent
= exponent
* 10 + DIGIT2UINT (c
);
2524 if (exponent
> SCM_MAXEXP
)
2526 size_t exp_len
= idx
- start
;
2527 SCM exp_string
= scm_mem2string (&mem
[start
], exp_len
);
2528 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
2529 scm_out_of_range ("string->number", exp_num
);
2532 e
= scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent
));
2534 result
= scm_product (result
, e
);
2536 result
= scm_divide2real (result
, e
);
2538 /* We've seen an exponent, thus the value is implicitly inexact. */
2556 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2559 mem2ureal (const char* mem
, size_t len
, unsigned int *p_idx
,
2560 unsigned int radix
, enum t_exactness
*p_exactness
)
2562 unsigned int idx
= *p_idx
;
2568 if (idx
+5 <= len
&& !strncmp (mem
+idx
, "inf.0", 5))
2574 if (idx
+4 < len
&& !strncmp (mem
+idx
, "nan.", 4))
2576 enum t_exactness x
= EXACT
;
2578 /* Cobble up the fractional part. We might want to set the
2579 NaN's mantissa from it. */
2581 mem2uinteger (mem
, len
, &idx
, 10, &x
);
2586 if (mem
[idx
] == '.')
2590 else if (idx
+ 1 == len
)
2592 else if (!isdigit (mem
[idx
+ 1]))
2595 result
= mem2decimal_from_point (SCM_MAKINUM (0), mem
, len
,
2596 p_idx
, p_exactness
);
2600 enum t_exactness x
= EXACT
;
2603 uinteger
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2604 if (SCM_FALSEP (uinteger
))
2609 else if (mem
[idx
] == '/')
2615 divisor
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2616 if (SCM_FALSEP (divisor
))
2619 /* both are int/big here, I assume */
2620 result
= scm_make_ratio (uinteger
, divisor
);
2622 else if (radix
== 10)
2624 result
= mem2decimal_from_point (uinteger
, mem
, len
, &idx
, &x
);
2625 if (SCM_FALSEP (result
))
2636 /* When returning an inexact zero, make sure it is represented as a
2637 floating point value so that we can change its sign.
2639 if (SCM_EQ_P (result
, SCM_MAKINUM(0)) && *p_exactness
== INEXACT
)
2640 result
= scm_make_real (0.0);
2646 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2649 mem2complex (const char* mem
, size_t len
, unsigned int idx
,
2650 unsigned int radix
, enum t_exactness
*p_exactness
)
2674 ureal
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2675 if (SCM_FALSEP (ureal
))
2677 /* input must be either +i or -i */
2682 if (mem
[idx
] == 'i' || mem
[idx
] == 'I')
2688 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign
));
2695 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2696 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
2705 /* either +<ureal>i or -<ureal>i */
2712 return scm_make_rectangular (SCM_MAKINUM (0), ureal
);
2715 /* polar input: <real>@<real>. */
2740 angle
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2741 if (SCM_FALSEP (angle
))
2746 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2747 angle
= scm_difference (angle
, SCM_UNDEFINED
);
2749 result
= scm_make_polar (ureal
, angle
);
2754 /* expecting input matching <real>[+-]<ureal>?i */
2761 int sign
= (c
== '+') ? 1 : -1;
2762 SCM imag
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2764 if (SCM_FALSEP (imag
))
2765 imag
= SCM_MAKINUM (sign
);
2766 else if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2767 imag
= scm_difference (imag
, SCM_UNDEFINED
);
2771 if (mem
[idx
] != 'i' && mem
[idx
] != 'I')
2778 return scm_make_rectangular (ureal
, imag
);
2787 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2789 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
2792 scm_i_mem2number (const char* mem
, size_t len
, unsigned int default_radix
)
2794 unsigned int idx
= 0;
2795 unsigned int radix
= NO_RADIX
;
2796 enum t_exactness forced_x
= NO_EXACTNESS
;
2797 enum t_exactness implicit_x
= EXACT
;
2800 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2801 while (idx
+ 2 < len
&& mem
[idx
] == '#')
2803 switch (mem
[idx
+ 1])
2806 if (radix
!= NO_RADIX
)
2811 if (radix
!= NO_RADIX
)
2816 if (forced_x
!= NO_EXACTNESS
)
2821 if (forced_x
!= NO_EXACTNESS
)
2826 if (radix
!= NO_RADIX
)
2831 if (radix
!= NO_RADIX
)
2841 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2842 if (radix
== NO_RADIX
)
2843 result
= mem2complex (mem
, len
, idx
, default_radix
, &implicit_x
);
2845 result
= mem2complex (mem
, len
, idx
, (unsigned int) radix
, &implicit_x
);
2847 if (SCM_FALSEP (result
))
2853 if (SCM_INEXACTP (result
))
2854 return scm_inexact_to_exact (result
);
2858 if (SCM_INEXACTP (result
))
2861 return scm_exact_to_inexact (result
);
2864 if (implicit_x
== INEXACT
)
2866 if (SCM_INEXACTP (result
))
2869 return scm_exact_to_inexact (result
);
2877 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2878 (SCM string
, SCM radix
),
2879 "Return a number of the maximally precise representation\n"
2880 "expressed by the given @var{string}. @var{radix} must be an\n"
2881 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2882 "is a default radix that may be overridden by an explicit radix\n"
2883 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2884 "supplied, then the default radix is 10. If string is not a\n"
2885 "syntactically valid notation for a number, then\n"
2886 "@code{string->number} returns @code{#f}.")
2887 #define FUNC_NAME s_scm_string_to_number
2891 SCM_VALIDATE_STRING (1, string
);
2892 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix
,2,10, base
);
2893 answer
= scm_i_mem2number (SCM_STRING_CHARS (string
),
2894 SCM_STRING_LENGTH (string
),
2896 return scm_return_first (answer
, string
);
2901 /*** END strs->nums ***/
2905 scm_make_real (double x
)
2907 SCM z
= scm_double_cell (scm_tc16_real
, 0, 0, 0);
2909 SCM_REAL_VALUE (z
) = x
;
2915 scm_make_complex (double x
, double y
)
2918 return scm_make_real (x
);
2922 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_gc_malloc (sizeof (scm_t_complex
),
2924 SCM_COMPLEX_REAL (z
) = x
;
2925 SCM_COMPLEX_IMAG (z
) = y
;
2932 scm_bigequal (SCM x
, SCM y
)
2934 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2935 scm_remember_upto_here_2 (x
, y
);
2936 return SCM_BOOL (0 == result
);
2940 scm_real_equalp (SCM x
, SCM y
)
2942 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2946 scm_complex_equalp (SCM x
, SCM y
)
2948 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2949 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2953 scm_i_fraction_equalp (SCM x
, SCM y
)
2955 scm_i_fraction_reduce (x
);
2956 scm_i_fraction_reduce (y
);
2957 if (SCM_FALSEP (scm_equal_p (SCM_FRACTION_NUMERATOR (x
),
2958 SCM_FRACTION_NUMERATOR (y
)))
2959 || SCM_FALSEP (scm_equal_p (SCM_FRACTION_DENOMINATOR (x
),
2960 SCM_FRACTION_DENOMINATOR (y
))))
2967 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2968 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2969 * "else. Note that the sets of complex, real, rational and\n"
2970 * "integer values form subsets of the set of numbers, i. e. the\n"
2971 * "predicate will be fulfilled for any number."
2973 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2975 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2976 "otherwise. Note that the sets of real, rational and integer\n"
2977 "values form subsets of the set of complex numbers, i. e. the\n"
2978 "predicate will also be fulfilled if @var{x} is a real,\n"
2979 "rational or integer number.")
2980 #define FUNC_NAME s_scm_number_p
2982 return SCM_BOOL (SCM_NUMBERP (x
));
2987 SCM_DEFINE (scm_real_p
, "real?", 1, 0, 0,
2989 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
2990 "otherwise. Note that the set of integer values forms a subset of\n"
2991 "the set of real numbers, i. e. the predicate will also be\n"
2992 "fulfilled if @var{x} is an integer number.")
2993 #define FUNC_NAME s_scm_real_p
2995 /* we can't represent irrational numbers. */
2996 return scm_rational_p (x
);
3000 SCM_DEFINE (scm_rational_p
, "rational?", 1, 0, 0,
3002 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
3003 "otherwise. Note that the set of integer values forms a subset of\n"
3004 "the set of rational numbers, i. e. the predicate will also be\n"
3005 "fulfilled if @var{x} is an integer number.")
3006 #define FUNC_NAME s_scm_rational_p
3010 else if (SCM_IMP (x
))
3012 else if (SCM_BIGP (x
))
3014 else if (SCM_FRACTIONP (x
))
3016 else if (SCM_REALP (x
))
3017 /* due to their limited precision, all floating point numbers are
3018 rational as well. */
3026 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
3028 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
3030 #define FUNC_NAME s_scm_integer_p
3039 if (!SCM_INEXACTP (x
))
3041 if (SCM_COMPLEXP (x
))
3043 r
= SCM_REAL_VALUE (x
);
3051 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
3053 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
3055 #define FUNC_NAME s_scm_inexact_p
3057 if (SCM_INEXACTP (x
))
3059 if (SCM_NUMBERP (x
))
3061 SCM_WRONG_TYPE_ARG (1, x
);
3066 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
3067 /* "Return @code{#t} if all parameters are numerically equal." */
3069 scm_num_eq_p (SCM x
, SCM y
)
3074 long xx
= SCM_INUM (x
);
3077 long yy
= SCM_INUM (y
);
3078 return SCM_BOOL (xx
== yy
);
3080 else if (SCM_BIGP (y
))
3082 else if (SCM_REALP (y
))
3083 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
3084 else if (SCM_COMPLEXP (y
))
3085 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
3086 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3087 else if (SCM_FRACTIONP (y
))
3090 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3092 else if (SCM_BIGP (x
))
3096 else if (SCM_BIGP (y
))
3098 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3099 scm_remember_upto_here_2 (x
, y
);
3100 return SCM_BOOL (0 == cmp
);
3102 else if (SCM_REALP (y
))
3105 if (xisnan (SCM_REAL_VALUE (y
)))
3107 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
3108 scm_remember_upto_here_1 (x
);
3109 return SCM_BOOL (0 == cmp
);
3111 else if (SCM_COMPLEXP (y
))
3114 if (0.0 != SCM_COMPLEX_IMAG (y
))
3116 if (xisnan (SCM_COMPLEX_REAL (y
)))
3118 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
3119 scm_remember_upto_here_1 (x
);
3120 return SCM_BOOL (0 == cmp
);
3122 else if (SCM_FRACTIONP (y
))
3125 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3127 else if (SCM_REALP (x
))
3130 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3131 else if (SCM_BIGP (y
))
3134 if (xisnan (SCM_REAL_VALUE (x
)))
3136 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
3137 scm_remember_upto_here_1 (y
);
3138 return SCM_BOOL (0 == cmp
);
3140 else if (SCM_REALP (y
))
3141 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3142 else if (SCM_COMPLEXP (y
))
3143 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3144 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3145 else if (SCM_FRACTIONP (y
))
3147 double xx
= SCM_REAL_VALUE (x
);
3151 return SCM_BOOL (xx
< 0.0);
3152 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
3156 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3158 else if (SCM_COMPLEXP (x
))
3161 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3162 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3163 else if (SCM_BIGP (y
))
3166 if (0.0 != SCM_COMPLEX_IMAG (x
))
3168 if (xisnan (SCM_COMPLEX_REAL (x
)))
3170 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
3171 scm_remember_upto_here_1 (y
);
3172 return SCM_BOOL (0 == cmp
);
3174 else if (SCM_REALP (y
))
3175 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3176 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3177 else if (SCM_COMPLEXP (y
))
3178 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3179 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3180 else if (SCM_FRACTIONP (y
))
3183 if (SCM_COMPLEX_IMAG (x
) != 0.0)
3185 xx
= SCM_COMPLEX_REAL (x
);
3189 return SCM_BOOL (xx
< 0.0);
3190 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
3194 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3196 else if (SCM_FRACTIONP (x
))
3200 else if (SCM_BIGP (y
))
3202 else if (SCM_REALP (y
))
3204 double yy
= SCM_REAL_VALUE (y
);
3208 return SCM_BOOL (0.0 < yy
);
3209 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
3212 else if (SCM_COMPLEXP (y
))
3215 if (SCM_COMPLEX_IMAG (y
) != 0.0)
3217 yy
= SCM_COMPLEX_REAL (y
);
3221 return SCM_BOOL (0.0 < yy
);
3222 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
3225 else if (SCM_FRACTIONP (y
))
3226 return scm_i_fraction_equalp (x
, y
);
3228 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3231 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3235 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
3236 done are good for inums, but for bignums an answer can almost always be
3237 had by just examining a few high bits of the operands, as done by GMP in
3238 mpq_cmp. flonum/frac compares likewise, but with the slight complication
3239 of the float exponent to take into account. */
3241 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3242 /* "Return @code{#t} if the list of parameters is monotonically\n"
3246 scm_less_p (SCM x
, SCM y
)
3251 long xx
= SCM_INUM (x
);
3254 long yy
= SCM_INUM (y
);
3255 return SCM_BOOL (xx
< yy
);
3257 else if (SCM_BIGP (y
))
3259 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3260 scm_remember_upto_here_1 (y
);
3261 return SCM_BOOL (sgn
> 0);
3263 else if (SCM_REALP (y
))
3264 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3265 else if (SCM_FRACTIONP (y
))
3267 /* "x < a/b" becomes "x*b < a" */
3269 x
= scm_product (x
, SCM_FRACTION_DENOMINATOR (y
));
3270 y
= SCM_FRACTION_NUMERATOR (y
);
3274 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3276 else if (SCM_BIGP (x
))
3280 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3281 scm_remember_upto_here_1 (x
);
3282 return SCM_BOOL (sgn
< 0);
3284 else if (SCM_BIGP (y
))
3286 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3287 scm_remember_upto_here_2 (x
, y
);
3288 return SCM_BOOL (cmp
< 0);
3290 else if (SCM_REALP (y
))
3293 if (xisnan (SCM_REAL_VALUE (y
)))
3295 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
3296 scm_remember_upto_here_1 (x
);
3297 return SCM_BOOL (cmp
< 0);
3299 else if (SCM_FRACTIONP (y
))
3302 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3304 else if (SCM_REALP (x
))
3307 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3308 else if (SCM_BIGP (y
))
3311 if (xisnan (SCM_REAL_VALUE (x
)))
3313 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
3314 scm_remember_upto_here_1 (y
);
3315 return SCM_BOOL (cmp
> 0);
3317 else if (SCM_REALP (y
))
3318 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3319 else if (SCM_FRACTIONP (y
))
3321 double xx
= SCM_REAL_VALUE (x
);
3325 return SCM_BOOL (xx
< 0.0);
3326 x
= scm_inexact_to_exact (x
); /* with x as frac or int */
3330 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3332 else if (SCM_FRACTIONP (x
))
3334 if (SCM_INUMP (y
) || SCM_BIGP (y
))
3336 /* "a/b < y" becomes "a < y*b" */
3337 y
= scm_product (y
, SCM_FRACTION_DENOMINATOR (x
));
3338 x
= SCM_FRACTION_NUMERATOR (x
);
3341 else if (SCM_REALP (y
))
3343 double yy
= SCM_REAL_VALUE (y
);
3347 return SCM_BOOL (0.0 < yy
);
3348 y
= scm_inexact_to_exact (y
); /* with y as frac or int */
3351 else if (SCM_FRACTIONP (y
))
3353 /* "a/b < c/d" becomes "a*d < c*b" */
3354 SCM new_x
= scm_product (SCM_FRACTION_NUMERATOR (x
),
3355 SCM_FRACTION_DENOMINATOR (y
));
3356 SCM new_y
= scm_product (SCM_FRACTION_NUMERATOR (y
),
3357 SCM_FRACTION_DENOMINATOR (x
));
3363 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3366 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3370 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3371 /* "Return @code{#t} if the list of parameters is monotonically\n"
3374 #define FUNC_NAME s_scm_gr_p
3376 scm_gr_p (SCM x
, SCM y
)
3378 if (!SCM_NUMBERP (x
))
3379 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3380 else if (!SCM_NUMBERP (y
))
3381 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3383 return scm_less_p (y
, x
);
3388 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3389 /* "Return @code{#t} if the list of parameters is monotonically\n"
3392 #define FUNC_NAME s_scm_leq_p
3394 scm_leq_p (SCM x
, SCM y
)
3396 if (!SCM_NUMBERP (x
))
3397 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3398 else if (!SCM_NUMBERP (y
))
3399 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3400 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
3403 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3408 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3409 /* "Return @code{#t} if the list of parameters is monotonically\n"
3412 #define FUNC_NAME s_scm_geq_p
3414 scm_geq_p (SCM x
, SCM y
)
3416 if (!SCM_NUMBERP (x
))
3417 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3418 else if (!SCM_NUMBERP (y
))
3419 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3420 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
3423 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3428 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3429 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3436 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3437 else if (SCM_BIGP (z
))
3439 else if (SCM_REALP (z
))
3440 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3441 else if (SCM_COMPLEXP (z
))
3442 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3443 && SCM_COMPLEX_IMAG (z
) == 0.0);
3444 else if (SCM_FRACTIONP (z
))
3447 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3451 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3452 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3456 scm_positive_p (SCM x
)
3459 return SCM_BOOL (SCM_INUM (x
) > 0);
3460 else if (SCM_BIGP (x
))
3462 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3463 scm_remember_upto_here_1 (x
);
3464 return SCM_BOOL (sgn
> 0);
3466 else if (SCM_REALP (x
))
3467 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3468 else if (SCM_FRACTIONP (x
))
3469 return scm_positive_p (SCM_FRACTION_NUMERATOR (x
));
3471 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3475 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3476 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3480 scm_negative_p (SCM x
)
3483 return SCM_BOOL (SCM_INUM (x
) < 0);
3484 else if (SCM_BIGP (x
))
3486 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3487 scm_remember_upto_here_1 (x
);
3488 return SCM_BOOL (sgn
< 0);
3490 else if (SCM_REALP (x
))
3491 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3492 else if (SCM_FRACTIONP (x
))
3493 return scm_negative_p (SCM_FRACTION_NUMERATOR (x
));
3495 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3499 /* scm_min and scm_max return an inexact when either argument is inexact, as
3500 required by r5rs. On that basis, for exact/inexact combinations the
3501 exact is converted to inexact to compare and possibly return. This is
3502 unlike scm_less_p above which takes some trouble to preserve all bits in
3503 its test, such trouble is not required for min and max. */
3505 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3506 /* "Return the maximum of all parameter values."
3509 scm_max (SCM x
, SCM y
)
3514 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
3515 else if (SCM_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
3518 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3523 long xx
= SCM_INUM (x
);
3526 long yy
= SCM_INUM (y
);
3527 return (xx
< yy
) ? y
: x
;
3529 else if (SCM_BIGP (y
))
3531 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3532 scm_remember_upto_here_1 (y
);
3533 return (sgn
< 0) ? x
: y
;
3535 else if (SCM_REALP (y
))
3538 /* if y==NaN then ">" is false and we return NaN */
3539 return (z
> SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3541 else if (SCM_FRACTIONP (y
))
3544 return (SCM_FALSEP (scm_less_p (x
, y
)) ? x
: y
);
3547 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3549 else if (SCM_BIGP (x
))
3553 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3554 scm_remember_upto_here_1 (x
);
3555 return (sgn
< 0) ? y
: x
;
3557 else if (SCM_BIGP (y
))
3559 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3560 scm_remember_upto_here_2 (x
, y
);
3561 return (cmp
> 0) ? x
: y
;
3563 else if (SCM_REALP (y
))
3565 /* if y==NaN then xx>yy is false, so we return the NaN y */
3568 xx
= scm_i_big2dbl (x
);
3569 yy
= SCM_REAL_VALUE (y
);
3570 return (xx
> yy
? scm_make_real (xx
) : y
);
3572 else if (SCM_FRACTIONP (y
))
3577 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3579 else if (SCM_REALP (x
))
3583 double z
= SCM_INUM (y
);
3584 /* if x==NaN then "<" is false and we return NaN */
3585 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3587 else if (SCM_BIGP (y
))
3592 else if (SCM_REALP (y
))
3594 /* if x==NaN then our explicit check means we return NaN
3595 if y==NaN then ">" is false and we return NaN
3596 calling isnan is unavoidable, since it's the only way to know
3597 which of x or y causes any compares to be false */
3598 double xx
= SCM_REAL_VALUE (x
);
3599 return (xisnan (xx
) || xx
> SCM_REAL_VALUE (y
)) ? x
: y
;
3601 else if (SCM_FRACTIONP (y
))
3603 double yy
= scm_i_fraction2double (y
);
3604 double xx
= SCM_REAL_VALUE (x
);
3605 return (xx
< yy
) ? scm_make_real (yy
) : x
;
3608 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3610 else if (SCM_FRACTIONP (x
))
3616 else if (SCM_BIGP (y
))
3620 else if (SCM_REALP (y
))
3622 double xx
= scm_i_fraction2double (x
);
3623 return (xx
< SCM_REAL_VALUE (y
)) ? y
: scm_make_real (xx
);
3625 else if (SCM_FRACTIONP (y
))
3630 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3633 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3637 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3638 /* "Return the minium of all parameter values."
3641 scm_min (SCM x
, SCM y
)
3646 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
3647 else if (SCM_INUMP(x
) || SCM_BIGP(x
) || SCM_REALP(x
) || SCM_FRACTIONP(x
))
3650 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3655 long xx
= SCM_INUM (x
);
3658 long yy
= SCM_INUM (y
);
3659 return (xx
< yy
) ? x
: y
;
3661 else if (SCM_BIGP (y
))
3663 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3664 scm_remember_upto_here_1 (y
);
3665 return (sgn
< 0) ? y
: x
;
3667 else if (SCM_REALP (y
))
3670 /* if y==NaN then "<" is false and we return NaN */
3671 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3673 else if (SCM_FRACTIONP (y
))
3676 return (SCM_FALSEP (scm_less_p (x
, y
)) ? y
: x
);
3679 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3681 else if (SCM_BIGP (x
))
3685 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3686 scm_remember_upto_here_1 (x
);
3687 return (sgn
< 0) ? x
: y
;
3689 else if (SCM_BIGP (y
))
3691 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3692 scm_remember_upto_here_2 (x
, y
);
3693 return (cmp
> 0) ? y
: x
;
3695 else if (SCM_REALP (y
))
3697 /* if y==NaN then xx<yy is false, so we return the NaN y */
3700 xx
= scm_i_big2dbl (x
);
3701 yy
= SCM_REAL_VALUE (y
);
3702 return (xx
< yy
? scm_make_real (xx
) : y
);
3704 else if (SCM_FRACTIONP (y
))
3709 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3711 else if (SCM_REALP (x
))
3715 double z
= SCM_INUM (y
);
3716 /* if x==NaN then "<" is false and we return NaN */
3717 return (z
< SCM_REAL_VALUE (x
)) ? scm_make_real (z
) : x
;
3719 else if (SCM_BIGP (y
))
3724 else if (SCM_REALP (y
))
3726 /* if x==NaN then our explicit check means we return NaN
3727 if y==NaN then "<" is false and we return NaN
3728 calling isnan is unavoidable, since it's the only way to know
3729 which of x or y causes any compares to be false */
3730 double xx
= SCM_REAL_VALUE (x
);
3731 return (xisnan (xx
) || xx
< SCM_REAL_VALUE (y
)) ? x
: y
;
3733 else if (SCM_FRACTIONP (y
))
3735 double yy
= scm_i_fraction2double (y
);
3736 double xx
= SCM_REAL_VALUE (x
);
3737 return (yy
< xx
) ? scm_make_real (yy
) : x
;
3740 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3742 else if (SCM_FRACTIONP (x
))
3748 else if (SCM_BIGP (y
))
3752 else if (SCM_REALP (y
))
3754 double xx
= scm_i_fraction2double (x
);
3755 return (SCM_REAL_VALUE (y
) < xx
) ? y
: scm_make_real (xx
);
3757 else if (SCM_FRACTIONP (y
))
3762 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3765 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3769 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3770 /* "Return the sum of all parameter values. Return 0 if called without\n"
3774 scm_sum (SCM x
, SCM y
)
3778 if (SCM_NUMBERP (x
)) return x
;
3779 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
3780 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3787 long xx
= SCM_INUM (x
);
3788 long yy
= SCM_INUM (y
);
3789 long int z
= xx
+ yy
;
3790 return SCM_FIXABLE (z
) ? SCM_MAKINUM (z
) : scm_i_long2big (z
);
3792 else if (SCM_BIGP (y
))
3797 else if (SCM_REALP (y
))
3799 long int xx
= SCM_INUM (x
);
3800 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3802 else if (SCM_COMPLEXP (y
))
3804 long int xx
= SCM_INUM (x
);
3805 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3806 SCM_COMPLEX_IMAG (y
));
3808 else if (SCM_FRACTIONP (y
))
3809 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
3810 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
3811 SCM_FRACTION_DENOMINATOR (y
));
3813 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3814 } else if (SCM_BIGP (x
))
3821 inum
= SCM_INUM (y
);
3824 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3827 SCM result
= scm_i_mkbig ();
3828 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
3829 scm_remember_upto_here_1 (x
);
3830 /* we know the result will have to be a bignum */
3833 return scm_i_normbig (result
);
3837 SCM result
= scm_i_mkbig ();
3838 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
3839 scm_remember_upto_here_1 (x
);
3840 /* we know the result will have to be a bignum */
3843 return scm_i_normbig (result
);
3846 else if (SCM_BIGP (y
))
3848 SCM result
= scm_i_mkbig ();
3849 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3850 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3851 mpz_add (SCM_I_BIG_MPZ (result
),
3854 scm_remember_upto_here_2 (x
, y
);
3855 /* we know the result will have to be a bignum */
3858 return scm_i_normbig (result
);
3860 else if (SCM_REALP (y
))
3862 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
3863 scm_remember_upto_here_1 (x
);
3864 return scm_make_real (result
);
3866 else if (SCM_COMPLEXP (y
))
3868 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
3869 + SCM_COMPLEX_REAL (y
));
3870 scm_remember_upto_here_1 (x
);
3871 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (y
));
3873 else if (SCM_FRACTIONP (y
))
3874 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y
),
3875 scm_product (x
, SCM_FRACTION_DENOMINATOR (y
))),
3876 SCM_FRACTION_DENOMINATOR (y
));
3878 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3880 else if (SCM_REALP (x
))
3883 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3884 else if (SCM_BIGP (y
))
3886 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
3887 scm_remember_upto_here_1 (y
);
3888 return scm_make_real (result
);
3890 else if (SCM_REALP (y
))
3891 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3892 else if (SCM_COMPLEXP (y
))
3893 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3894 SCM_COMPLEX_IMAG (y
));
3895 else if (SCM_FRACTIONP (y
))
3896 return scm_make_real (SCM_REAL_VALUE (x
) + scm_i_fraction2double (y
));
3898 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3900 else if (SCM_COMPLEXP (x
))
3903 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3904 SCM_COMPLEX_IMAG (x
));
3905 else if (SCM_BIGP (y
))
3907 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
3908 + SCM_COMPLEX_REAL (x
));
3909 scm_remember_upto_here_1 (y
);
3910 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (x
));
3912 else if (SCM_REALP (y
))
3913 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3914 SCM_COMPLEX_IMAG (x
));
3915 else if (SCM_COMPLEXP (y
))
3916 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3917 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3918 else if (SCM_FRACTIONP (y
))
3919 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_i_fraction2double (y
),
3920 SCM_COMPLEX_IMAG (x
));
3922 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3924 else if (SCM_FRACTIONP (x
))
3927 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
3928 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
3929 SCM_FRACTION_DENOMINATOR (x
));
3930 else if (SCM_BIGP (y
))
3931 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x
),
3932 scm_product (y
, SCM_FRACTION_DENOMINATOR (x
))),
3933 SCM_FRACTION_DENOMINATOR (x
));
3934 else if (SCM_REALP (y
))
3935 return scm_make_real (SCM_REAL_VALUE (y
) + scm_i_fraction2double (x
));
3936 else if (SCM_COMPLEXP (y
))
3937 return scm_make_complex (SCM_COMPLEX_REAL (y
) + scm_i_fraction2double (x
),
3938 SCM_COMPLEX_IMAG (y
));
3939 else if (SCM_FRACTIONP (y
))
3940 /* a/b + c/d = (ad + bc) / bd */
3941 return scm_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
3942 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
3943 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
3945 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3948 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3952 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3953 /* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3954 * the sum of all but the first argument are subtracted from the first
3956 #define FUNC_NAME s_difference
3958 scm_difference (SCM x
, SCM y
)
3963 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3967 long xx
= -SCM_INUM (x
);
3968 if (SCM_FIXABLE (xx
))
3969 return SCM_MAKINUM (xx
);
3971 return scm_i_long2big (xx
);
3973 else if (SCM_BIGP (x
))
3974 /* FIXME: do we really need to normalize here? */
3975 return scm_i_normbig (scm_i_clonebig (x
, 0));
3976 else if (SCM_REALP (x
))
3977 return scm_make_real (-SCM_REAL_VALUE (x
));
3978 else if (SCM_COMPLEXP (x
))
3979 return scm_make_complex (-SCM_COMPLEX_REAL (x
),
3980 -SCM_COMPLEX_IMAG (x
));
3981 else if (SCM_FRACTIONP (x
))
3982 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
), SCM_UNDEFINED
),
3983 SCM_FRACTION_DENOMINATOR (x
));
3985 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3992 long int xx
= SCM_INUM (x
);
3993 long int yy
= SCM_INUM (y
);
3994 long int z
= xx
- yy
;
3995 if (SCM_FIXABLE (z
))
3996 return SCM_MAKINUM (z
);
3998 return scm_i_long2big (z
);
4000 else if (SCM_BIGP (y
))
4002 /* inum-x - big-y */
4003 long xx
= SCM_INUM (x
);
4006 return scm_i_clonebig (y
, 0);
4009 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
4010 SCM result
= scm_i_mkbig ();
4013 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
4016 /* x - y == -(y + -x) */
4017 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
4018 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
4020 scm_remember_upto_here_1 (y
);
4022 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
4023 /* we know the result will have to be a bignum */
4026 return scm_i_normbig (result
);
4029 else if (SCM_REALP (y
))
4031 long int xx
= SCM_INUM (x
);
4032 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
4034 else if (SCM_COMPLEXP (y
))
4036 long int xx
= SCM_INUM (x
);
4037 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
4038 - SCM_COMPLEX_IMAG (y
));
4040 else if (SCM_FRACTIONP (y
))
4041 /* a - b/c = (ac - b) / c */
4042 return scm_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4043 SCM_FRACTION_NUMERATOR (y
)),
4044 SCM_FRACTION_DENOMINATOR (y
));
4046 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4048 else if (SCM_BIGP (x
))
4052 /* big-x - inum-y */
4053 long yy
= SCM_INUM (y
);
4054 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4056 scm_remember_upto_here_1 (x
);
4058 return SCM_FIXABLE (-yy
) ? SCM_MAKINUM (-yy
) : scm_long2num (-yy
);
4061 SCM result
= scm_i_mkbig ();
4064 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
4066 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
4067 scm_remember_upto_here_1 (x
);
4069 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
4070 /* we know the result will have to be a bignum */
4073 return scm_i_normbig (result
);
4076 else if (SCM_BIGP (y
))
4078 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4079 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
4080 SCM result
= scm_i_mkbig ();
4081 mpz_sub (SCM_I_BIG_MPZ (result
),
4084 scm_remember_upto_here_2 (x
, y
);
4085 /* we know the result will have to be a bignum */
4086 if ((sgn_x
== 1) && (sgn_y
== -1))
4088 if ((sgn_x
== -1) && (sgn_y
== 1))
4090 return scm_i_normbig (result
);
4092 else if (SCM_REALP (y
))
4094 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
4095 scm_remember_upto_here_1 (x
);
4096 return scm_make_real (result
);
4098 else if (SCM_COMPLEXP (y
))
4100 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
4101 - SCM_COMPLEX_REAL (y
));
4102 scm_remember_upto_here_1 (x
);
4103 return scm_make_complex (real_part
, - SCM_COMPLEX_IMAG (y
));
4105 else if (SCM_FRACTIONP (y
))
4106 return scm_make_ratio (scm_difference (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4107 SCM_FRACTION_NUMERATOR (y
)),
4108 SCM_FRACTION_DENOMINATOR (y
));
4109 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4111 else if (SCM_REALP (x
))
4114 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
4115 else if (SCM_BIGP (y
))
4117 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
4118 scm_remember_upto_here_1 (x
);
4119 return scm_make_real (result
);
4121 else if (SCM_REALP (y
))
4122 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
4123 else if (SCM_COMPLEXP (y
))
4124 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
4125 -SCM_COMPLEX_IMAG (y
));
4126 else if (SCM_FRACTIONP (y
))
4127 return scm_make_real (SCM_REAL_VALUE (x
) - scm_i_fraction2double (y
));
4129 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4131 else if (SCM_COMPLEXP (x
))
4134 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
4135 SCM_COMPLEX_IMAG (x
));
4136 else if (SCM_BIGP (y
))
4138 double real_part
= (SCM_COMPLEX_REAL (x
)
4139 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
4140 scm_remember_upto_here_1 (x
);
4141 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (y
));
4143 else if (SCM_REALP (y
))
4144 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
4145 SCM_COMPLEX_IMAG (x
));
4146 else if (SCM_COMPLEXP (y
))
4147 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
4148 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
4149 else if (SCM_FRACTIONP (y
))
4150 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_i_fraction2double (y
),
4151 SCM_COMPLEX_IMAG (x
));
4153 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4155 else if (SCM_FRACTIONP (x
))
4158 /* a/b - c = (a - cb) / b */
4159 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
4160 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
4161 SCM_FRACTION_DENOMINATOR (x
));
4162 else if (SCM_BIGP (y
))
4163 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x
),
4164 scm_product(y
, SCM_FRACTION_DENOMINATOR (x
))),
4165 SCM_FRACTION_DENOMINATOR (x
));
4166 else if (SCM_REALP (y
))
4167 return scm_make_real (scm_i_fraction2double (x
) - SCM_REAL_VALUE (y
));
4168 else if (SCM_COMPLEXP (y
))
4169 return scm_make_complex (scm_i_fraction2double (x
) - SCM_COMPLEX_REAL (y
),
4170 -SCM_COMPLEX_IMAG (y
));
4171 else if (SCM_FRACTIONP (y
))
4172 /* a/b - c/d = (ad - bc) / bd */
4173 return scm_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
4174 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
))),
4175 scm_product (SCM_FRACTION_DENOMINATOR (x
), SCM_FRACTION_DENOMINATOR (y
)));
4177 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
4180 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
4185 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
4186 /* "Return the product of all arguments. If called without arguments,\n"
4190 scm_product (SCM x
, SCM y
)
4195 return SCM_MAKINUM (1L);
4196 else if (SCM_NUMBERP (x
))
4199 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
4211 case 0: return x
; break;
4212 case 1: return y
; break;
4217 long yy
= SCM_INUM (y
);
4219 SCM k
= SCM_MAKINUM (kk
);
4220 if ((kk
== SCM_INUM (k
)) && (kk
/ xx
== yy
))
4224 SCM result
= scm_i_long2big (xx
);
4225 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
4226 return scm_i_normbig (result
);
4229 else if (SCM_BIGP (y
))
4231 SCM result
= scm_i_mkbig ();
4232 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
4233 scm_remember_upto_here_1 (y
);
4236 else if (SCM_REALP (y
))
4237 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
4238 else if (SCM_COMPLEXP (y
))
4239 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
4240 xx
* SCM_COMPLEX_IMAG (y
));
4241 else if (SCM_FRACTIONP (y
))
4242 return scm_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
4243 SCM_FRACTION_DENOMINATOR (y
));
4245 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4247 else if (SCM_BIGP (x
))
4254 else if (SCM_BIGP (y
))
4256 SCM result
= scm_i_mkbig ();
4257 mpz_mul (SCM_I_BIG_MPZ (result
),
4260 scm_remember_upto_here_2 (x
, y
);
4263 else if (SCM_REALP (y
))
4265 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
4266 scm_remember_upto_here_1 (x
);
4267 return scm_make_real (result
);
4269 else if (SCM_COMPLEXP (y
))
4271 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
4272 scm_remember_upto_here_1 (x
);
4273 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
4274 z
* SCM_COMPLEX_IMAG (y
));
4276 else if (SCM_FRACTIONP (y
))
4277 return scm_make_ratio (scm_product (x
, SCM_FRACTION_NUMERATOR (y
)),
4278 SCM_FRACTION_DENOMINATOR (y
));
4280 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4282 else if (SCM_REALP (x
))
4285 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
4286 else if (SCM_BIGP (y
))
4288 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
4289 scm_remember_upto_here_1 (y
);
4290 return scm_make_real (result
);
4292 else if (SCM_REALP (y
))
4293 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
4294 else if (SCM_COMPLEXP (y
))
4295 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
4296 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
4297 else if (SCM_FRACTIONP (y
))
4298 return scm_make_real (SCM_REAL_VALUE (x
) * scm_i_fraction2double (y
));
4300 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4302 else if (SCM_COMPLEXP (x
))
4305 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
4306 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
4307 else if (SCM_BIGP (y
))
4309 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4310 scm_remember_upto_here_1 (y
);
4311 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
4312 z
* SCM_COMPLEX_IMAG (x
));
4314 else if (SCM_REALP (y
))
4315 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
4316 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
4317 else if (SCM_COMPLEXP (y
))
4319 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
4320 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
4321 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
4322 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
4324 else if (SCM_FRACTIONP (y
))
4326 double yy
= scm_i_fraction2double (y
);
4327 return scm_make_complex (yy
* SCM_COMPLEX_REAL (x
),
4328 yy
* SCM_COMPLEX_IMAG (x
));
4331 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4333 else if (SCM_FRACTIONP (x
))
4336 return scm_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
4337 SCM_FRACTION_DENOMINATOR (x
));
4338 else if (SCM_BIGP (y
))
4339 return scm_make_ratio (scm_product (y
, SCM_FRACTION_NUMERATOR (x
)),
4340 SCM_FRACTION_DENOMINATOR (x
));
4341 else if (SCM_REALP (y
))
4342 return scm_make_real (scm_i_fraction2double (x
) * SCM_REAL_VALUE (y
));
4343 else if (SCM_COMPLEXP (y
))
4345 double xx
= scm_i_fraction2double (x
);
4346 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
4347 xx
* SCM_COMPLEX_IMAG (y
));
4349 else if (SCM_FRACTIONP (y
))
4350 /* a/b * c/d = ac / bd */
4351 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
),
4352 SCM_FRACTION_NUMERATOR (y
)),
4353 scm_product (SCM_FRACTION_DENOMINATOR (x
),
4354 SCM_FRACTION_DENOMINATOR (y
)));
4356 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
4359 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
4363 scm_num2dbl (SCM a
, const char *why
)
4364 #define FUNC_NAME why
4367 return (double) SCM_INUM (a
);
4368 else if (SCM_BIGP (a
))
4370 double result
= mpz_get_d (SCM_I_BIG_MPZ (a
));
4371 scm_remember_upto_here_1 (a
);
4374 else if (SCM_REALP (a
))
4375 return (SCM_REAL_VALUE (a
));
4376 else if (SCM_FRACTIONP (a
))
4377 return scm_i_fraction2double (a
);
4379 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
4383 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
4384 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
4385 #define ALLOW_DIVIDE_BY_ZERO
4386 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
4389 /* The code below for complex division is adapted from the GNU
4390 libstdc++, which adapted it from f2c's libF77, and is subject to
4393 /****************************************************************
4394 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
4396 Permission to use, copy, modify, and distribute this software
4397 and its documentation for any purpose and without fee is hereby
4398 granted, provided that the above copyright notice appear in all
4399 copies and that both that the copyright notice and this
4400 permission notice and warranty disclaimer appear in supporting
4401 documentation, and that the names of AT&T Bell Laboratories or
4402 Bellcore or any of their entities not be used in advertising or
4403 publicity pertaining to distribution of the software without
4404 specific, written prior permission.
4406 AT&T and Bellcore disclaim all warranties with regard to this
4407 software, including all implied warranties of merchantability
4408 and fitness. In no event shall AT&T or Bellcore be liable for
4409 any special, indirect or consequential damages or any damages
4410 whatsoever resulting from loss of use, data or profits, whether
4411 in an action of contract, negligence or other tortious action,
4412 arising out of or in connection with the use or performance of
4414 ****************************************************************/
4416 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
4417 /* Divide the first argument by the product of the remaining
4418 arguments. If called with one argument @var{z1}, 1/@var{z1} is
4420 #define FUNC_NAME s_divide
4422 scm_i_divide (SCM x
, SCM y
, int inexact
)
4429 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
4430 else if (SCM_INUMP (x
))
4432 long xx
= SCM_INUM (x
);
4433 if (xx
== 1 || xx
== -1)
4435 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4437 scm_num_overflow (s_divide
);
4442 return scm_make_real (1.0 / (double) xx
);
4443 else return scm_make_ratio (SCM_MAKINUM(1), x
);
4446 else if (SCM_BIGP (x
))
4449 return scm_make_real (1.0 / scm_i_big2dbl (x
));
4450 else return scm_make_ratio (SCM_MAKINUM(1), x
);
4452 else if (SCM_REALP (x
))
4454 double xx
= SCM_REAL_VALUE (x
);
4455 #ifndef ALLOW_DIVIDE_BY_ZERO
4457 scm_num_overflow (s_divide
);
4460 return scm_make_real (1.0 / xx
);
4462 else if (SCM_COMPLEXP (x
))
4464 double r
= SCM_COMPLEX_REAL (x
);
4465 double i
= SCM_COMPLEX_IMAG (x
);
4469 double d
= i
* (1.0 + t
* t
);
4470 return scm_make_complex (t
/ d
, -1.0 / d
);
4475 double d
= r
* (1.0 + t
* t
);
4476 return scm_make_complex (1.0 / d
, -t
/ d
);
4479 else if (SCM_FRACTIONP (x
))
4480 return scm_make_ratio (SCM_FRACTION_DENOMINATOR (x
),
4481 SCM_FRACTION_NUMERATOR (x
));
4483 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
4488 long xx
= SCM_INUM (x
);
4491 long yy
= SCM_INUM (y
);
4494 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4495 scm_num_overflow (s_divide
);
4497 return scm_make_real ((double) xx
/ (double) yy
);
4500 else if (xx
% yy
!= 0)
4503 return scm_make_real ((double) xx
/ (double) yy
);
4504 else return scm_make_ratio (x
, y
);
4509 if (SCM_FIXABLE (z
))
4510 return SCM_MAKINUM (z
);
4512 return scm_i_long2big (z
);
4515 else if (SCM_BIGP (y
))
4518 return scm_make_real ((double) xx
/ scm_i_big2dbl (y
));
4519 else return scm_make_ratio (x
, y
);
4521 else if (SCM_REALP (y
))
4523 double yy
= SCM_REAL_VALUE (y
);
4524 #ifndef ALLOW_DIVIDE_BY_ZERO
4526 scm_num_overflow (s_divide
);
4529 return scm_make_real ((double) xx
/ yy
);
4531 else if (SCM_COMPLEXP (y
))
4534 complex_div
: /* y _must_ be a complex number */
4536 double r
= SCM_COMPLEX_REAL (y
);
4537 double i
= SCM_COMPLEX_IMAG (y
);
4541 double d
= i
* (1.0 + t
* t
);
4542 return scm_make_complex ((a
* t
) / d
, -a
/ d
);
4547 double d
= r
* (1.0 + t
* t
);
4548 return scm_make_complex (a
/ d
, -(a
* t
) / d
);
4552 else if (SCM_FRACTIONP (y
))
4553 /* a / b/c = ac / b */
4554 return scm_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4555 SCM_FRACTION_NUMERATOR (y
));
4557 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4559 else if (SCM_BIGP (x
))
4563 long int yy
= SCM_INUM (y
);
4566 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4567 scm_num_overflow (s_divide
);
4569 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4570 scm_remember_upto_here_1 (x
);
4571 return (sgn
== 0) ? scm_nan () : scm_inf ();
4578 /* FIXME: HMM, what are the relative performance issues here?
4579 We need to test. Is it faster on average to test
4580 divisible_p, then perform whichever operation, or is it
4581 faster to perform the integer div opportunistically and
4582 switch to real if there's a remainder? For now we take the
4583 middle ground: test, then if divisible, use the faster div
4586 long abs_yy
= yy
< 0 ? -yy
: yy
;
4587 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
4591 SCM result
= scm_i_mkbig ();
4592 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
4593 scm_remember_upto_here_1 (x
);
4595 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
4596 return scm_i_normbig (result
);
4601 return scm_make_real (scm_i_big2dbl (x
) / (double) yy
);
4602 else return scm_make_ratio (x
, y
);
4606 else if (SCM_BIGP (y
))
4608 int y_is_zero
= (mpz_sgn (SCM_I_BIG_MPZ (y
)) == 0);
4611 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4612 scm_num_overflow (s_divide
);
4614 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
4615 scm_remember_upto_here_1 (x
);
4616 return (sgn
== 0) ? scm_nan () : scm_inf ();
4622 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
4626 SCM result
= scm_i_mkbig ();
4627 mpz_divexact (SCM_I_BIG_MPZ (result
),
4630 scm_remember_upto_here_2 (x
, y
);
4631 return scm_i_normbig (result
);
4637 double dbx
= mpz_get_d (SCM_I_BIG_MPZ (x
));
4638 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4639 scm_remember_upto_here_2 (x
, y
);
4640 return scm_make_real (dbx
/ dby
);
4642 else return scm_make_ratio (x
, y
);
4646 else if (SCM_REALP (y
))
4648 double yy
= SCM_REAL_VALUE (y
);
4649 #ifndef ALLOW_DIVIDE_BY_ZERO
4651 scm_num_overflow (s_divide
);
4654 return scm_make_real (scm_i_big2dbl (x
) / yy
);
4656 else if (SCM_COMPLEXP (y
))
4658 a
= scm_i_big2dbl (x
);
4661 else if (SCM_FRACTIONP (y
))
4662 return scm_make_ratio (scm_product (x
, SCM_FRACTION_DENOMINATOR (y
)),
4663 SCM_FRACTION_NUMERATOR (y
));
4665 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4667 else if (SCM_REALP (x
))
4669 double rx
= SCM_REAL_VALUE (x
);
4672 long int yy
= SCM_INUM (y
);
4673 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4675 scm_num_overflow (s_divide
);
4678 return scm_make_real (rx
/ (double) yy
);
4680 else if (SCM_BIGP (y
))
4682 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4683 scm_remember_upto_here_1 (y
);
4684 return scm_make_real (rx
/ dby
);
4686 else if (SCM_REALP (y
))
4688 double yy
= SCM_REAL_VALUE (y
);
4689 #ifndef ALLOW_DIVIDE_BY_ZERO
4691 scm_num_overflow (s_divide
);
4694 return scm_make_real (rx
/ yy
);
4696 else if (SCM_COMPLEXP (y
))
4701 else if (SCM_FRACTIONP (y
))
4702 return scm_make_real (rx
/ scm_i_fraction2double (y
));
4704 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4706 else if (SCM_COMPLEXP (x
))
4708 double rx
= SCM_COMPLEX_REAL (x
);
4709 double ix
= SCM_COMPLEX_IMAG (x
);
4712 long int yy
= SCM_INUM (y
);
4713 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4715 scm_num_overflow (s_divide
);
4720 return scm_make_complex (rx
/ d
, ix
/ d
);
4723 else if (SCM_BIGP (y
))
4725 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
4726 scm_remember_upto_here_1 (y
);
4727 return scm_make_complex (rx
/ dby
, ix
/ dby
);
4729 else if (SCM_REALP (y
))
4731 double yy
= SCM_REAL_VALUE (y
);
4732 #ifndef ALLOW_DIVIDE_BY_ZERO
4734 scm_num_overflow (s_divide
);
4737 return scm_make_complex (rx
/ yy
, ix
/ yy
);
4739 else if (SCM_COMPLEXP (y
))
4741 double ry
= SCM_COMPLEX_REAL (y
);
4742 double iy
= SCM_COMPLEX_IMAG (y
);
4746 double d
= iy
* (1.0 + t
* t
);
4747 return scm_make_complex ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
4752 double d
= ry
* (1.0 + t
* t
);
4753 return scm_make_complex ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
4756 else if (SCM_FRACTIONP (y
))
4758 double yy
= scm_i_fraction2double (y
);
4759 return scm_make_complex (rx
/ yy
, ix
/ yy
);
4762 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4764 else if (SCM_FRACTIONP (x
))
4768 long int yy
= SCM_INUM (y
);
4769 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4771 scm_num_overflow (s_divide
);
4774 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x
),
4775 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
4777 else if (SCM_BIGP (y
))
4779 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x
),
4780 scm_product (SCM_FRACTION_DENOMINATOR (x
), y
));
4782 else if (SCM_REALP (y
))
4784 double yy
= SCM_REAL_VALUE (y
);
4785 #ifndef ALLOW_DIVIDE_BY_ZERO
4787 scm_num_overflow (s_divide
);
4790 return scm_make_real (scm_i_fraction2double (x
) / yy
);
4792 else if (SCM_COMPLEXP (y
))
4794 a
= scm_i_fraction2double (x
);
4797 else if (SCM_FRACTIONP (y
))
4798 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x
), SCM_FRACTION_DENOMINATOR (y
)),
4799 scm_product (SCM_FRACTION_NUMERATOR (y
), SCM_FRACTION_DENOMINATOR (x
)));
4801 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4804 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
4808 scm_divide (SCM x
, SCM y
)
4810 return scm_i_divide (x
, y
, 0);
4813 static SCM
scm_divide2real (SCM x
, SCM y
)
4815 return scm_i_divide (x
, y
, 1);
4821 scm_asinh (double x
)
4826 #define asinh scm_asinh
4827 return log (x
+ sqrt (x
* x
+ 1));
4830 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_dsubr
, (SCM (*)()) asinh
, g_asinh
);
4831 /* "Return the inverse hyperbolic sine of @var{x}."
4836 scm_acosh (double x
)
4841 #define acosh scm_acosh
4842 return log (x
+ sqrt (x
* x
- 1));
4845 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_dsubr
, (SCM (*)()) acosh
, g_acosh
);
4846 /* "Return the inverse hyperbolic cosine of @var{x}."
4851 scm_atanh (double x
)
4856 #define atanh scm_atanh
4857 return 0.5 * log ((1 + x
) / (1 - x
));
4860 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_dsubr
, (SCM (*)()) atanh
, g_atanh
);
4861 /* "Return the inverse hyperbolic tangent of @var{x}."
4865 /* XXX - eventually, we should remove this definition of scm_round and
4866 rename scm_round_number to scm_round. Likewise for scm_truncate
4867 and scm_truncate_number.
4871 scm_truncate (double x
)
4876 #define trunc scm_truncate
4883 /* scm_round is done using floor(x+0.5) to round to nearest and with
4884 half-way case (ie. when x is an integer plus 0.5) going upwards. Then
4885 half-way cases are identified and adjusted down if the round-upwards
4886 didn't give the desired even integer.
4888 "plus_half == result" identifies a half-way case. If plus_half, which is
4889 x + 0.5, is an integer then x must be an integer plus 0.5.
4891 An odd "result" value is identified with result/2 != floor(result/2).
4892 This is done with plus_half, since that value is ready for use sooner in
4893 a pipelined cpu, and we're already requiring plus_half == result.
4895 Note however that we need to be careful when x is big and already an
4896 integer. In that case "x+0.5" may round to an adjacent integer, causing
4897 us to return such a value, incorrectly. For instance if the hardware is
4898 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
4899 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
4900 returned. Or if the hardware is in round-upwards mode, then other bigger
4901 values like say x == 2^128 will see x+0.5 rounding up to the next higher
4902 representable value, 2^128+2^76 (or whatever), again incorrect.
4904 These bad roundings of x+0.5 are avoided by testing at the start whether
4905 x is already an integer. If it is then clearly that's the desired result
4906 already. And if it's not then the exponent must be small enough to allow
4907 an 0.5 to be represented, and hence added without a bad rounding. */
4910 scm_round (double x
)
4912 double plus_half
, result
;
4917 plus_half
= x
+ 0.5;
4918 result
= floor (plus_half
);
4919 /* Adjust so that the scm_round is towards even. */
4920 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
4925 SCM_DEFINE (scm_truncate_number
, "truncate", 1, 0, 0,
4927 "Round the number @var{x} towards zero.")
4928 #define FUNC_NAME s_scm_truncate_number
4930 if (SCM_FALSEP (scm_negative_p (x
)))
4931 return scm_floor (x
);
4933 return scm_ceiling (x
);
4937 static SCM exactly_one_half
;
4939 SCM_DEFINE (scm_round_number
, "round", 1, 0, 0,
4941 "Round the number @var{x} towards the nearest integer. "
4942 "When it is exactly halfway between two integers, "
4943 "round towards the even one.")
4944 #define FUNC_NAME s_scm_round_number
4946 SCM plus_half
= scm_sum (x
, exactly_one_half
);
4947 SCM result
= scm_floor (plus_half
);
4948 /* Adjust so that the scm_round is towards even. */
4949 if (!SCM_FALSEP (scm_num_eq_p (plus_half
, result
))
4950 && !SCM_FALSEP (scm_odd_p (result
)))
4951 return scm_difference (result
, SCM_MAKINUM (1));
4957 SCM_PRIMITIVE_GENERIC (scm_floor
, "floor", 1, 0, 0,
4959 "Round the number @var{x} towards minus infinity.")
4960 #define FUNC_NAME s_scm_floor
4962 if (SCM_INUMP (x
) || SCM_BIGP (x
))
4964 else if (SCM_REALP (x
))
4965 return scm_make_real (floor (SCM_REAL_VALUE (x
)));
4966 else if (SCM_FRACTIONP (x
))
4968 SCM q
= scm_quotient (SCM_FRACTION_NUMERATOR (x
),
4969 SCM_FRACTION_DENOMINATOR (x
));
4970 if (SCM_FALSEP (scm_negative_p (x
)))
4972 /* For positive x, rounding towards zero is correct. */
4977 /* For negative x, we need to return q-1 unless x is an
4978 integer. But fractions are never integer, per our
4980 return scm_difference (q
, SCM_MAKINUM (1));
4984 SCM_WTA_DISPATCH_1 (g_scm_floor
, x
, 1, s_scm_floor
);
4988 SCM_PRIMITIVE_GENERIC (scm_ceiling
, "ceiling", 1, 0, 0,
4990 "Round the number @var{x} towards infinity.")
4991 #define FUNC_NAME s_scm_ceiling
4993 if (SCM_INUMP (x
) || SCM_BIGP (x
))
4995 else if (SCM_REALP (x
))
4996 return scm_make_real (ceil (SCM_REAL_VALUE (x
)));
4997 else if (SCM_FRACTIONP (x
))
4999 SCM q
= scm_quotient (SCM_FRACTION_NUMERATOR (x
),
5000 SCM_FRACTION_DENOMINATOR (x
));
5001 if (SCM_FALSEP (scm_positive_p (x
)))
5003 /* For negative x, rounding towards zero is correct. */
5008 /* For positive x, we need to return q+1 unless x is an
5009 integer. But fractions are never integer, per our
5011 return scm_sum (q
, SCM_MAKINUM (1));
5015 SCM_WTA_DISPATCH_1 (g_scm_ceiling
, x
, 1, s_scm_ceiling
);
5019 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_dsubr
, (SCM (*)()) sqrt
, g_i_sqrt
);
5020 /* "Return the square root of the real number @var{x}."
5022 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_dsubr
, (SCM (*)()) fabs
, g_i_abs
);
5023 /* "Return the absolute value of the real number @var{x}."
5025 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_dsubr
, (SCM (*)()) exp
, g_i_exp
);
5026 /* "Return the @var{x}th power of e."
5028 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_dsubr
, (SCM (*)()) log
, g_i_log
);
5029 /* "Return the natural logarithm of the real number @var{x}."
5031 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_dsubr
, (SCM (*)()) sin
, g_i_sin
);
5032 /* "Return the sine of the real number @var{x}."
5034 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_dsubr
, (SCM (*)()) cos
, g_i_cos
);
5035 /* "Return the cosine of the real number @var{x}."
5037 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_dsubr
, (SCM (*)()) tan
, g_i_tan
);
5038 /* "Return the tangent of the real number @var{x}."
5040 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_dsubr
, (SCM (*)()) asin
, g_i_asin
);
5041 /* "Return the arc sine of the real number @var{x}."
5043 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_dsubr
, (SCM (*)()) acos
, g_i_acos
);
5044 /* "Return the arc cosine of the real number @var{x}."
5046 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_dsubr
, (SCM (*)()) atan
, g_i_atan
);
5047 /* "Return the arc tangent of the real number @var{x}."
5049 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_dsubr
, (SCM (*)()) sinh
, g_i_sinh
);
5050 /* "Return the hyperbolic sine of the real number @var{x}."
5052 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_dsubr
, (SCM (*)()) cosh
, g_i_cosh
);
5053 /* "Return the hyperbolic cosine of the real number @var{x}."
5055 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_dsubr
, (SCM (*)()) tanh
, g_i_tanh
);
5056 /* "Return the hyperbolic tangent of the real number @var{x}."
5064 static void scm_two_doubles (SCM x
,
5066 const char *sstring
,
5070 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
5073 xy
->x
= SCM_INUM (x
);
5074 else if (SCM_BIGP (x
))
5075 xy
->x
= scm_i_big2dbl (x
);
5076 else if (SCM_REALP (x
))
5077 xy
->x
= SCM_REAL_VALUE (x
);
5078 else if (SCM_FRACTIONP (x
))
5079 xy
->x
= scm_i_fraction2double (x
);
5081 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
5084 xy
->y
= SCM_INUM (y
);
5085 else if (SCM_BIGP (y
))
5086 xy
->y
= scm_i_big2dbl (y
);
5087 else if (SCM_REALP (y
))
5088 xy
->y
= SCM_REAL_VALUE (y
);
5089 else if (SCM_FRACTIONP (y
))
5090 xy
->y
= scm_i_fraction2double (y
);
5092 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
5096 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
5098 "Return @var{x} raised to the power of @var{y}. This\n"
5099 "procedure does not accept complex arguments.")
5100 #define FUNC_NAME s_scm_sys_expt
5103 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
5104 return scm_make_real (pow (xy
.x
, xy
.y
));
5109 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
5111 "Return the arc tangent of the two arguments @var{x} and\n"
5112 "@var{y}. This is similar to calculating the arc tangent of\n"
5113 "@var{x} / @var{y}, except that the signs of both arguments\n"
5114 "are used to determine the quadrant of the result. This\n"
5115 "procedure does not accept complex arguments.")
5116 #define FUNC_NAME s_scm_sys_atan2
5119 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
5120 return scm_make_real (atan2 (xy
.x
, xy
.y
));
5125 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
5126 (SCM real
, SCM imaginary
),
5127 "Return a complex number constructed of the given @var{real} and\n"
5128 "@var{imaginary} parts.")
5129 #define FUNC_NAME s_scm_make_rectangular
5132 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
5133 return scm_make_complex (xy
.x
, xy
.y
);
5139 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
5141 "Return the complex number @var{x} * e^(i * @var{y}).")
5142 #define FUNC_NAME s_scm_make_polar
5146 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
5148 sincos (xy
.y
, &s
, &c
);
5153 return scm_make_complex (xy
.x
* c
, xy
.x
* s
);
5158 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
5159 /* "Return the real part of the number @var{z}."
5162 scm_real_part (SCM z
)
5166 else if (SCM_BIGP (z
))
5168 else if (SCM_REALP (z
))
5170 else if (SCM_COMPLEXP (z
))
5171 return scm_make_real (SCM_COMPLEX_REAL (z
));
5172 else if (SCM_FRACTIONP (z
))
5175 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
5179 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
5180 /* "Return the imaginary part of the number @var{z}."
5183 scm_imag_part (SCM z
)
5187 else if (SCM_BIGP (z
))
5189 else if (SCM_REALP (z
))
5191 else if (SCM_COMPLEXP (z
))
5192 return scm_make_real (SCM_COMPLEX_IMAG (z
));
5193 else if (SCM_FRACTIONP (z
))
5196 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
5199 SCM_GPROC (s_numerator
, "numerator", 1, 0, 0, scm_numerator
, g_numerator
);
5200 /* "Return the numerator of the number @var{z}."
5203 scm_numerator (SCM z
)
5207 else if (SCM_BIGP (z
))
5209 else if (SCM_FRACTIONP (z
))
5211 scm_i_fraction_reduce (z
);
5212 return SCM_FRACTION_NUMERATOR (z
);
5214 else if (SCM_REALP (z
))
5215 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z
)));
5217 SCM_WTA_DISPATCH_1 (g_numerator
, z
, SCM_ARG1
, s_numerator
);
5221 SCM_GPROC (s_denominator
, "denominator", 1, 0, 0, scm_denominator
, g_denominator
);
5222 /* "Return the denominator of the number @var{z}."
5225 scm_denominator (SCM z
)
5228 return SCM_MAKINUM (1);
5229 else if (SCM_BIGP (z
))
5230 return SCM_MAKINUM (1);
5231 else if (SCM_FRACTIONP (z
))
5233 scm_i_fraction_reduce (z
);
5234 return SCM_FRACTION_DENOMINATOR (z
);
5236 else if (SCM_REALP (z
))
5237 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z
)));
5239 SCM_WTA_DISPATCH_1 (g_denominator
, z
, SCM_ARG1
, s_denominator
);
5242 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
5243 /* "Return the magnitude of the number @var{z}. This is the same as\n"
5244 * "@code{abs} for real arguments, but also allows complex numbers."
5247 scm_magnitude (SCM z
)
5251 long int zz
= SCM_INUM (z
);
5254 else if (SCM_POSFIXABLE (-zz
))
5255 return SCM_MAKINUM (-zz
);
5257 return scm_i_long2big (-zz
);
5259 else if (SCM_BIGP (z
))
5261 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
5262 scm_remember_upto_here_1 (z
);
5264 return scm_i_clonebig (z
, 0);
5268 else if (SCM_REALP (z
))
5269 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
5270 else if (SCM_COMPLEXP (z
))
5271 return scm_make_real (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
5272 else if (SCM_FRACTIONP (z
))
5274 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
5276 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z
), SCM_UNDEFINED
),
5277 SCM_FRACTION_DENOMINATOR (z
));
5280 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
5284 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
5285 /* "Return the angle of the complex number @var{z}."
5290 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
5291 scm_flo0 to save allocating a new flonum with scm_make_real each time.
5292 But if atan2 follows the floating point rounding mode, then the value
5293 is not a constant. Maybe it'd be close enough though. */
5296 if (SCM_INUM (z
) >= 0)
5299 return scm_make_real (atan2 (0.0, -1.0));
5301 else if (SCM_BIGP (z
))
5303 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
5304 scm_remember_upto_here_1 (z
);
5306 return scm_make_real (atan2 (0.0, -1.0));
5310 else if (SCM_REALP (z
))
5312 if (SCM_REAL_VALUE (z
) >= 0)
5315 return scm_make_real (atan2 (0.0, -1.0));
5317 else if (SCM_COMPLEXP (z
))
5318 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
5319 else if (SCM_FRACTIONP (z
))
5321 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z
))))
5323 else return scm_make_real (atan2 (0.0, -1.0));
5326 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
5330 SCM_GPROC (s_exact_to_inexact
, "exact->inexact", 1, 0, 0, scm_exact_to_inexact
, g_exact_to_inexact
);
5331 /* Convert the number @var{x} to its inexact representation.\n"
5334 scm_exact_to_inexact (SCM z
)
5337 return scm_make_real ((double) SCM_INUM (z
));
5338 else if (SCM_BIGP (z
))
5339 return scm_make_real (scm_i_big2dbl (z
));
5340 else if (SCM_FRACTIONP (z
))
5341 return scm_make_real (scm_i_fraction2double (z
));
5342 else if (SCM_INEXACTP (z
))
5345 SCM_WTA_DISPATCH_1 (g_exact_to_inexact
, z
, 1, s_exact_to_inexact
);
5349 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
5351 "Return an exact number that is numerically closest to @var{z}.")
5352 #define FUNC_NAME s_scm_inexact_to_exact
5356 else if (SCM_BIGP (z
))
5358 else if (SCM_REALP (z
))
5360 if (xisinf (SCM_REAL_VALUE (z
)) || xisnan (SCM_REAL_VALUE (z
)))
5361 SCM_OUT_OF_RANGE (1, z
);
5368 mpq_set_d (frac
, SCM_REAL_VALUE (z
));
5369 q
= scm_make_ratio (scm_i_mpz2num (mpq_numref (frac
)),
5370 scm_i_mpz2num (mpq_denref (frac
)));
5372 /* When scm_make_ratio throws, we leak the memory allocated
5379 else if (SCM_FRACTIONP (z
))
5382 SCM_WRONG_TYPE_ARG (1, z
);
5386 SCM_DEFINE (scm_rationalize
, "rationalize", 2, 0, 0,
5388 "Return an exact number that is within @var{err} of @var{x}.")
5389 #define FUNC_NAME s_scm_rationalize
5393 else if (SCM_BIGP (x
))
5395 else if ((SCM_REALP (x
)) || SCM_FRACTIONP (x
))
5397 /* Use continued fractions to find closest ratio. All
5398 arithmetic is done with exact numbers.
5401 SCM ex
= scm_inexact_to_exact (x
);
5402 SCM int_part
= scm_floor (ex
);
5403 SCM tt
= SCM_MAKINUM (1);
5404 SCM a1
= SCM_MAKINUM (0), a2
= SCM_MAKINUM (1), a
= SCM_MAKINUM (0);
5405 SCM b1
= SCM_MAKINUM (1), b2
= SCM_MAKINUM (0), b
= SCM_MAKINUM (0);
5409 if (!SCM_FALSEP (scm_num_eq_p (ex
, int_part
)))
5412 ex
= scm_difference (ex
, int_part
); /* x = x-int_part */
5413 rx
= scm_divide (ex
, SCM_UNDEFINED
); /* rx = 1/x */
5415 /* We stop after a million iterations just to be absolutely sure
5416 that we don't go into an infinite loop. The process normally
5417 converges after less than a dozen iterations.
5420 err
= scm_abs (err
);
5421 while (++i
< 1000000)
5423 a
= scm_sum (scm_product (a1
, tt
), a2
); /* a = a1*tt + a2 */
5424 b
= scm_sum (scm_product (b1
, tt
), b2
); /* b = b1*tt + b2 */
5425 if (SCM_FALSEP (scm_zero_p (b
)) && /* b != 0 */
5427 (scm_gr_p (scm_abs (scm_difference (ex
, scm_divide (a
, b
))),
5428 err
))) /* abs(x-a/b) <= err */
5430 SCM res
= scm_sum (int_part
, scm_divide (a
, b
));
5431 if (SCM_FALSEP (scm_exact_p (x
))
5432 || SCM_FALSEP (scm_exact_p (err
)))
5433 return scm_exact_to_inexact (res
);
5437 rx
= scm_divide (scm_difference (rx
, tt
), /* rx = 1/(rx - tt) */
5439 tt
= scm_floor (rx
); /* tt = floor (rx) */
5445 scm_num_overflow (s_scm_rationalize
);
5448 SCM_WRONG_TYPE_ARG (1, x
);
5452 /* if you need to change this, change test-num2integral.c as well */
5453 #if SCM_SIZEOF_LONG_LONG != 0
5455 # define ULLONG_MAX ((unsigned long long) (-1))
5456 # define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
5457 # define LLONG_MIN (~LLONG_MAX)
5461 /* Parameters for creating integer conversion routines.
5463 Define the following preprocessor macros before including
5464 "libguile/num2integral.i.c":
5466 NUM2INTEGRAL - the name of the function for converting from a
5467 Scheme object to the integral type. This function will be
5468 defined when including "num2integral.i.c".
5470 INTEGRAL2NUM - the name of the function for converting from the
5471 integral type to a Scheme object. This function will be defined.
5473 INTEGRAL2BIG - the name of an internal function that createas a
5474 bignum from the integral type. This function will be defined.
5475 The name should start with "scm_i_".
5477 ITYPE - the name of the integral type.
5479 UNSIGNED - Define this to 1 when ITYPE is an unsigned type. Define
5482 UNSIGNED_ITYPE - the name of the the unsigned variant of the
5483 integral type. If you don't define this, it defaults to
5484 "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned
5487 SIZEOF_ITYPE - an expression giving the size of the integral type
5488 in bytes. This expression must be computable by the
5489 preprocessor. (SIZEOF_FOO values are calculated by configure.in
5494 #define NUM2INTEGRAL scm_num2short
5495 #define INTEGRAL2NUM scm_short2num
5496 #define INTEGRAL2BIG scm_i_short2big
5499 #define SIZEOF_ITYPE SIZEOF_SHORT
5500 #include "libguile/num2integral.i.c"
5502 #define NUM2INTEGRAL scm_num2ushort
5503 #define INTEGRAL2NUM scm_ushort2num
5504 #define INTEGRAL2BIG scm_i_ushort2big
5506 #define ITYPE unsigned short
5507 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT
5508 #include "libguile/num2integral.i.c"
5510 #define NUM2INTEGRAL scm_num2int
5511 #define INTEGRAL2NUM scm_int2num
5512 #define INTEGRAL2BIG scm_i_int2big
5515 #define SIZEOF_ITYPE SIZEOF_INT
5516 #include "libguile/num2integral.i.c"
5518 #define NUM2INTEGRAL scm_num2uint
5519 #define INTEGRAL2NUM scm_uint2num
5520 #define INTEGRAL2BIG scm_i_uint2big
5522 #define ITYPE unsigned int
5523 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT
5524 #include "libguile/num2integral.i.c"
5526 #define NUM2INTEGRAL scm_num2long
5527 #define INTEGRAL2NUM scm_long2num
5528 #define INTEGRAL2BIG scm_i_long2big
5531 #define SIZEOF_ITYPE SIZEOF_LONG
5532 #include "libguile/num2integral.i.c"
5534 #define NUM2INTEGRAL scm_num2ulong
5535 #define INTEGRAL2NUM scm_ulong2num
5536 #define INTEGRAL2BIG scm_i_ulong2big
5538 #define ITYPE unsigned long
5539 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG
5540 #include "libguile/num2integral.i.c"
5542 #define NUM2INTEGRAL scm_num2ptrdiff
5543 #define INTEGRAL2NUM scm_ptrdiff2num
5544 #define INTEGRAL2BIG scm_i_ptrdiff2big
5546 #define ITYPE scm_t_ptrdiff
5547 #define UNSIGNED_ITYPE size_t
5548 #define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF
5549 #include "libguile/num2integral.i.c"
5551 #define NUM2INTEGRAL scm_num2size
5552 #define INTEGRAL2NUM scm_size2num
5553 #define INTEGRAL2BIG scm_i_size2big
5555 #define ITYPE size_t
5556 #define SIZEOF_ITYPE SIZEOF_SIZE_T
5557 #include "libguile/num2integral.i.c"
5559 #if SCM_SIZEOF_LONG_LONG != 0
5561 #ifndef ULONG_LONG_MAX
5562 #define ULONG_LONG_MAX (~0ULL)
5565 #define NUM2INTEGRAL scm_num2long_long
5566 #define INTEGRAL2NUM scm_long_long2num
5567 #define INTEGRAL2BIG scm_i_long_long2big
5569 #define ITYPE long long
5570 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
5571 #include "libguile/num2integral.i.c"
5573 #define NUM2INTEGRAL scm_num2ulong_long
5574 #define INTEGRAL2NUM scm_ulong_long2num
5575 #define INTEGRAL2BIG scm_i_ulong_long2big
5577 #define ITYPE unsigned long long
5578 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG
5579 #include "libguile/num2integral.i.c"
5581 #endif /* SCM_SIZEOF_LONG_LONG != 0 */
5583 #define NUM2FLOAT scm_num2float
5584 #define FLOAT2NUM scm_float2num
5586 #include "libguile/num2float.i.c"
5588 #define NUM2FLOAT scm_num2double
5589 #define FLOAT2NUM scm_double2num
5590 #define FTYPE double
5591 #include "libguile/num2float.i.c"
5596 #define SIZE_MAX ((size_t) (-1))
5599 #define PTRDIFF_MIN \
5600 ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 \
5601 << ((sizeof (scm_t_ptrdiff) * SCM_CHAR_BIT) - 1)))
5604 #define PTRDIFF_MAX (~ PTRDIFF_MIN)
5607 #define CHECK(type, v) \
5610 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
5630 CHECK (ptrdiff
, -1);
5632 CHECK (short, SHRT_MAX
);
5633 CHECK (short, SHRT_MIN
);
5634 CHECK (ushort
, USHRT_MAX
);
5635 CHECK (int, INT_MAX
);
5636 CHECK (int, INT_MIN
);
5637 CHECK (uint
, UINT_MAX
);
5638 CHECK (long, LONG_MAX
);
5639 CHECK (long, LONG_MIN
);
5640 CHECK (ulong
, ULONG_MAX
);
5641 CHECK (size
, SIZE_MAX
);
5642 CHECK (ptrdiff
, PTRDIFF_MAX
);
5643 CHECK (ptrdiff
, PTRDIFF_MIN
);
5645 #if SCM_SIZEOF_LONG_LONG != 0
5646 CHECK (long_long
, 0LL);
5647 CHECK (ulong_long
, 0ULL);
5648 CHECK (long_long
, -1LL);
5649 CHECK (long_long
, LLONG_MAX
);
5650 CHECK (long_long
, LLONG_MIN
);
5651 CHECK (ulong_long
, ULLONG_MAX
);
5658 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
5659 if (!SCM_FALSEP (data)) abort();
5662 check_body (void *data
)
5664 SCM num
= *(SCM
*) data
;
5665 scm_num2ulong (num
, 1, NULL
);
5667 return SCM_UNSPECIFIED
;
5671 check_handler (void *data
, SCM tag
, SCM throw_args
)
5673 SCM
*num
= (SCM
*) data
;
5676 return SCM_UNSPECIFIED
;
5679 SCM_DEFINE (scm_sys_check_number_conversions
, "%check-number-conversions", 0, 0, 0,
5681 "Number conversion sanity checking.")
5682 #define FUNC_NAME s_scm_sys_check_number_conversions
5684 SCM data
= SCM_MAKINUM (-1);
5686 data
= scm_int2num (INT_MIN
);
5688 data
= scm_ulong2num (ULONG_MAX
);
5689 data
= scm_difference (SCM_INUM0
, data
);
5691 data
= scm_ulong2num (ULONG_MAX
);
5692 data
= scm_sum (SCM_MAKINUM (1), data
); data
= scm_difference (SCM_INUM0
, data
);
5694 data
= scm_int2num (-10000); data
= scm_product (data
, data
); data
= scm_product (data
, data
);
5697 return SCM_UNSPECIFIED
;
5706 mpz_init_set_si (z_negative_one
, -1);
5708 /* It may be possible to tune the performance of some algorithms by using
5709 * the following constants to avoid the creation of bignums. Please, before
5710 * using these values, remember the two rules of program optimization:
5711 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
5712 scm_c_define ("most-positive-fixnum",
5713 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
5714 scm_c_define ("most-negative-fixnum",
5715 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
5717 scm_add_feature ("complex");
5718 scm_add_feature ("inexact");
5719 scm_flo0
= scm_make_real (0.0);
5721 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
5723 { /* determine floating point precision */
5725 double fsum
= 1.0 + f
;
5728 if (++scm_dblprec
> 20)
5736 scm_dblprec
= scm_dblprec
- 1;
5738 #endif /* DBL_DIG */
5744 exactly_one_half
= scm_permanent_object (scm_divide (SCM_MAKINUM (1),
5746 #include "libguile/numbers.x"