1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 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.
32 - see if special casing bignums and reals in integer-exponent when
33 possible (to use mpz_pow and mpf_pow_ui) is faster.
35 - look in to better short-circuiting of common cases in
36 integer-expt and elsewhere.
38 - see if direct mpz operations can help in ash and elsewhere.
50 #include "libguile/_scm.h"
51 #include "libguile/feature.h"
52 #include "libguile/ports.h"
53 #include "libguile/root.h"
54 #include "libguile/smob.h"
55 #include "libguile/strings.h"
57 #include "libguile/validate.h"
58 #include "libguile/numbers.h"
59 #include "libguile/deprecation.h"
64 Wonder if this might be faster for some of our code? A switch on
65 the numtag would jump directly to the right case, and the
66 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
68 #define SCM_I_NUMTAG_NOTNUM 0
69 #define SCM_I_NUMTAG_INUM 1
70 #define SCM_I_NUMTAG_BIG scm_tc16_big
71 #define SCM_I_NUMTAG_REAL scm_tc16_real
72 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
73 #define SCM_I_NUMTAG(x) \
74 (SCM_INUMP(x) ? SCM_I_NUMTAG_INUM \
75 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
76 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_smob) ? SCM_TYP16(x) \
77 : SCM_I_NUMTAG_NOTNUM)))
81 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
83 /* FLOBUFLEN is the maximum number of characters neccessary for the
84 * printed or scm_string representation of an inexact number.
86 #define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
89 #if ! defined (HAVE_ISNAN)
94 return (IsNANorINF (x
) && NaN (x
) && ! IsINF (x
)) ? 1 : 0;
97 #if ! defined (HAVE_ISINF)
102 return (IsNANorINF (x
) && IsINF (x
)) ? 1 : 0;
110 static SCM abs_most_negative_fixnum
;
114 static const char s_bignum
[] = "bignum";
119 /* Return a newly created bignum. */
120 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
121 mpz_init (SCM_I_BIG_MPZ (z
));
125 SCM_C_INLINE
static SCM
126 scm_i_clonebig (SCM src_big
, int same_sign_p
)
128 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
129 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
130 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
131 if (!same_sign_p
) mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
136 scm_i_bigcmp (SCM x
, SCM y
)
138 /* Return neg if x < y, pos if x > y, and 0 if x == y */
139 /* presume we already know x and y are bignums */
140 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
141 scm_remember_upto_here_2 (x
, y
);
146 scm_i_dbl2big (double d
)
148 /* results are only defined if d is an integer */
149 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
150 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
155 scm_i_big2dbl (SCM b
)
157 double result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
158 scm_remember_upto_here_1 (b
);
163 scm_i_normbig (SCM b
)
165 /* convert a big back to a fixnum if it'll fit */
166 /* presume b is a bignum */
167 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
169 long val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
170 if (SCM_FIXABLE (val
))
171 b
= SCM_MAKINUM (val
);
176 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
178 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
180 #define FUNC_NAME s_scm_exact_p
182 if (SCM_INUMP (x
)) return SCM_BOOL_T
;
183 if (SCM_BIGP (x
)) return SCM_BOOL_T
;
189 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
191 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
193 #define FUNC_NAME s_scm_odd_p
196 long val
= SCM_INUM (n
);
197 return SCM_BOOL ((val
& 1L) != 0);
198 } else if (SCM_BIGP (n
)) {
199 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
200 scm_remember_upto_here_1 (n
);
201 return SCM_BOOL (odd_p
);
202 } else if (scm_inf_p (n
)) {
205 SCM_WRONG_TYPE_ARG (1, n
);
211 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
213 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
215 #define FUNC_NAME s_scm_even_p
218 long val
= SCM_INUM (n
);
219 return SCM_BOOL ((val
& 1L) == 0);
220 } else if (SCM_BIGP (n
)) {
221 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
222 scm_remember_upto_here_1 (n
);
223 return SCM_BOOL (even_p
);
224 } else if (scm_inf_p (n
)) {
227 SCM_WRONG_TYPE_ARG (1, n
);
235 #if defined (HAVE_ISINF)
237 #elif defined (HAVE_FINITE) && defined (HAVE_ISNAN)
238 return (! (finite (x
) || isnan (x
)));
247 #if defined (HAVE_ISNAN)
254 #define isfinite(x) (! xisinf (x))
256 SCM_DEFINE (scm_inf_p
, "inf?", 1, 0, 0,
258 "Return @code{#t} if @var{n} is infinite, @code{#f}\n"
260 #define FUNC_NAME s_scm_inf_p
263 return SCM_BOOL (xisinf (SCM_REAL_VALUE (n
)));
264 } else if (SCM_COMPLEXP (n
)) {
265 return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n
))
266 || xisinf (SCM_COMPLEX_IMAG (n
)));
273 SCM_DEFINE (scm_nan_p
, "nan?", 1, 0, 0,
275 "Return @code{#t} if @var{n} is a NaN, @code{#f}\n"
277 #define FUNC_NAME s_scm_nan_p
280 return SCM_BOOL (xisnan (SCM_REAL_VALUE (n
)));
281 } else if (SCM_COMPLEXP (n
)) {
282 return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n
))
283 || xisnan (SCM_COMPLEX_IMAG (n
)));
290 /* Guile's idea of infinity. */
291 static double guile_Inf
;
293 /* Guile's idea of not a number. */
294 static double guile_NaN
;
297 guile_ieee_init (void)
299 #if defined (HAVE_ISINF) || defined (HAVE_FINITE)
301 /* Some version of gcc on some old version of Linux used to crash when
302 trying to make Inf and NaN. */
306 guile_Inf
= 1.0 / (tmp
- tmp
);
307 #elif defined (__alpha__) && ! defined (linux)
308 extern unsigned int DINFINITY
[2];
309 guile_Inf
= (*(X_CAST(double *, DINFINITY
)));
316 if (guile_Inf
== tmp
)
324 #if defined (HAVE_ISNAN)
326 #if defined (__alpha__) && ! defined (linux)
327 extern unsigned int DQNAN
[2];
328 guile_NaN
= (*(X_CAST(double *, DQNAN
)));
330 guile_NaN
= guile_Inf
/ guile_Inf
;
336 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
339 #define FUNC_NAME s_scm_inf
341 static int initialized
= 0;
347 return scm_make_real (guile_Inf
);
351 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
354 #define FUNC_NAME s_scm_nan
356 static int initialized
= 0;
362 return scm_make_real (guile_NaN
);
367 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
369 "Return the absolute value of @var{x}.")
373 long int xx
= SCM_INUM (x
);
376 } else if (SCM_POSFIXABLE (-xx
)) {
377 return SCM_MAKINUM (-xx
);
379 return scm_i_long2big (-xx
);
381 } else if (SCM_BIGP (x
)) {
382 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
384 return scm_i_clonebig (x
, 0);
388 } else if (SCM_REALP (x
)) {
389 return scm_make_real (fabs (SCM_REAL_VALUE (x
)));
391 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
397 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
398 /* "Return the quotient of the numbers @var{x} and @var{y}."
401 scm_quotient (SCM x
, SCM y
)
404 long xx
= SCM_INUM (x
);
406 long yy
= SCM_INUM (y
);
408 scm_num_overflow (s_quotient
);
411 if (SCM_FIXABLE (z
)) {
412 return SCM_MAKINUM (z
);
414 return scm_i_long2big (z
);
417 } else if (SCM_BIGP (y
)) {
418 if ((SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
)
419 && (scm_i_bigcmp (abs_most_negative_fixnum
, y
) == 0))
421 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
422 return SCM_MAKINUM (-1);
425 return SCM_MAKINUM (0);
427 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
429 } else if (SCM_BIGP (x
)) {
431 long yy
= SCM_INUM (y
);
433 scm_num_overflow (s_quotient
);
434 } else if (yy
== 1) {
437 SCM result
= scm_i_mkbig ();
439 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - yy
);
440 mpz_neg(SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
442 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
444 scm_remember_upto_here_1 (x
);
445 return scm_i_normbig (result
);
447 } else if (SCM_BIGP (y
)) {
448 SCM result
= scm_i_mkbig ();
449 mpz_tdiv_q(SCM_I_BIG_MPZ (result
),
452 scm_remember_upto_here_2 (x
, y
);
453 return scm_i_normbig (result
);
455 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
458 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
462 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
463 /* "Return the remainder of the numbers @var{x} and @var{y}.\n"
465 * "(remainder 13 4) @result{} 1\n"
466 * "(remainder -13 4) @result{} -1\n"
470 scm_remainder (SCM x
, SCM y
)
474 long yy
= SCM_INUM (y
);
476 scm_num_overflow (s_remainder
);
478 long z
= SCM_INUM (x
) % yy
;
479 return SCM_MAKINUM (z
);
481 } else if (SCM_BIGP (y
)) {
482 if ((SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
)
483 && (scm_i_bigcmp (abs_most_negative_fixnum
, y
) == 0))
485 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
486 return SCM_MAKINUM (0);
491 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
493 } else if (SCM_BIGP (x
)) {
495 long yy
= SCM_INUM (y
);
497 scm_num_overflow (s_remainder
);
499 SCM result
= scm_i_mkbig ();
500 if (yy
< 0) yy
= - yy
;
501 mpz_tdiv_r_ui(SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ(x
), yy
);
502 scm_remember_upto_here_1(x
);
503 return scm_i_normbig (result
);
505 } else if (SCM_BIGP (y
)) {
506 SCM result
= scm_i_mkbig ();
507 mpz_tdiv_r (SCM_I_BIG_MPZ (result
),
510 scm_remember_upto_here_2(x
, y
);
511 return scm_i_normbig (result
);
513 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
516 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
521 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
522 /* "Return the modulo of the numbers @var{x} and @var{y}.\n"
524 * "(modulo 13 4) @result{} 1\n"
525 * "(modulo -13 4) @result{} 3\n"
529 scm_modulo (SCM x
, SCM y
)
532 long xx
= SCM_INUM (x
);
534 long yy
= SCM_INUM (y
);
536 scm_num_overflow (s_modulo
);
538 /* FIXME: I think this may be a bug on some arches -- results
539 of % with negative second arg are undefined... */
544 if (z
> 0) result
= z
+ yy
;
547 if (z
< 0) result
= z
+ yy
;
550 return SCM_MAKINUM (result
);
552 } else if (SCM_BIGP (y
)) {
553 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
556 scm_num_overflow (s_modulo
);
562 SCM pos_y
= scm_i_clonebig (y
, 0);
563 /* do this after the last scm_op */
564 mpz_init_set_si (z_x
, xx
);
565 result
= pos_y
; /* re-use this bignum */
566 mpz_mod (SCM_I_BIG_MPZ (result
), z_x
, SCM_I_BIG_MPZ (pos_y
));
567 scm_remember_upto_here_1 (pos_y
);
569 result
= scm_i_mkbig ();
570 /* do this after the last scm_op */
571 mpz_init_set_si (z_x
, xx
);
572 mpz_mod (SCM_I_BIG_MPZ (result
), z_x
, SCM_I_BIG_MPZ (y
));
573 scm_remember_upto_here_1 (y
);
576 if ((sgn_y
< 0) && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0) {
577 mpz_add (SCM_I_BIG_MPZ (result
),
579 SCM_I_BIG_MPZ (result
));
581 scm_remember_upto_here_1 (y
);
582 /* and do this before the next one */
584 return scm_i_normbig (result
);
587 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
589 } else if (SCM_BIGP (x
)) {
591 long yy
= SCM_INUM (y
);
593 scm_num_overflow (s_modulo
);
595 SCM result
= scm_i_mkbig ();
596 mpz_mod_ui (SCM_I_BIG_MPZ (result
),
598 (yy
< 0) ? - yy
: yy
);
599 scm_remember_upto_here_1 (x
);
600 if ((yy
< 0) && (mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)) {
601 mpz_sub_ui (SCM_I_BIG_MPZ (result
),
602 SCM_I_BIG_MPZ (result
),
605 return scm_i_normbig (result
);
607 } else if (SCM_BIGP (y
)) {
608 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
610 scm_num_overflow (s_modulo
);
612 SCM result
= scm_i_mkbig ();
613 int y_sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
614 SCM pos_y
= scm_i_clonebig (y
, y_sgn
>= 0);
615 mpz_mod (SCM_I_BIG_MPZ (result
),
617 SCM_I_BIG_MPZ (pos_y
));
619 scm_remember_upto_here_1 (x
);
620 if ((y_sgn
< 0) && (mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)) {
621 mpz_add (SCM_I_BIG_MPZ (result
),
623 SCM_I_BIG_MPZ (result
));
625 scm_remember_upto_here_2 (y
, pos_y
);
626 return scm_i_normbig (result
);
629 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
632 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
636 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
637 /* "Return the greatest common divisor of all arguments.\n"
638 * "If called without arguments, 0 is returned."
641 scm_gcd (SCM x
, SCM y
)
644 return (SCM_UNBNDP (x
)) ? SCM_INUM0
: x
;
650 long xx
= SCM_INUM (x
);
651 long yy
= SCM_INUM (y
);
652 long u
= xx
< 0 ? -xx
: xx
;
653 long v
= yy
< 0 ? -yy
: yy
;
657 } else if (yy
== 0) {
662 /* Determine a common factor 2^k */
663 while (!(1 & (u
| v
)))
669 /* Now, any factor 2^n can be eliminated */
689 return SCM_POSFIXABLE (result
) \
690 ? SCM_MAKINUM (result
) : scm_i_long2big (result
);
692 else if (SCM_BIGP (y
))
694 SCM result
= scm_i_mkbig ();
695 SCM mx
= scm_i_mkbig ();
696 mpz_set_si(SCM_I_BIG_MPZ (mx
), SCM_INUM (x
));
697 scm_remember_upto_here_1 (x
);
698 mpz_gcd(SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (mx
), SCM_I_BIG_MPZ (y
));
699 scm_remember_upto_here_2(mx
, y
);
700 return scm_i_normbig (result
);
703 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
705 else if (SCM_BIGP (x
))
709 unsigned long result
;
710 long yy
= SCM_INUM (y
);
711 if (yy
< 0) yy
= -yy
;
712 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
713 scm_remember_upto_here_1 (x
);
714 return SCM_POSFIXABLE (result
) \
715 ? SCM_MAKINUM (result
) : scm_ulong2num (result
);
717 else if (SCM_BIGP (y
))
719 SCM result
= scm_i_mkbig ();
720 mpz_gcd(SCM_I_BIG_MPZ (result
),
723 scm_remember_upto_here_2(x
, y
);
724 return scm_i_normbig (result
);
727 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
730 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
733 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
734 /* "Return the least common multiple of the arguments.\n"
735 * "If called without arguments, 1 is returned."
738 scm_lcm (SCM n1
, SCM n2
)
743 return SCM_MAKINUM (1L);
744 n2
= SCM_MAKINUM (1L);
747 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
748 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
749 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
750 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
756 SCM d
= scm_gcd (n1
, n2
);
757 if (SCM_EQ_P (d
, SCM_INUM0
))
760 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
764 /* inum n1, big n2 */
767 SCM result
= scm_i_mkbig ();
768 long nn1
= SCM_INUM (n1
);
769 if (nn1
== 0) return SCM_INUM0
;
770 if (nn1
< 0) nn1
= - nn1
;
771 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
772 scm_remember_upto_here_1 (n2
);
787 SCM result
= scm_i_mkbig ();
788 mpz_lcm(SCM_I_BIG_MPZ (result
),
791 scm_remember_upto_here_2(n1
, n2
);
792 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
799 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
801 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
804 /* Emulating 2's complement bignums with sign magnitude arithmetic:
809 + + + x (map digit:logand X Y)
810 + - + x (map digit:logand X (lognot (+ -1 Y)))
811 - + + y (map digit:logand (lognot (+ -1 X)) Y)
812 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
817 + + + (map digit:logior X Y)
818 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
819 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
820 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
825 + + + (map digit:logxor X Y)
826 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
827 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
828 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
833 + + (any digit:logand X Y)
834 + - (any digit:logand X (lognot (+ -1 Y)))
835 - + (any digit:logand (lognot (+ -1 X)) Y)
840 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
842 "Return the bitwise AND of the integer arguments.\n\n"
844 "(logand) @result{} -1\n"
845 "(logand 7) @result{} 7\n"
846 "(logand #b111 #b011 #\b001) @result{} 1\n"
848 #define FUNC_NAME s_scm_logand
852 if (SCM_UNBNDP (n2
)) {
853 if (SCM_UNBNDP (n1
)) {
854 return SCM_MAKINUM (-1);
855 } else if (!SCM_NUMBERP (n1
)) {
856 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
857 } else if (SCM_NUMBERP (n1
)) {
860 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
864 if (SCM_INUMP (n1
)) {
866 if (SCM_INUMP (n2
)) {
867 long nn2
= SCM_INUM (n2
);
868 return SCM_MAKINUM (nn1
& nn2
);
869 } else if SCM_BIGP (n2
) {
871 if (n1
== 0) return SCM_INUM0
;
873 SCM result_z
= scm_i_mkbig ();
875 mpz_init_set_si (nn1_z
, nn1
);
876 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
877 scm_remember_upto_here_1 (n2
);
879 return scm_i_normbig (result_z
);
882 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
884 } else if (SCM_BIGP (n1
)) {
885 if (SCM_INUMP (n2
)) {
889 } else if (SCM_BIGP (n2
)) {
890 SCM result_z
= scm_i_mkbig ();
891 mpz_and (SCM_I_BIG_MPZ (result_z
),
894 scm_remember_upto_here_2 (n1
, n2
);
895 return scm_i_normbig (result_z
);
897 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
900 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
906 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
908 "Return the bitwise OR of the integer arguments.\n\n"
910 "(logior) @result{} 0\n"
911 "(logior 7) @result{} 7\n"
912 "(logior #b000 #b001 #b011) @result{} 3\n"
914 #define FUNC_NAME s_scm_logior
918 if (SCM_UNBNDP (n2
)) {
919 if (SCM_UNBNDP (n1
)) {
921 } else if (SCM_NUMBERP (n1
)) {
924 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
928 if (SCM_INUMP (n1
)) {
930 if (SCM_INUMP (n2
)) {
931 long nn2
= SCM_INUM (n2
);
932 return SCM_MAKINUM (nn1
| nn2
);
933 } else if (SCM_BIGP (n2
)) {
935 if (nn1
== 0) return n2
;
937 SCM result_z
= scm_i_mkbig ();
939 mpz_init_set_si (nn1_z
, nn1
);
940 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
941 scm_remember_upto_here_1 (n2
);
946 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
948 } else if (SCM_BIGP (n1
)) {
949 if (SCM_INUMP (n2
)) {
953 } else if (SCM_BIGP (n2
)) {
954 SCM result_z
= scm_i_mkbig ();
955 mpz_ior (SCM_I_BIG_MPZ (result_z
),
958 scm_remember_upto_here_2 (n1
, n2
);
961 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
964 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
970 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
972 "Return the bitwise XOR of the integer arguments. A bit is\n"
973 "set in the result if it is set in an odd number of arguments.\n"
975 "(logxor) @result{} 0\n"
976 "(logxor 7) @result{} 7\n"
977 "(logxor #b000 #b001 #b011) @result{} 2\n"
978 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
980 #define FUNC_NAME s_scm_logxor
984 if (SCM_UNBNDP (n2
)) {
985 if (SCM_UNBNDP (n1
)) {
987 } else if (SCM_NUMBERP (n1
)) {
990 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
994 if (SCM_INUMP (n1
)) {
996 if (SCM_INUMP (n2
)) {
997 long nn2
= SCM_INUM (n2
);
998 return SCM_MAKINUM (nn1
^ nn2
);
999 } else if (SCM_BIGP (n2
)) {
1002 SCM result_z
= scm_i_mkbig ();
1004 mpz_init_set_si (nn1_z
, nn1
);
1005 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
1006 scm_remember_upto_here_1 (n2
);
1008 return scm_i_normbig (result_z
);
1011 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1013 } else if (SCM_BIGP (n1
)) {
1014 if (SCM_INUMP (n2
)) {
1016 nn1
= SCM_INUM (n1
);
1018 } else if (SCM_BIGP (n2
)) {
1019 SCM result_z
= scm_i_mkbig ();
1020 mpz_xor (SCM_I_BIG_MPZ (result_z
),
1022 SCM_I_BIG_MPZ (n2
));
1023 scm_remember_upto_here_2 (n1
, n2
);
1024 return scm_i_normbig (result_z
);
1026 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1029 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1035 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
1038 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
1039 "(logtest #b0100 #b1011) @result{} #f\n"
1040 "(logtest #b0100 #b0111) @result{} #t\n"
1042 #define FUNC_NAME s_scm_logtest
1046 if (SCM_INUMP (j
)) {
1048 if (SCM_INUMP (k
)) {
1049 long nk
= SCM_INUM (k
);
1050 return SCM_BOOL (nj
& nk
);
1051 } else if (SCM_BIGP (k
)) {
1053 if (nj
== 0) return SCM_BOOL_F
;
1057 mpz_init_set_si (nj_z
, nj
);
1058 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
1059 scm_remember_upto_here_1 (k
);
1060 result
= SCM_BOOL (mpz_sgn (nj_z
) != 0);
1065 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1067 } else if (SCM_BIGP (j
)) {
1068 if (SCM_INUMP (k
)) {
1072 } else if (SCM_BIGP (k
)) {
1075 mpz_init (result_z
);
1079 scm_remember_upto_here_2 (j
, k
);
1080 result
= SCM_BOOL (mpz_sgn (result_z
) != 0);
1081 mpz_clear (result_z
);
1084 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1087 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
1093 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
1096 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1097 "(logbit? 0 #b1101) @result{} #t\n"
1098 "(logbit? 1 #b1101) @result{} #f\n"
1099 "(logbit? 2 #b1101) @result{} #t\n"
1100 "(logbit? 3 #b1101) @result{} #t\n"
1101 "(logbit? 4 #b1101) @result{} #f\n"
1103 #define FUNC_NAME s_scm_logbit_p
1105 unsigned long int iindex
;
1107 SCM_VALIDATE_INUM_MIN (SCM_ARG1
, index
, 0);
1108 iindex
= (unsigned long int) SCM_INUM (index
);
1110 if (SCM_INUMP (j
)) {
1111 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1112 } else if (SCM_BIGP (j
)) {
1113 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
1114 scm_remember_upto_here_1 (j
);
1115 return SCM_BOOL (val
);
1117 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1123 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1125 "Return the integer which is the 2s-complement of the integer\n"
1129 "(number->string (lognot #b10000000) 2)\n"
1130 " @result{} \"-10000001\"\n"
1131 "(number->string (lognot #b0) 2)\n"
1132 " @result{} \"-1\"\n"
1134 #define FUNC_NAME s_scm_lognot
1136 return scm_difference (SCM_MAKINUM (-1L), n
);
1140 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1142 "Return @var{n} raised to the non-negative integer exponent\n"
1146 "(integer-expt 2 5)\n"
1148 "(integer-expt -3 3)\n"
1151 #define FUNC_NAME s_scm_integer_expt
1154 SCM z_i2
= SCM_BOOL_F
;
1156 SCM acc
= SCM_MAKINUM (1L);
1158 /* 0^0 == 1 according to R5RS */
1159 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1160 return SCM_FALSEP (scm_zero_p(k
)) ? n
: acc
;
1161 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1162 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1166 else if (SCM_BIGP (k
))
1168 z_i2
= scm_i_clonebig (k
, 1);
1169 mpz_init_set (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (k
));
1170 scm_remember_upto_here_1 (k
);
1173 else if (SCM_REALP (k
))
1175 double r
= SCM_REAL_VALUE (k
);
1177 SCM_WRONG_TYPE_ARG (2, k
);
1178 if ((r
> SCM_MOST_POSITIVE_FIXNUM
) || (r
< SCM_MOST_NEGATIVE_FIXNUM
))
1180 z_i2
= scm_i_mkbig ();
1181 mpz_init_set_d (SCM_I_BIG_MPZ (z_i2
), r
);
1190 SCM_WRONG_TYPE_ARG (2, k
);
1194 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
1196 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
1197 n
= scm_divide (n
, SCM_UNDEFINED
);
1201 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
1203 mpz_clear (SCM_I_BIG_MPZ (z_i2
));
1206 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
1208 mpz_clear (SCM_I_BIG_MPZ (z_i2
));
1209 return scm_product (acc
, n
);
1211 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
1212 acc
= scm_product (acc
, n
);
1213 n
= scm_product (n
, n
);
1214 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
1222 n
= scm_divide (n
, SCM_UNDEFINED
);
1229 return scm_product (acc
, n
);
1231 acc
= scm_product (acc
, n
);
1232 n
= scm_product (n
, n
);
1239 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1241 "The function ash performs an arithmetic shift left by @var{cnt}\n"
1242 "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n"
1243 "means, that the function does not guarantee to keep the bit\n"
1244 "structure of @var{n}, but rather guarantees that the result\n"
1245 "will always be rounded towards minus infinity. Therefore, the\n"
1246 "results of ash and a corresponding bitwise shift will differ if\n"
1247 "@var{n} is negative.\n"
1249 "Formally, the function returns an integer equivalent to\n"
1250 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n"
1253 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1254 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
1256 #define FUNC_NAME s_scm_ash
1260 SCM_VALIDATE_INUM (2, cnt
);
1262 bits_to_shift
= SCM_INUM (cnt
);
1264 if (bits_to_shift
< 0)
1266 /* Shift right by abs(cnt) bits. This is realized as a division
1267 by div:=2^abs(cnt). However, to guarantee the floor
1268 rounding, negative values require some special treatment.
1270 SCM div
= scm_integer_expt (SCM_MAKINUM (2),
1271 SCM_MAKINUM (-bits_to_shift
));
1272 if (SCM_FALSEP (scm_negative_p (n
)))
1273 return scm_quotient (n
, div
);
1275 return scm_sum (SCM_MAKINUM (-1L),
1276 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1279 /* Shift left is done by multiplication with 2^CNT */
1280 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1285 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1286 (SCM n
, SCM start
, SCM end
),
1287 "Return the integer composed of the @var{start} (inclusive)\n"
1288 "through @var{end} (exclusive) bits of @var{n}. The\n"
1289 "@var{start}th bit becomes the 0-th bit in the result.\n"
1292 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1293 " @result{} \"1010\"\n"
1294 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1295 " @result{} \"10110\"\n"
1297 #define FUNC_NAME s_scm_bit_extract
1299 unsigned long int istart
, iend
;
1300 SCM_VALIDATE_INUM_MIN_COPY (2, start
,0, istart
);
1301 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1302 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1304 if (SCM_INUMP (n
)) {
1305 long int in
= SCM_INUM (n
);
1306 unsigned long int bits
= iend
- istart
;
1308 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
1310 /* Since we emulate two's complement encoded numbers, this special
1311 * case requires us to produce a result that has more bits than can be
1312 * stored in a fixnum. Thus, we fall back to the more general
1313 * algorithm that is used for bignums.
1318 if (istart
< SCM_I_FIXNUM_BIT
)
1321 if (bits
< SCM_I_FIXNUM_BIT
)
1322 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1323 else /* we know: in >= 0 */
1324 return SCM_MAKINUM (in
);
1328 return SCM_MAKINUM (-1L & ((1L << bits
) - 1));
1332 return SCM_MAKINUM (0);
1334 } else if (SCM_BIGP (n
)) {
1337 SCM num1
= SCM_MAKINUM (1L);
1338 SCM num2
= SCM_MAKINUM (2L);
1339 SCM bits
= SCM_MAKINUM (iend
- istart
);
1340 SCM mask
= scm_difference (scm_integer_expt (num2
, bits
), num1
);
1341 return scm_logand (mask
, scm_ash (n
, SCM_MAKINUM (-istart
)));
1344 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1349 static const char scm_logtab
[] = {
1350 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1353 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1355 "Return the number of bits in integer @var{n}. If integer is\n"
1356 "positive, the 1-bits in its binary representation are counted.\n"
1357 "If negative, the 0-bits in its two's-complement binary\n"
1358 "representation are counted. If 0, 0 is returned.\n"
1361 "(logcount #b10101010)\n"
1368 #define FUNC_NAME s_scm_logcount
1372 unsigned long int c
= 0;
1373 long int nn
= SCM_INUM (n
);
1378 c
+= scm_logtab
[15 & nn
];
1381 return SCM_MAKINUM (c
);
1383 else if (SCM_BIGP (n
))
1385 unsigned long count
;
1386 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0)
1390 mpz_com (z_n
, SCM_I_BIG_MPZ (n
));
1391 scm_remember_upto_here_1 (n
);
1392 count
= mpz_popcount (z_n
);
1397 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
1398 scm_remember_upto_here_1 (n
);
1400 return SCM_MAKINUM (count
);
1403 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1408 static const char scm_ilentab
[] = {
1409 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1413 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1415 "Return the number of bits necessary to represent @var{n}.\n"
1418 "(integer-length #b10101010)\n"
1420 "(integer-length 0)\n"
1422 "(integer-length #b1111)\n"
1425 #define FUNC_NAME s_scm_integer_length
1427 if (SCM_INUMP (n
)) {
1428 unsigned long int c
= 0;
1430 long int nn
= SCM_INUM (n
);
1436 l
= scm_ilentab
[15 & nn
];
1439 return SCM_MAKINUM (c
- 4 + l
);
1440 } else if (SCM_BIGP (n
)) {
1441 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
1442 scm_remember_upto_here_1 (n
);
1443 return SCM_MAKINUM (size
);
1445 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1450 /*** NUMBERS -> STRINGS ***/
1452 static const double fx
[] =
1453 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1454 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1455 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1456 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1459 idbl2str (double f
, char *a
)
1461 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1467 #ifdef HAVE_COPYSIGN
1468 double sgn
= copysign (1.0, f
);
1474 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1480 strcpy (a
, "-inf.0");
1482 strcpy (a
, "+inf.0");
1485 else if (xisnan (f
))
1487 strcpy (a
, "+nan.0");
1497 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1498 make-uniform-vector, from causing infinite loops. */
1502 if (exp
-- < DBL_MIN_10_EXP
)
1513 if (exp
++ > DBL_MAX_10_EXP
)
1533 if (f
+ fx
[wp
] >= 10.0)
1540 dpt
= (exp
+ 9999) % 3;
1544 efmt
= (exp
< -3) || (exp
> wp
+ 2);
1569 if (f
+ fx
[wp
] >= 1.0)
1583 if ((dpt
> 4) && (exp
> 6))
1585 d
= (a
[0] == '-' ? 2 : 1);
1586 for (i
= ch
++; i
> d
; i
--)
1599 if (a
[ch
- 1] == '.')
1600 a
[ch
++] = '0'; /* trailing zero */
1609 for (i
= 10; i
<= exp
; i
*= 10);
1610 for (i
/= 10; i
; i
/= 10)
1612 a
[ch
++] = exp
/ i
+ '0';
1621 iflo2str (SCM flt
, char *str
)
1624 if (SCM_REALP (flt
))
1625 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
1628 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
1629 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
1631 double imag
= SCM_COMPLEX_IMAG (flt
);
1632 /* Don't output a '+' for negative numbers or for Inf and
1633 NaN. They will provide their own sign. */
1634 if (0 <= imag
&& !xisinf (imag
) && !xisnan (imag
))
1636 i
+= idbl2str (imag
, &str
[i
]);
1643 /* convert a long to a string (unterminated). returns the number of
1644 characters in the result.
1646 p is destination: worst case (base 2) is SCM_INTBUFLEN */
1648 scm_iint2str (long num
, int rad
, char *p
)
1652 unsigned long n
= (num
< 0) ? -num
: num
;
1654 for (n
/= rad
; n
> 0; n
/= rad
)
1671 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
1677 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
1679 "Return a string holding the external representation of the\n"
1680 "number @var{n} in the given @var{radix}. If @var{n} is\n"
1681 "inexact, a radix of 10 will be used.")
1682 #define FUNC_NAME s_scm_number_to_string
1686 if (SCM_UNBNDP (radix
)) {
1689 SCM_VALIDATE_INUM (2, radix
);
1690 base
= SCM_INUM (radix
);
1691 /* FIXME: ask if range limit was OK, and if so, document */
1692 SCM_ASSERT_RANGE (2, radix
, (base
>= 2) && (base
<= 36));
1695 if (SCM_INUMP (n
)) {
1696 char num_buf
[SCM_INTBUFLEN
];
1697 size_t length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
1698 return scm_mem2string (num_buf
, length
);
1699 } else if (SCM_BIGP (n
)) {
1700 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
1701 scm_remember_upto_here_1 (n
);
1702 return scm_take0str (str
);
1703 } else if (SCM_INEXACTP (n
)) {
1704 char num_buf
[FLOBUFLEN
];
1705 return scm_mem2string (num_buf
, iflo2str (n
, num_buf
));
1707 SCM_WRONG_TYPE_ARG (1, n
);
1713 /* These print routines used to be stubbed here so that scm_repl.c
1714 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
1717 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1719 char num_buf
[FLOBUFLEN
];
1720 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
1725 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1727 char num_buf
[FLOBUFLEN
];
1728 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
1733 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1735 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
1736 scm_remember_upto_here_1 (exp
);
1737 scm_lfwrite (str
, (size_t) strlen (str
), port
);
1741 /*** END nums->strs ***/
1744 /*** STRINGS -> NUMBERS ***/
1746 /* The following functions implement the conversion from strings to numbers.
1747 * The implementation somehow follows the grammar for numbers as it is given
1748 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
1749 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
1750 * points should be noted about the implementation:
1751 * * Each function keeps a local index variable 'idx' that points at the
1752 * current position within the parsed string. The global index is only
1753 * updated if the function could parse the corresponding syntactic unit
1755 * * Similarly, the functions keep track of indicators of inexactness ('#',
1756 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
1757 * global exactness information is only updated after each part has been
1758 * successfully parsed.
1759 * * Sequences of digits are parsed into temporary variables holding fixnums.
1760 * Only if these fixnums would overflow, the result variables are updated
1761 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
1762 * the temporary variables holding the fixnums are cleared, and the process
1763 * starts over again. If for example fixnums were able to store five decimal
1764 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
1765 * and the result was computed as 12345 * 100000 + 67890. In other words,
1766 * only every five digits two bignum operations were performed.
1769 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
1771 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
1773 /* In non ASCII-style encodings the following macro might not work. */
1774 #define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
1777 mem2uinteger (const char* mem
, size_t len
, unsigned int *p_idx
,
1778 unsigned int radix
, enum t_exactness
*p_exactness
)
1780 unsigned int idx
= *p_idx
;
1781 unsigned int hash_seen
= 0;
1782 scm_t_bits shift
= 1;
1784 unsigned int digit_value
;
1794 digit_value
= XDIGIT2UINT (c
);
1795 if (digit_value
>= radix
)
1799 result
= SCM_MAKINUM (digit_value
);
1807 digit_value
= XDIGIT2UINT (c
);
1808 if (digit_value
>= radix
)
1820 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
1822 result
= scm_product (result
, SCM_MAKINUM (shift
));
1824 result
= scm_sum (result
, SCM_MAKINUM (add
));
1831 shift
= shift
* radix
;
1832 add
= add
* radix
+ digit_value
;
1837 result
= scm_product (result
, SCM_MAKINUM (shift
));
1839 result
= scm_sum (result
, SCM_MAKINUM (add
));
1843 *p_exactness
= INEXACT
;
1849 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
1850 * covers the parts of the rules that start at a potential point. The value
1851 * of the digits up to the point have been parsed by the caller and are given
1852 * in variable result. The content of *p_exactness indicates, whether a hash
1853 * has already been seen in the digits before the point.
1856 /* In non ASCII-style encodings the following macro might not work. */
1857 #define DIGIT2UINT(d) ((d) - '0')
1860 mem2decimal_from_point (SCM result
, const char* mem
, size_t len
,
1861 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
1863 unsigned int idx
= *p_idx
;
1864 enum t_exactness x
= *p_exactness
;
1869 if (mem
[idx
] == '.')
1871 scm_t_bits shift
= 1;
1873 unsigned int digit_value
;
1874 SCM big_shift
= SCM_MAKINUM (1);
1885 digit_value
= DIGIT2UINT (c
);
1896 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
1898 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
1899 result
= scm_product (result
, SCM_MAKINUM (shift
));
1901 result
= scm_sum (result
, SCM_MAKINUM (add
));
1909 add
= add
* 10 + digit_value
;
1915 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
1916 result
= scm_product (result
, SCM_MAKINUM (shift
));
1917 result
= scm_sum (result
, SCM_MAKINUM (add
));
1920 result
= scm_divide (result
, big_shift
);
1922 /* We've seen a decimal point, thus the value is implicitly inexact. */
1934 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
1965 exponent
= DIGIT2UINT (c
);
1972 if (exponent
<= SCM_MAXEXP
)
1973 exponent
= exponent
* 10 + DIGIT2UINT (c
);
1979 if (exponent
> SCM_MAXEXP
)
1981 size_t exp_len
= idx
- start
;
1982 SCM exp_string
= scm_mem2string (&mem
[start
], exp_len
);
1983 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
1984 scm_out_of_range ("string->number", exp_num
);
1987 e
= scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent
));
1989 result
= scm_product (result
, e
);
1991 result
= scm_divide (result
, e
);
1993 /* We've seen an exponent, thus the value is implicitly inexact. */
2011 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2014 mem2ureal (const char* mem
, size_t len
, unsigned int *p_idx
,
2015 unsigned int radix
, enum t_exactness
*p_exactness
)
2017 unsigned int idx
= *p_idx
;
2023 if (idx
+5 <= len
&& !strncmp (mem
+idx
, "inf.0", 5))
2029 if (idx
+4 < len
&& !strncmp (mem
+idx
, "nan.", 4))
2031 enum t_exactness x
= EXACT
;
2033 /* Cobble up the fraction. We might want to set the NaN's
2034 mantissa from it. */
2036 mem2uinteger (mem
, len
, &idx
, 10, &x
);
2041 if (mem
[idx
] == '.')
2045 else if (idx
+ 1 == len
)
2047 else if (!isdigit (mem
[idx
+ 1]))
2050 result
= mem2decimal_from_point (SCM_MAKINUM (0), mem
, len
,
2051 p_idx
, p_exactness
);
2055 enum t_exactness x
= EXACT
;
2058 uinteger
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2059 if (SCM_FALSEP (uinteger
))
2064 else if (mem
[idx
] == '/')
2070 divisor
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2071 if (SCM_FALSEP (divisor
))
2074 result
= scm_divide (uinteger
, divisor
);
2076 else if (radix
== 10)
2078 result
= mem2decimal_from_point (uinteger
, mem
, len
, &idx
, &x
);
2079 if (SCM_FALSEP (result
))
2090 /* When returning an inexact zero, make sure it is represented as a
2091 floating point value so that we can change its sign.
2093 if (SCM_EQ_P (result
, SCM_MAKINUM(0)) && *p_exactness
== INEXACT
)
2094 result
= scm_make_real (0.0);
2100 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2103 mem2complex (const char* mem
, size_t len
, unsigned int idx
,
2104 unsigned int radix
, enum t_exactness
*p_exactness
)
2128 ureal
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2129 if (SCM_FALSEP (ureal
))
2131 /* input must be either +i or -i */
2136 if (mem
[idx
] == 'i' || mem
[idx
] == 'I')
2142 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign
));
2149 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2150 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
2159 /* either +<ureal>i or -<ureal>i */
2166 return scm_make_rectangular (SCM_MAKINUM (0), ureal
);
2169 /* polar input: <real>@<real>. */
2194 angle
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2195 if (SCM_FALSEP (angle
))
2200 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2201 angle
= scm_difference (angle
, SCM_UNDEFINED
);
2203 result
= scm_make_polar (ureal
, angle
);
2208 /* expecting input matching <real>[+-]<ureal>?i */
2215 int sign
= (c
== '+') ? 1 : -1;
2216 SCM imag
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2218 if (SCM_FALSEP (imag
))
2219 imag
= SCM_MAKINUM (sign
);
2220 else if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2221 imag
= scm_difference (imag
, SCM_UNDEFINED
);
2225 if (mem
[idx
] != 'i' && mem
[idx
] != 'I')
2232 return scm_make_rectangular (ureal
, imag
);
2241 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2243 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
2246 scm_i_mem2number (const char* mem
, size_t len
, unsigned int default_radix
)
2248 unsigned int idx
= 0;
2249 unsigned int radix
= NO_RADIX
;
2250 enum t_exactness forced_x
= NO_EXACTNESS
;
2251 enum t_exactness implicit_x
= EXACT
;
2254 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2255 while (idx
+ 2 < len
&& mem
[idx
] == '#')
2257 switch (mem
[idx
+ 1])
2260 if (radix
!= NO_RADIX
)
2265 if (radix
!= NO_RADIX
)
2270 if (forced_x
!= NO_EXACTNESS
)
2275 if (forced_x
!= NO_EXACTNESS
)
2280 if (radix
!= NO_RADIX
)
2285 if (radix
!= NO_RADIX
)
2295 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2296 if (radix
== NO_RADIX
)
2297 result
= mem2complex (mem
, len
, idx
, default_radix
, &implicit_x
);
2299 result
= mem2complex (mem
, len
, idx
, (unsigned int) radix
, &implicit_x
);
2301 if (SCM_FALSEP (result
))
2307 if (SCM_INEXACTP (result
))
2308 /* FIXME: This may change the value. */
2309 return scm_inexact_to_exact (result
);
2313 if (SCM_INEXACTP (result
))
2316 return scm_exact_to_inexact (result
);
2319 if (implicit_x
== INEXACT
)
2321 if (SCM_INEXACTP (result
))
2324 return scm_exact_to_inexact (result
);
2332 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2333 (SCM string
, SCM radix
),
2334 "Return a number of the maximally precise representation\n"
2335 "expressed by the given @var{string}. @var{radix} must be an\n"
2336 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2337 "is a default radix that may be overridden by an explicit radix\n"
2338 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2339 "supplied, then the default radix is 10. If string is not a\n"
2340 "syntactically valid notation for a number, then\n"
2341 "@code{string->number} returns @code{#f}.")
2342 #define FUNC_NAME s_scm_string_to_number
2346 SCM_VALIDATE_STRING (1, string
);
2347 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix
,2,10, base
);
2348 answer
= scm_i_mem2number (SCM_STRING_CHARS (string
),
2349 SCM_STRING_LENGTH (string
),
2351 return scm_return_first (answer
, string
);
2356 /*** END strs->nums ***/
2360 scm_make_real (double x
)
2362 SCM z
= scm_double_cell (scm_tc16_real
, 0, 0, 0);
2364 SCM_REAL_VALUE (z
) = x
;
2370 scm_make_complex (double x
, double y
)
2373 return scm_make_real (x
);
2376 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_gc_malloc (2*sizeof (double),
2378 SCM_COMPLEX_REAL (z
) = x
;
2379 SCM_COMPLEX_IMAG (z
) = y
;
2386 scm_bigequal (SCM x
, SCM y
)
2388 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (x
));
2389 scm_remember_upto_here_2 (x
, y
);
2390 return SCM_BOOL (0 == result
);
2394 scm_real_equalp (SCM x
, SCM y
)
2396 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2400 scm_complex_equalp (SCM x
, SCM y
)
2402 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2403 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2408 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2409 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2410 * "else. Note that the sets of complex, real, rational and\n"
2411 * "integer values form subsets of the set of numbers, i. e. the\n"
2412 * "predicate will be fulfilled for any number."
2414 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2416 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2417 "otherwise. Note that the sets of real, rational and integer\n"
2418 "values form subsets of the set of complex numbers, i. e. the\n"
2419 "predicate will also be fulfilled if @var{x} is a real,\n"
2420 "rational or integer number.")
2421 #define FUNC_NAME s_scm_number_p
2423 return SCM_BOOL (SCM_NUMBERP (x
));
2428 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2429 /* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
2430 * "Note that the sets of integer and rational values form a subset\n"
2431 * "of the set of real numbers, i. e. the predicate will also\n"
2432 * "be fulfilled if @var{x} is an integer or a rational number."
2434 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2436 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
2437 "otherwise. Note that the set of integer values forms a subset of\n"
2438 "the set of rational numbers, i. e. the predicate will also be\n"
2439 "fulfilled if @var{x} is an integer number. Real numbers\n"
2440 "will also satisfy this predicate, because of their limited\n"
2442 #define FUNC_NAME s_scm_real_p
2444 if (SCM_INUMP (x
)) {
2446 } else if (SCM_IMP (x
)) {
2448 } else if (SCM_REALP (x
)) {
2450 } else if (SCM_BIGP (x
)) {
2459 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2461 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2463 #define FUNC_NAME s_scm_integer_p
2472 if (!SCM_INEXACTP (x
))
2474 if (SCM_COMPLEXP (x
))
2476 r
= SCM_REAL_VALUE (x
);
2484 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
2486 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
2488 #define FUNC_NAME s_scm_inexact_p
2490 return SCM_BOOL (SCM_INEXACTP (x
));
2495 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
2496 /* "Return @code{#t} if all parameters are numerically equal." */
2498 scm_num_eq_p (SCM x
, SCM y
)
2500 if (SCM_INUMP (x
)) {
2501 long xx
= SCM_INUM (x
);
2502 if (SCM_INUMP (y
)) {
2503 long yy
= SCM_INUM (y
);
2504 return SCM_BOOL (xx
== yy
);
2505 } else if (SCM_BIGP (y
)) {
2507 } else if (SCM_REALP (y
)) {
2508 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
2509 } else if (SCM_COMPLEXP (y
)) {
2510 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
2511 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2513 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2515 } else if (SCM_BIGP (x
)) {
2516 if (SCM_INUMP (y
)) {
2518 } else if (SCM_BIGP (y
)) {
2519 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2520 scm_remember_upto_here_2 (x
, y
);
2521 return SCM_BOOL (0 == cmp
);
2522 } else if (SCM_REALP (y
)) {
2524 if (xisnan (SCM_REAL_VALUE (y
))) return SCM_BOOL_F
;
2525 cmp
= mpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
2526 scm_remember_upto_here_1 (x
);
2527 return SCM_BOOL (0 == cmp
);
2528 } else if (SCM_COMPLEXP (y
)) {
2530 if (0.0 != SCM_COMPLEX_IMAG (y
)) return SCM_BOOL_F
;
2531 if (xisnan (SCM_COMPLEX_REAL (y
))) return SCM_BOOL_F
;
2532 cmp
= mpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
2533 scm_remember_upto_here_1 (x
);
2534 return SCM_BOOL (0 == cmp
);
2536 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2538 } else if (SCM_REALP (x
)) {
2539 if (SCM_INUMP (y
)) {
2540 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
2541 } else if (SCM_BIGP (y
)) {
2543 if (xisnan (SCM_REAL_VALUE (x
))) return SCM_BOOL_F
;
2544 cmp
= mpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
2545 scm_remember_upto_here_1 (y
);
2546 return SCM_BOOL (0 == cmp
);
2547 } else if (SCM_REALP (y
)) {
2548 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2549 } else if (SCM_COMPLEXP (y
)) {
2550 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
2551 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2553 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2555 } else if (SCM_COMPLEXP (x
)) {
2556 if (SCM_INUMP (y
)) {
2557 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
2558 && (SCM_COMPLEX_IMAG (x
) == 0.0));
2559 } else if (SCM_BIGP (y
)) {
2561 if (0.0 != SCM_COMPLEX_IMAG (x
)) return SCM_BOOL_F
;
2562 if (xisnan (SCM_COMPLEX_REAL (x
))) return SCM_BOOL_F
;
2563 cmp
= mpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
2564 scm_remember_upto_here_1 (y
);
2565 return SCM_BOOL (0 == cmp
);
2566 } else if (SCM_REALP (y
)) {
2567 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
2568 && (SCM_COMPLEX_IMAG (x
) == 0.0));
2569 } else if (SCM_COMPLEXP (y
)) {
2570 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
2571 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
2573 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2576 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
2581 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
2582 /* "Return @code{#t} if the list of parameters is monotonically\n"
2586 scm_less_p (SCM x
, SCM y
)
2588 if (SCM_INUMP (x
)) {
2589 long xx
= SCM_INUM (x
);
2590 if (SCM_INUMP (y
)) {
2591 long yy
= SCM_INUM (y
);
2592 return SCM_BOOL (xx
< yy
);
2593 } else if (SCM_BIGP (y
)) {
2594 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2595 scm_remember_upto_here_1 (y
);
2596 return SCM_BOOL (sgn
> 0);
2597 } else if (SCM_REALP (y
)) {
2598 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
2600 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
2602 } else if (SCM_BIGP (x
)) {
2603 if (SCM_INUMP (y
)) {
2604 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
2605 scm_remember_upto_here_1 (x
);
2606 return SCM_BOOL (sgn
< 0);
2607 } else if (SCM_BIGP (y
)) {
2608 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2609 scm_remember_upto_here_2 (x
, y
);
2610 return SCM_BOOL (cmp
< 0);
2611 } else if (SCM_REALP (y
)) {
2613 if (xisnan (SCM_REAL_VALUE (y
))) return SCM_BOOL_F
;
2614 cmp
= mpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
2615 scm_remember_upto_here_1 (x
);
2616 return SCM_BOOL (cmp
< 0);
2618 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
2620 } else if (SCM_REALP (x
)) {
2621 if (SCM_INUMP (y
)) {
2622 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
2623 } else if (SCM_BIGP (y
)) {
2625 if (xisnan (SCM_REAL_VALUE (x
))) return SCM_BOOL_F
;
2626 cmp
= mpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
2627 scm_remember_upto_here_1 (y
);
2628 return SCM_BOOL (cmp
> 0);
2629 } else if (SCM_REALP (y
)) {
2630 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
2632 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
2635 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
2640 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
2641 /* "Return @code{#t} if the list of parameters is monotonically\n"
2644 #define FUNC_NAME s_scm_gr_p
2646 scm_gr_p (SCM x
, SCM y
)
2648 if (!SCM_NUMBERP (x
))
2649 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
2650 else if (!SCM_NUMBERP (y
))
2651 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
2653 return scm_less_p (y
, x
);
2658 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
2659 /* "Return @code{#t} if the list of parameters is monotonically\n"
2662 #define FUNC_NAME s_scm_leq_p
2664 scm_leq_p (SCM x
, SCM y
)
2666 if (!SCM_NUMBERP (x
))
2667 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
2668 else if (!SCM_NUMBERP (y
))
2669 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
2670 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
2673 return SCM_BOOL_NOT (scm_less_p (y
, x
));
2678 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
2679 /* "Return @code{#t} if the list of parameters is monotonically\n"
2682 #define FUNC_NAME s_scm_geq_p
2684 scm_geq_p (SCM x
, SCM y
)
2686 if (!SCM_NUMBERP (x
))
2687 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
2688 else if (!SCM_NUMBERP (y
))
2689 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
2690 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
2693 return SCM_BOOL_NOT (scm_less_p (x
, y
));
2698 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
2699 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
2705 if (SCM_INUMP (z
)) {
2706 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
2707 } else if (SCM_BIGP (z
)) {
2709 } else if (SCM_REALP (z
)) {
2710 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
2711 } else if (SCM_COMPLEXP (z
)) {
2712 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
2713 && SCM_COMPLEX_IMAG (z
) == 0.0);
2715 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
2720 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
2721 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
2725 scm_positive_p (SCM x
)
2727 if (SCM_INUMP (x
)) {
2728 return SCM_BOOL (SCM_INUM (x
) > 0);
2729 } else if (SCM_BIGP (x
)) {
2730 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
2731 scm_remember_upto_here_1 (x
);
2732 return SCM_BOOL (sgn
> 0);
2733 } else if (SCM_REALP (x
)) {
2734 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
2736 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
2741 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
2742 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
2746 scm_negative_p (SCM x
)
2748 if (SCM_INUMP (x
)) {
2749 return SCM_BOOL (SCM_INUM (x
) < 0);
2750 } else if (SCM_BIGP (x
)) {
2751 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
2752 scm_remember_upto_here_1 (x
);
2753 return SCM_BOOL (sgn
< 0);
2754 } else if (SCM_REALP (x
)) {
2755 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
2757 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
2762 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
2763 /* "Return the maximum of all parameter values."
2766 scm_max (SCM x
, SCM y
)
2768 if (SCM_UNBNDP (y
)) {
2769 if (SCM_UNBNDP (x
)) {
2770 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
2771 } else if (SCM_NUMBERP (x
)) {
2774 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
2778 if (SCM_INUMP (x
)) {
2779 long xx
= SCM_INUM (x
);
2780 if (SCM_INUMP (y
)) {
2781 long yy
= SCM_INUM (y
);
2782 return (xx
< yy
) ? y
: x
;
2783 } else if (SCM_BIGP (y
)) {
2784 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2785 scm_remember_upto_here_1 (y
);
2786 return (sgn
< 0) ? x
: y
;
2787 } else if (SCM_REALP (y
)) {
2789 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
2791 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
2793 } else if (SCM_BIGP (x
)) {
2794 if (SCM_INUMP (y
)) {
2795 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
2796 scm_remember_upto_here_1 (x
);
2797 return (sgn
< 0) ? y
: x
;
2798 } else if (SCM_BIGP (y
)) {
2799 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2800 scm_remember_upto_here_2 (x
, y
);
2801 return (cmp
> 0) ? x
: y
;
2802 } else if (SCM_REALP (y
)) {
2803 int cmp
= mpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
2804 scm_remember_upto_here_1 (x
);
2805 return (cmp
> 0) ? x
: y
;
2807 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
2809 } else if (SCM_REALP (x
)) {
2810 if (SCM_INUMP (y
)) {
2811 double z
= SCM_INUM (y
);
2812 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
2813 } else if (SCM_BIGP (y
)) {
2814 int cmp
= mpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
2815 scm_remember_upto_here_1 (y
);
2816 return (cmp
< 0) ? x
: y
;
2817 } else if (SCM_REALP (y
)) {
2818 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? y
: x
;
2820 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
2823 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
2828 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
2829 /* "Return the minium of all parameter values."
2832 scm_min (SCM x
, SCM y
)
2834 if (SCM_UNBNDP (y
)) {
2835 if (SCM_UNBNDP (x
)) {
2836 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
2837 } else if (SCM_NUMBERP (x
)) {
2840 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
2844 if (SCM_INUMP (x
)) {
2845 long xx
= SCM_INUM (x
);
2846 if (SCM_INUMP (y
)) {
2847 long yy
= SCM_INUM (y
);
2848 return (xx
< yy
) ? x
: y
;
2849 } else if (SCM_BIGP (y
)) {
2850 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2851 scm_remember_upto_here_1 (y
);
2852 return (sgn
< 0) ? y
: x
;
2853 } else if (SCM_REALP (y
)) {
2855 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
2857 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
2859 } else if (SCM_BIGP (x
)) {
2860 if (SCM_INUMP (y
)) {
2861 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
2862 scm_remember_upto_here_1 (x
);
2863 return (sgn
< 0) ? x
: y
;
2864 } else if (SCM_BIGP (y
)) {
2865 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2866 scm_remember_upto_here_2 (x
, y
);
2867 return (cmp
> 0) ? y
: x
;
2868 } else if (SCM_REALP (y
)) {
2869 int cmp
= mpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
2870 scm_remember_upto_here_1 (x
);
2871 return (cmp
> 0) ? y
: x
;
2873 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
2875 } else if (SCM_REALP (x
)) {
2876 if (SCM_INUMP (y
)) {
2877 double z
= SCM_INUM (y
);
2878 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
2879 } else if (SCM_BIGP (y
)) {
2880 int cmp
= mpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
2881 scm_remember_upto_here_1 (y
);
2882 return (cmp
< 0) ? y
: x
;
2883 } else if (SCM_REALP (y
)) {
2884 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? x
: y
;
2886 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
2889 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
2894 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
2895 /* "Return the sum of all parameter values. Return 0 if called without\n"
2899 scm_sum (SCM x
, SCM y
)
2903 if (SCM_NUMBERP (x
)) return x
;
2904 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
2905 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
2912 long xx
= SCM_INUM (x
);
2913 long yy
= SCM_INUM (y
);
2914 long int z
= xx
+ yy
;
2915 return SCM_FIXABLE (z
) ? SCM_MAKINUM (z
) : scm_i_long2big (z
);
2917 else if (SCM_BIGP (y
))
2922 else if (SCM_REALP (y
))
2924 long int xx
= SCM_INUM (x
);
2925 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
2927 else if (SCM_COMPLEXP (y
))
2929 long int xx
= SCM_INUM (x
);
2930 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
2931 SCM_COMPLEX_IMAG (y
));
2934 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
2935 } else if (SCM_BIGP (x
)) {
2936 if (SCM_INUMP (y
)) {
2940 inum
= SCM_INUM (y
);
2941 if (inum
== 0) return x
;
2942 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
2944 SCM result
= scm_i_mkbig ();
2945 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
2946 scm_remember_upto_here_1 (x
);
2947 /* we know the result will have to be a bignum */
2948 if (bigsgn
== -1) return result
;
2949 return scm_i_normbig (result
);
2951 SCM result
= scm_i_mkbig ();
2952 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
2953 scm_remember_upto_here_1 (x
);
2954 /* we know the result will have to be a bignum */
2955 if (bigsgn
== 1) return result
;
2957 return scm_i_normbig (result
);
2960 else if (SCM_BIGP (y
)) {
2961 SCM result
= scm_i_mkbig ();
2962 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
2963 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2964 mpz_add (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2965 scm_remember_upto_here_2 (x
, y
);
2966 /* we know the result will have to be a bignum */
2967 if (sgn_x
== sgn_y
) return result
;
2968 return scm_i_normbig (result
);
2970 else if (SCM_REALP (y
)) {
2971 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
2972 scm_remember_upto_here_1 (x
);
2973 return scm_make_real (result
);
2975 else if (SCM_COMPLEXP (y
)) {
2976 double real_part
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_COMPLEX_REAL (y
);
2977 scm_remember_upto_here_1 (x
);
2978 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (y
));
2980 else SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
2981 } else if (SCM_REALP (x
)) {
2982 if (SCM_INUMP (y
)) {
2983 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
2984 } else if (SCM_BIGP (y
)) {
2985 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
2986 scm_remember_upto_here_1 (y
);
2987 return scm_make_real (result
);
2988 } else if (SCM_REALP (y
)) {
2989 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
2990 } else if (SCM_COMPLEXP (y
)) {
2991 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
2992 SCM_COMPLEX_IMAG (y
));
2994 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
2996 } else if (SCM_COMPLEXP (x
)) {
2997 if (SCM_INUMP (y
)) {
2998 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
2999 SCM_COMPLEX_IMAG (x
));
3000 } else if (SCM_BIGP (y
)) {
3001 double real_part
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_COMPLEX_REAL (x
);
3002 scm_remember_upto_here_1 (y
);
3003 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (x
));
3004 } else if (SCM_REALP (y
)) {
3005 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3006 SCM_COMPLEX_IMAG (x
));
3007 } else if (SCM_COMPLEXP (y
)) {
3008 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3009 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3011 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3014 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3019 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3020 /* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3021 * the sum of all but the first argument are subtracted from the first
3023 #define FUNC_NAME s_difference
3025 scm_difference (SCM x
, SCM y
)
3030 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3034 long xx
= -SCM_INUM (x
);
3035 if (SCM_FIXABLE (xx
))
3036 return SCM_MAKINUM (xx
);
3038 return scm_i_long2big (xx
);
3040 else if (SCM_BIGP (x
))
3041 /* FIXME: do we really need to normalize here? */
3042 return scm_i_normbig (scm_i_clonebig (x
, 0));
3043 else if (SCM_REALP (x
))
3044 return scm_make_real (-SCM_REAL_VALUE (x
));
3045 else if (SCM_COMPLEXP (x
))
3046 return scm_make_complex (-SCM_COMPLEX_REAL (x
),
3047 -SCM_COMPLEX_IMAG (x
));
3049 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3052 if (SCM_INUMP (x
)) {
3053 if (SCM_INUMP (y
)) {
3054 long int xx
= SCM_INUM (x
);
3055 long int yy
= SCM_INUM (y
);
3056 long int z
= xx
- yy
;
3057 if (SCM_FIXABLE (z
)) {
3058 return SCM_MAKINUM (z
);
3060 return scm_i_long2big (z
);
3062 } else if (SCM_BIGP (y
)) {
3063 /* inum-x - big-y */
3064 long xx
= SCM_INUM (x
);
3067 return scm_i_clonebig (y
, 0);
3070 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3071 SCM result
= scm_i_mkbig ();
3074 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
3077 /* x - y == -(y + -x) */
3078 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
3079 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
3081 scm_remember_upto_here_1 (y
);
3083 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
3084 /* we know the result will have to be a bignum */
3087 return scm_i_normbig (result
);
3089 } else if (SCM_REALP (y
)) {
3090 long int xx
= SCM_INUM (x
);
3091 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
3092 } else if (SCM_COMPLEXP (y
)) {
3093 long int xx
= SCM_INUM (x
);
3094 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
3095 -SCM_COMPLEX_IMAG (y
));
3097 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3099 } else if (SCM_BIGP (x
)) {
3100 if (SCM_INUMP (y
)) {
3101 /* big-x - inum-y */
3102 long yy
= SCM_INUM (y
);
3103 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3105 scm_remember_upto_here_1 (x
);
3107 return SCM_FIXABLE (-yy
) ? SCM_MAKINUM (-yy
) : scm_long2num (-yy
);
3110 SCM result
= scm_i_mkbig ();
3112 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
3113 scm_remember_upto_here_1 (x
);
3115 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
3116 /* we know the result will have to be a bignum */
3119 return scm_i_normbig (result
);
3122 else if (SCM_BIGP (y
))
3124 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3125 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3126 SCM result
= scm_i_mkbig ();
3127 mpz_sub (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3128 scm_remember_upto_here_2 (x
, y
);
3129 /* we know the result will have to be a bignum */
3130 if ((sgn_x
== 1) && (sgn_y
== -1)) return result
;
3131 if ((sgn_x
== -1) && (sgn_y
== 1)) return result
;
3132 return scm_i_normbig (result
);
3134 else if (SCM_REALP (y
)) {
3135 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
3136 scm_remember_upto_here_1 (x
);
3137 return scm_make_real (result
);
3139 else if (SCM_COMPLEXP (y
)) {
3140 double real_part
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_COMPLEX_REAL (y
);
3141 scm_remember_upto_here_1 (x
);
3142 return scm_make_complex (real_part
, - SCM_COMPLEX_IMAG (y
));
3144 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3145 } else if (SCM_REALP (x
)) {
3146 if (SCM_INUMP (y
)) {
3147 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
3148 } else if (SCM_BIGP (y
)) {
3149 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
3150 scm_remember_upto_here_1 (x
);
3151 return scm_make_real (result
);
3152 } else if (SCM_REALP (y
)) {
3153 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3154 } else if (SCM_COMPLEXP (y
)) {
3155 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3156 -SCM_COMPLEX_IMAG (y
));
3158 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3160 } else if (SCM_COMPLEXP (x
)) {
3161 if (SCM_INUMP (y
)) {
3162 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
3163 SCM_COMPLEX_IMAG (x
));
3164 } else if (SCM_BIGP (y
)) {
3165 double real_part
= SCM_COMPLEX_REAL (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
3166 scm_remember_upto_here_1 (x
);
3167 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (y
));
3168 } else if (SCM_REALP (y
)) {
3169 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3170 SCM_COMPLEX_IMAG (x
));
3171 } else if (SCM_COMPLEXP (y
)) {
3172 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3173 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3175 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3178 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3184 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3185 /* "Return the product of all arguments. If called without arguments,\n"
3189 scm_product (SCM x
, SCM y
)
3191 if (SCM_UNBNDP (y
)) {
3192 if (SCM_UNBNDP (x
)) {
3193 return SCM_MAKINUM (1L);
3194 } else if (SCM_NUMBERP (x
)) {
3197 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3201 if (SCM_INUMP (x
)) {
3209 case 0: return x
; break;
3210 case 1: return y
; break;
3213 if (SCM_INUMP (y
)) {
3214 long yy
= SCM_INUM (y
);
3216 SCM k
= SCM_MAKINUM (kk
);
3217 if ((kk
== SCM_INUM (k
)) && (kk
/ xx
== yy
)) {
3220 SCM result
= scm_i_long2big (xx
);
3221 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
3222 return scm_i_normbig (result
);
3224 } else if (SCM_BIGP (y
)) {
3225 SCM result
= scm_i_mkbig ();
3226 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
3227 scm_remember_upto_here_1 (y
);
3229 } else if (SCM_REALP (y
)) {
3230 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3231 } else if (SCM_COMPLEXP (y
)) {
3232 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3233 xx
* SCM_COMPLEX_IMAG (y
));
3235 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3237 } else if (SCM_BIGP (x
)) {
3238 if (SCM_INUMP (y
)) {
3241 } else if (SCM_BIGP (y
)) {
3242 SCM result
= scm_i_mkbig ();
3243 mpz_mul (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3244 scm_remember_upto_here_2 (x
, y
);
3246 } else if (SCM_REALP (y
)) {
3247 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
3248 scm_remember_upto_here_1 (x
);
3249 return scm_make_real (result
);
3250 } else if (SCM_COMPLEXP (y
)) {
3251 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
3252 scm_remember_upto_here_1 (x
);
3253 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3254 z
* SCM_COMPLEX_IMAG (y
));
3256 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3258 } else if (SCM_REALP (x
)) {
3259 if (SCM_INUMP (y
)) {
3260 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3261 } else if (SCM_BIGP (y
)) {
3262 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
3263 scm_remember_upto_here_1 (y
);
3264 return scm_make_real (result
);
3265 } else if (SCM_REALP (y
)) {
3266 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
3267 } else if (SCM_COMPLEXP (y
)) {
3268 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
3269 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3271 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3273 } else if (SCM_COMPLEXP (x
)) {
3274 if (SCM_INUMP (y
)) {
3275 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3276 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3277 } else if (SCM_BIGP (y
)) {
3278 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
3279 scm_remember_upto_here_1 (y
);
3280 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3281 z
* SCM_COMPLEX_IMAG (y
));
3282 } else if (SCM_REALP (y
)) {
3283 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3284 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
3285 } else if (SCM_COMPLEXP (y
)) {
3286 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
3287 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
3288 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3289 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3291 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3294 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3299 scm_num2dbl (SCM a
, const char *why
)
3300 #define FUNC_NAME why
3302 if (SCM_INUMP (a
)) {
3303 return (double) SCM_INUM (a
);
3304 } else if (SCM_BIGP (a
)) {
3305 double result
= mpz_get_d (SCM_I_BIG_MPZ (a
));
3306 scm_remember_upto_here_1 (a
);
3308 } else if (SCM_REALP (a
)) {
3309 return (SCM_REAL_VALUE (a
));
3311 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3316 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
3317 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
3318 #define ALLOW_DIVIDE_BY_ZERO
3319 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
3322 /* The code below for complex division is adapted from the GNU
3323 libstdc++, which adapted it from f2c's libF77, and is subject to
3326 /****************************************************************
3327 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
3329 Permission to use, copy, modify, and distribute this software
3330 and its documentation for any purpose and without fee is hereby
3331 granted, provided that the above copyright notice appear in all
3332 copies and that both that the copyright notice and this
3333 permission notice and warranty disclaimer appear in supporting
3334 documentation, and that the names of AT&T Bell Laboratories or
3335 Bellcore or any of their entities not be used in advertising or
3336 publicity pertaining to distribution of the software without
3337 specific, written prior permission.
3339 AT&T and Bellcore disclaim all warranties with regard to this
3340 software, including all implied warranties of merchantability
3341 and fitness. In no event shall AT&T or Bellcore be liable for
3342 any special, indirect or consequential damages or any damages
3343 whatsoever resulting from loss of use, data or profits, whether
3344 in an action of contract, negligence or other tortious action,
3345 arising out of or in connection with the use or performance of
3347 ****************************************************************/
3349 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3350 /* Divide the first argument by the product of the remaining
3351 arguments. If called with one argument @var{z1}, 1/@var{z1} is
3353 #define FUNC_NAME s_divide
3355 scm_divide (SCM x
, SCM y
)
3359 if (SCM_UNBNDP (y
)) {
3360 if (SCM_UNBNDP (x
)) {
3361 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
3362 } else if (SCM_INUMP (x
)) {
3363 long xx
= SCM_INUM (x
);
3364 if (xx
== 1 || xx
== -1) {
3366 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3367 } else if (xx
== 0) {
3368 scm_num_overflow (s_divide
);
3371 return scm_make_real (1.0 / (double) xx
);
3373 } else if (SCM_BIGP (x
)) {
3374 return scm_make_real (1.0 / scm_i_big2dbl (x
));
3375 } else if (SCM_REALP (x
)) {
3376 double xx
= SCM_REAL_VALUE (x
);
3377 #ifndef ALLOW_DIVIDE_BY_ZERO
3379 scm_num_overflow (s_divide
);
3382 return scm_make_real (1.0 / xx
);
3383 } else if (SCM_COMPLEXP (x
)) {
3384 double r
= SCM_COMPLEX_REAL (x
);
3385 double i
= SCM_COMPLEX_IMAG (x
);
3388 double d
= i
* (1.0 + t
* t
);
3389 return scm_make_complex (t
/ d
, -1.0 / d
);
3392 double d
= r
* (1.0 + t
* t
);
3393 return scm_make_complex (1.0 / d
, -t
/ d
);
3396 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3400 if (SCM_INUMP (x
)) {
3401 long xx
= SCM_INUM (x
);
3402 if (SCM_INUMP (y
)) {
3403 long yy
= SCM_INUM (y
);
3405 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3406 scm_num_overflow (s_divide
);
3408 return scm_make_real ((double) xx
/ (double) yy
);
3410 } else if (xx
% yy
!= 0) {
3411 return scm_make_real ((double) xx
/ (double) yy
);
3414 if (SCM_FIXABLE (z
)) {
3415 return SCM_MAKINUM (z
);
3417 return scm_i_long2big (z
);
3420 } else if (SCM_BIGP (y
)) {
3421 return scm_make_real ((double) xx
/ scm_i_big2dbl (y
));
3422 } else if (SCM_REALP (y
)) {
3423 double yy
= SCM_REAL_VALUE (y
);
3424 #ifndef ALLOW_DIVIDE_BY_ZERO
3426 scm_num_overflow (s_divide
);
3429 return scm_make_real ((double) xx
/ yy
);
3430 } else if (SCM_COMPLEXP (y
)) {
3432 complex_div
: /* y _must_ be a complex number */
3434 double r
= SCM_COMPLEX_REAL (y
);
3435 double i
= SCM_COMPLEX_IMAG (y
);
3438 double d
= i
* (1.0 + t
* t
);
3439 return scm_make_complex ((a
* t
) / d
, -a
/ d
);
3442 double d
= r
* (1.0 + t
* t
);
3443 return scm_make_complex (a
/ d
, -(a
* t
) / d
);
3447 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3449 } else if (SCM_BIGP (x
)) {
3450 if (SCM_INUMP (y
)) {
3451 long int yy
= SCM_INUM (y
);
3453 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3454 scm_num_overflow (s_divide
);
3456 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3457 scm_remember_upto_here_1 (x
);
3458 return (sgn
== 0) ? scm_nan () : scm_inf ();
3460 } else if (yy
== 1) {
3463 /* FIXME: HMM, what are the relative performance issues here?
3464 We need to test. Is it faster on average to test
3465 divisible_p, then perform whichever operation, or is it
3466 faster to perform the integer div opportunistically and
3467 switch to real if there's a remainder? For now we take the
3468 middle ground: test, then if divisible, use the faster div
3471 long abs_yy
= yy
< 0 ? -yy
: yy
;
3472 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
3475 SCM result
= scm_i_mkbig ();
3476 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
3477 scm_remember_upto_here_1 (x
);
3479 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
3480 return scm_i_normbig (result
);
3483 return scm_make_real (scm_i_big2dbl (x
) / (double) yy
);
3486 } else if (SCM_BIGP (y
)) {
3487 int y_is_zero
= (mpz_sgn (SCM_I_BIG_MPZ (y
)) == 0);
3489 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3490 scm_num_overflow (s_divide
);
3492 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3493 scm_remember_upto_here_1 (x
);
3494 return (sgn
== 0) ? scm_nan () : scm_inf ();
3498 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
3501 SCM result
= scm_i_mkbig ();
3502 mpz_divexact (SCM_I_BIG_MPZ (result
),
3505 scm_remember_upto_here_2 (x
, y
);
3506 return scm_i_normbig (result
);
3509 double dbx
= mpz_get_d (SCM_I_BIG_MPZ (x
));
3510 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
3511 scm_remember_upto_here_2 (x
, y
);
3512 return scm_make_real (dbx
/ dby
);
3515 } else if (SCM_REALP (y
)) {
3516 double yy
= SCM_REAL_VALUE (y
);
3517 #ifndef ALLOW_DIVIDE_BY_ZERO
3519 scm_num_overflow (s_divide
);
3522 return scm_make_real (scm_i_big2dbl (x
) / yy
);
3523 } else if (SCM_COMPLEXP (y
)) {
3524 a
= scm_i_big2dbl (x
);
3527 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3529 } else if (SCM_REALP (x
)) {
3530 double rx
= SCM_REAL_VALUE (x
);
3531 if (SCM_INUMP (y
)) {
3532 long int yy
= SCM_INUM (y
);
3533 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3535 scm_num_overflow (s_divide
);
3538 return scm_make_real (rx
/ (double) yy
);
3539 } else if (SCM_BIGP (y
)) {
3540 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
3541 scm_remember_upto_here_1 (y
);
3542 return scm_make_real (rx
/ dby
);
3543 } else if (SCM_REALP (y
)) {
3544 double yy
= SCM_REAL_VALUE (y
);
3545 #ifndef ALLOW_DIVIDE_BY_ZERO
3547 scm_num_overflow (s_divide
);
3550 return scm_make_real (rx
/ yy
);
3551 } else if (SCM_COMPLEXP (y
)) {
3555 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3557 } else if (SCM_COMPLEXP (x
)) {
3558 double rx
= SCM_COMPLEX_REAL (x
);
3559 double ix
= SCM_COMPLEX_IMAG (x
);
3560 if (SCM_INUMP (y
)) {
3561 long int yy
= SCM_INUM (y
);
3562 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3564 scm_num_overflow (s_divide
);
3569 return scm_make_complex (rx
/ d
, ix
/ d
);
3571 } else if (SCM_BIGP (y
)) {
3572 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
3573 scm_remember_upto_here_1 (y
);
3574 return scm_make_complex (rx
/ dby
, ix
/ dby
);
3575 } else if (SCM_REALP (y
)) {
3576 double yy
= SCM_REAL_VALUE (y
);
3577 #ifndef ALLOW_DIVIDE_BY_ZERO
3579 scm_num_overflow (s_divide
);
3582 return scm_make_complex (rx
/ yy
, ix
/ yy
);
3583 } else if (SCM_COMPLEXP (y
)) {
3584 double ry
= SCM_COMPLEX_REAL (y
);
3585 double iy
= SCM_COMPLEX_IMAG (y
);
3588 double d
= iy
* (1.0 + t
* t
);
3589 return scm_make_complex ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
3592 double d
= ry
* (1.0 + t
* t
);
3593 return scm_make_complex ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
3596 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3599 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
3604 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
3605 /* "Return the inverse hyperbolic sine of @var{x}."
3608 scm_asinh (double x
)
3610 return log (x
+ sqrt (x
* x
+ 1));
3614 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
3615 /* "Return the inverse hyperbolic cosine of @var{x}."
3618 scm_acosh (double x
)
3620 return log (x
+ sqrt (x
* x
- 1));
3624 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
3625 /* "Return the inverse hyperbolic tangent of @var{x}."
3628 scm_atanh (double x
)
3630 return 0.5 * log ((1 + x
) / (1 - x
));
3634 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
3635 /* "Round the inexact number @var{x} towards zero."
3638 scm_truncate (double x
)
3646 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
3647 /* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
3648 * "numbers, round towards even."
3651 scm_round (double x
)
3653 double plus_half
= x
+ 0.5;
3654 double result
= floor (plus_half
);
3655 /* Adjust so that the scm_round is towards even. */
3656 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
3657 ? result
- 1 : result
;
3661 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
3662 /* "Round the number @var{x} towards minus infinity."
3664 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
3665 /* "Round the number @var{x} towards infinity."
3667 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
3668 /* "Return the square root of the real number @var{x}."
3670 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
3671 /* "Return the absolute value of the real number @var{x}."
3673 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
3674 /* "Return the @var{x}th power of e."
3676 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
3677 /* "Return the natural logarithm of the real number @var{x}."
3679 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
3680 /* "Return the sine of the real number @var{x}."
3682 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
3683 /* "Return the cosine of the real number @var{x}."
3685 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
3686 /* "Return the tangent of the real number @var{x}."
3688 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
3689 /* "Return the arc sine of the real number @var{x}."
3691 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
3692 /* "Return the arc cosine of the real number @var{x}."
3694 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
3695 /* "Return the arc tangent of the real number @var{x}."
3697 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
3698 /* "Return the hyperbolic sine of the real number @var{x}."
3700 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
3701 /* "Return the hyperbolic cosine of the real number @var{x}."
3703 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
3704 /* "Return the hyperbolic tangent of the real number @var{x}."
3712 static void scm_two_doubles (SCM x
,
3714 const char *sstring
,
3718 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
3720 if (SCM_INUMP (x
)) {
3721 xy
->x
= SCM_INUM (x
);
3722 } else if (SCM_BIGP (x
)) {
3723 xy
->x
= scm_i_big2dbl (x
);
3724 } else if (SCM_REALP (x
)) {
3725 xy
->x
= SCM_REAL_VALUE (x
);
3727 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
3730 if (SCM_INUMP (y
)) {
3731 xy
->y
= SCM_INUM (y
);
3732 } else if (SCM_BIGP (y
)) {
3733 xy
->y
= scm_i_big2dbl (y
);
3734 } else if (SCM_REALP (y
)) {
3735 xy
->y
= SCM_REAL_VALUE (y
);
3737 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
3742 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
3744 "Return @var{x} raised to the power of @var{y}. This\n"
3745 "procedure does not accept complex arguments.")
3746 #define FUNC_NAME s_scm_sys_expt
3749 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
3750 return scm_make_real (pow (xy
.x
, xy
.y
));
3755 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
3757 "Return the arc tangent of the two arguments @var{x} and\n"
3758 "@var{y}. This is similar to calculating the arc tangent of\n"
3759 "@var{x} / @var{y}, except that the signs of both arguments\n"
3760 "are used to determine the quadrant of the result. This\n"
3761 "procedure does not accept complex arguments.")
3762 #define FUNC_NAME s_scm_sys_atan2
3765 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
3766 return scm_make_real (atan2 (xy
.x
, xy
.y
));
3771 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
3772 (SCM real
, SCM imaginary
),
3773 "Return a complex number constructed of the given @var{real} and\n"
3774 "@var{imaginary} parts.")
3775 #define FUNC_NAME s_scm_make_rectangular
3778 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
3779 return scm_make_complex (xy
.x
, xy
.y
);
3785 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
3787 "Return the complex number @var{x} * e^(i * @var{y}).")
3788 #define FUNC_NAME s_scm_make_polar
3791 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
3792 return scm_make_complex (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
3797 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
3798 /* "Return the real part of the number @var{z}."
3801 scm_real_part (SCM z
)
3803 if (SCM_INUMP (z
)) {
3805 } else if (SCM_BIGP (z
)) {
3807 } else if (SCM_REALP (z
)) {
3809 } else if (SCM_COMPLEXP (z
)) {
3810 return scm_make_real (SCM_COMPLEX_REAL (z
));
3812 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
3817 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
3818 /* "Return the imaginary part of the number @var{z}."
3821 scm_imag_part (SCM z
)
3823 if (SCM_INUMP (z
)) {
3825 } else if (SCM_BIGP (z
)) {
3827 } else if (SCM_REALP (z
)) {
3829 } else if (SCM_COMPLEXP (z
)) {
3830 return scm_make_real (SCM_COMPLEX_IMAG (z
));
3832 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
3837 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
3838 /* "Return the magnitude of the number @var{z}. This is the same as\n"
3839 * "@code{abs} for real arguments, but also allows complex numbers."
3842 scm_magnitude (SCM z
)
3844 if (SCM_INUMP (z
)) {
3845 long int zz
= SCM_INUM (z
);
3848 } else if (SCM_POSFIXABLE (-zz
)) {
3849 return SCM_MAKINUM (-zz
);
3851 return scm_i_long2big (-zz
);
3853 } else if (SCM_BIGP (z
)) {
3854 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
3855 scm_remember_upto_here_1 (z
);
3857 return scm_i_clonebig (z
, 0);
3861 } else if (SCM_REALP (z
)) {
3862 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
3863 } else if (SCM_COMPLEXP (z
)) {
3864 double r
= SCM_COMPLEX_REAL (z
);
3865 double i
= SCM_COMPLEX_IMAG (z
);
3866 return scm_make_real (sqrt (i
* i
+ r
* r
));
3868 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
3873 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
3874 /* "Return the angle of the complex number @var{z}."
3879 if (SCM_INUMP (z
)) {
3880 if (SCM_INUM (z
) >= 0) {
3881 return scm_make_real (atan2 (0.0, 1.0));
3883 return scm_make_real (atan2 (0.0, -1.0));
3885 } else if (SCM_BIGP (z
)) {
3886 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
3887 scm_remember_upto_here_1 (z
);
3889 return scm_make_real (atan2 (0.0, -1.0));
3891 return scm_make_real (atan2 (0.0, 1.0));
3893 } else if (SCM_REALP (z
)) {
3894 return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z
)));
3895 } else if (SCM_COMPLEXP (z
)) {
3896 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
3898 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
3903 SCM_GPROC (s_exact_to_inexact
, "exact->inexact", 1, 0, 0, scm_exact_to_inexact
, g_exact_to_inexact
);
3904 /* Convert the number @var{x} to its inexact representation.\n"
3907 scm_exact_to_inexact (SCM z
)
3910 return scm_make_real ((double) SCM_INUM (z
));
3911 else if (SCM_BIGP (z
))
3912 return scm_make_real (scm_i_big2dbl (z
));
3913 else if (SCM_INEXACTP (z
))
3916 SCM_WTA_DISPATCH_1 (g_exact_to_inexact
, z
, 1, s_exact_to_inexact
);
3920 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
3922 "Return an exact number that is numerically closest to @var{z}.")
3923 #define FUNC_NAME s_scm_inexact_to_exact
3925 if (SCM_INUMP (z
)) {
3927 } else if (SCM_BIGP (z
)) {
3929 } else if (SCM_REALP (z
)) {
3930 double u
= floor (SCM_REAL_VALUE (z
) + 0.5);
3932 if (SCM_FIXABLE (lu
)) {
3933 return SCM_MAKINUM (lu
);
3934 } else if (isfinite (u
) && !xisnan (u
)) {
3935 return scm_i_dbl2big (u
);
3937 scm_num_overflow (s_scm_inexact_to_exact
);
3940 SCM_WRONG_TYPE_ARG (1, z
);
3945 /* if you need to change this, change test-num2integral.c as well */
3946 #if SCM_SIZEOF_LONG_LONG != 0
3948 # define ULLONG_MAX ((unsigned long long) (-1))
3949 # define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
3950 # define LLONG_MIN (~LLONG_MAX)
3954 /* Parameters for creating integer conversion routines.
3956 Define the following preprocessor macros before including
3957 "libguile/num2integral.i.c":
3959 NUM2INTEGRAL - the name of the function for converting from a
3960 Scheme object to the integral type. This function will be
3961 defined when including "num2integral.i.c".
3963 INTEGRAL2NUM - the name of the function for converting from the
3964 integral type to a Scheme object. This function will be defined.
3966 INTEGRAL2BIG - the name of an internal function that createas a
3967 bignum from the integral type. This function will be defined.
3968 The name should start with "scm_i_".
3970 ITYPE - the name of the integral type.
3972 UNSIGNED - Define this to 1 when ITYPE is an unsigned type. Define
3975 UNSIGNED_ITYPE - the name of the the unsigned variant of the
3976 integral type. If you don't define this, it defaults to
3977 "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned
3980 SIZEOF_ITYPE - an expression giving the size of the integral type
3981 in bytes. This expression must be computable by the
3982 preprocessor. (SIZEOF_FOO values are calculated by configure.in
3987 #define NUM2INTEGRAL scm_num2short
3988 #define INTEGRAL2NUM scm_short2num
3989 #define INTEGRAL2BIG scm_i_short2big
3992 #define SIZEOF_ITYPE SIZEOF_SHORT
3993 #include "libguile/num2integral.i.c"
3995 #define NUM2INTEGRAL scm_num2ushort
3996 #define INTEGRAL2NUM scm_ushort2num
3997 #define INTEGRAL2BIG scm_i_ushort2big
3999 #define ITYPE unsigned short
4000 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT
4001 #include "libguile/num2integral.i.c"
4003 #define NUM2INTEGRAL scm_num2int
4004 #define INTEGRAL2NUM scm_int2num
4005 #define INTEGRAL2BIG scm_i_int2big
4008 #define SIZEOF_ITYPE SIZEOF_INT
4009 #include "libguile/num2integral.i.c"
4011 #define NUM2INTEGRAL scm_num2uint
4012 #define INTEGRAL2NUM scm_uint2num
4013 #define INTEGRAL2BIG scm_i_uint2big
4015 #define ITYPE unsigned int
4016 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT
4017 #include "libguile/num2integral.i.c"
4019 #define NUM2INTEGRAL scm_num2long
4020 #define INTEGRAL2NUM scm_long2num
4021 #define INTEGRAL2BIG scm_i_long2big
4024 #define SIZEOF_ITYPE SIZEOF_LONG
4025 #include "libguile/num2integral.i.c"
4027 #define NUM2INTEGRAL scm_num2ulong
4028 #define INTEGRAL2NUM scm_ulong2num
4029 #define INTEGRAL2BIG scm_i_ulong2big
4031 #define ITYPE unsigned long
4032 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG
4033 #include "libguile/num2integral.i.c"
4035 #define NUM2INTEGRAL scm_num2ptrdiff
4036 #define INTEGRAL2NUM scm_ptrdiff2num
4037 #define INTEGRAL2BIG scm_i_ptrdiff2big
4039 #define ITYPE scm_t_ptrdiff
4040 #define UNSIGNED_ITYPE size_t
4041 #define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF
4042 #include "libguile/num2integral.i.c"
4044 #define NUM2INTEGRAL scm_num2size
4045 #define INTEGRAL2NUM scm_size2num
4046 #define INTEGRAL2BIG scm_i_size2big
4048 #define ITYPE size_t
4049 #define SIZEOF_ITYPE SIZEOF_SIZE_T
4050 #include "libguile/num2integral.i.c"
4052 #if SCM_SIZEOF_LONG_LONG != 0
4054 #ifndef ULONG_LONG_MAX
4055 #define ULONG_LONG_MAX (~0ULL)
4058 #define NUM2INTEGRAL scm_num2long_long
4059 #define INTEGRAL2NUM scm_long_long2num
4060 #define INTEGRAL2BIG scm_i_long_long2big
4062 #define ITYPE long long
4063 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
4064 #include "libguile/num2integral.i.c"
4066 #define NUM2INTEGRAL scm_num2ulong_long
4067 #define INTEGRAL2NUM scm_ulong_long2num
4068 #define INTEGRAL2BIG scm_i_ulong_long2big
4070 #define ITYPE unsigned long long
4071 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG
4072 #include "libguile/num2integral.i.c"
4074 #endif /* SCM_SIZEOF_LONG_LONG != 0 */
4076 #define NUM2FLOAT scm_num2float
4077 #define FLOAT2NUM scm_float2num
4079 #include "libguile/num2float.i.c"
4081 #define NUM2FLOAT scm_num2double
4082 #define FLOAT2NUM scm_double2num
4083 #define FTYPE double
4084 #include "libguile/num2float.i.c"
4089 #define SIZE_MAX ((size_t) (-1))
4092 #define PTRDIFF_MIN \
4093 ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 \
4094 << ((sizeof (scm_t_ptrdiff) * SCM_CHAR_BIT) - 1)))
4097 #define PTRDIFF_MAX (~ PTRDIFF_MIN)
4100 #define CHECK(type, v) \
4102 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
4121 CHECK (ptrdiff
, -1);
4123 CHECK (short, SHRT_MAX
);
4124 CHECK (short, SHRT_MIN
);
4125 CHECK (ushort
, USHRT_MAX
);
4126 CHECK (int, INT_MAX
);
4127 CHECK (int, INT_MIN
);
4128 CHECK (uint
, UINT_MAX
);
4129 CHECK (long, LONG_MAX
);
4130 CHECK (long, LONG_MIN
);
4131 CHECK (ulong
, ULONG_MAX
);
4132 CHECK (size
, SIZE_MAX
);
4133 CHECK (ptrdiff
, PTRDIFF_MAX
);
4134 CHECK (ptrdiff
, PTRDIFF_MIN
);
4136 #if SCM_SIZEOF_LONG_LONG != 0
4137 CHECK (long_long
, 0LL);
4138 CHECK (ulong_long
, 0ULL);
4139 CHECK (long_long
, -1LL);
4140 CHECK (long_long
, LLONG_MAX
);
4141 CHECK (long_long
, LLONG_MIN
);
4142 CHECK (ulong_long
, ULLONG_MAX
);
4149 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
4150 if (!SCM_FALSEP (data)) abort();
4153 check_body (void *data
)
4155 SCM num
= *(SCM
*) data
;
4156 scm_num2ulong (num
, 1, NULL
);
4158 return SCM_UNSPECIFIED
;
4162 check_handler (void *data
, SCM tag
, SCM throw_args
)
4164 SCM
*num
= (SCM
*) data
;
4167 return SCM_UNSPECIFIED
;
4170 SCM_DEFINE (scm_sys_check_number_conversions
, "%check-number-conversions", 0, 0, 0,
4172 "Number conversion sanity checking.")
4173 #define FUNC_NAME s_scm_sys_check_number_conversions
4175 SCM data
= SCM_MAKINUM (-1);
4177 data
= scm_int2num (INT_MIN
);
4179 data
= scm_ulong2num (ULONG_MAX
);
4180 data
= scm_difference (SCM_INUM0
, data
);
4182 data
= scm_ulong2num (ULONG_MAX
);
4183 data
= scm_sum (SCM_MAKINUM (1), data
); data
= scm_difference (SCM_INUM0
, data
);
4185 data
= scm_int2num (-10000); data
= scm_product (data
, data
); data
= scm_product (data
, data
);
4188 return SCM_UNSPECIFIED
;
4197 abs_most_negative_fixnum
= scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM
);
4198 scm_permanent_object (abs_most_negative_fixnum
);
4200 /* It may be possible to tune the performance of some algorithms by using
4201 * the following constants to avoid the creation of bignums. Please, before
4202 * using these values, remember the two rules of program optimization:
4203 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
4204 scm_c_define ("most-positive-fixnum",
4205 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
4206 scm_c_define ("most-negative-fixnum",
4207 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
4209 scm_add_feature ("complex");
4210 scm_add_feature ("inexact");
4211 scm_flo0
= scm_make_real (0.0);
4213 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4215 { /* determine floating point precision */
4217 double fsum
= 1.0 + f
;
4218 while (fsum
!= 1.0) {
4219 if (++scm_dblprec
> 20) {
4226 scm_dblprec
= scm_dblprec
- 1;
4228 #endif /* DBL_DIG */
4234 #include "libguile/numbers.x"