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.
42 /* tell glibc (2.3) to give prototype for C99 trunc() */
53 #include "libguile/_scm.h"
54 #include "libguile/feature.h"
55 #include "libguile/ports.h"
56 #include "libguile/root.h"
57 #include "libguile/smob.h"
58 #include "libguile/strings.h"
60 #include "libguile/validate.h"
61 #include "libguile/numbers.h"
62 #include "libguile/deprecation.h"
67 Wonder if this might be faster for some of our code? A switch on
68 the numtag would jump directly to the right case, and the
69 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
71 #define SCM_I_NUMTAG_NOTNUM 0
72 #define SCM_I_NUMTAG_INUM 1
73 #define SCM_I_NUMTAG_BIG scm_tc16_big
74 #define SCM_I_NUMTAG_REAL scm_tc16_real
75 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
76 #define SCM_I_NUMTAG(x) \
77 (SCM_INUMP(x) ? SCM_I_NUMTAG_INUM \
78 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
79 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_smob) ? SCM_TYP16(x) \
80 : SCM_I_NUMTAG_NOTNUM)))
84 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
86 /* FLOBUFLEN is the maximum number of characters neccessary for the
87 * printed or scm_string representation of an inexact number.
89 #define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
92 #if ! defined (HAVE_ISNAN)
97 return (IsNANorINF (x
) && NaN (x
) && ! IsINF (x
)) ? 1 : 0;
100 #if ! defined (HAVE_ISINF)
105 return (IsNANorINF (x
) && IsINF (x
)) ? 1 : 0;
112 /* mpz_cmp_d only recognises infinities in gmp 4.2 and up.
113 For prior versions use an explicit check here. */
114 #if __GNU_MP_VERSION < 4 \
115 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2)
116 #define xmpz_cmp_d(z, d) \
117 (xisinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
119 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
124 static SCM abs_most_negative_fixnum
;
125 static mpz_t z_negative_one
;
129 static const char s_bignum
[] = "bignum";
131 SCM_C_INLINE_KEYWORD SCM
134 /* Return a newly created bignum. */
135 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
136 mpz_init (SCM_I_BIG_MPZ (z
));
140 SCM_C_INLINE_KEYWORD
static SCM
141 scm_i_clonebig (SCM src_big
, int same_sign_p
)
143 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
144 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
145 mpz_init_set (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (src_big
));
147 mpz_neg (SCM_I_BIG_MPZ (z
), SCM_I_BIG_MPZ (z
));
151 SCM_C_INLINE_KEYWORD
int
152 scm_i_bigcmp (SCM x
, SCM y
)
154 /* Return neg if x < y, pos if x > y, and 0 if x == y */
155 /* presume we already know x and y are bignums */
156 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
157 scm_remember_upto_here_2 (x
, y
);
161 SCM_C_INLINE_KEYWORD SCM
162 scm_i_dbl2big (double d
)
164 /* results are only defined if d is an integer */
165 SCM z
= scm_double_cell (scm_tc16_big
, 0, 0, 0);
166 mpz_init_set_d (SCM_I_BIG_MPZ (z
), d
);
170 SCM_C_INLINE_KEYWORD
double
171 scm_i_big2dbl (SCM b
)
173 double result
= mpz_get_d (SCM_I_BIG_MPZ (b
));
174 scm_remember_upto_here_1 (b
);
178 SCM_C_INLINE_KEYWORD SCM
179 scm_i_normbig (SCM b
)
181 /* convert a big back to a fixnum if it'll fit */
182 /* presume b is a bignum */
183 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b
)))
185 long val
= mpz_get_si (SCM_I_BIG_MPZ (b
));
186 if (SCM_FIXABLE (val
))
187 b
= SCM_MAKINUM (val
);
192 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
194 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
196 #define FUNC_NAME s_scm_exact_p
207 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
209 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
211 #define FUNC_NAME s_scm_odd_p
215 long val
= SCM_INUM (n
);
216 return SCM_BOOL ((val
& 1L) != 0);
218 else if (SCM_BIGP (n
))
220 int odd_p
= mpz_odd_p (SCM_I_BIG_MPZ (n
));
221 scm_remember_upto_here_1 (n
);
222 return SCM_BOOL (odd_p
);
224 else if (!SCM_FALSEP (scm_inf_p (n
)))
227 SCM_WRONG_TYPE_ARG (1, n
);
232 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
234 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
236 #define FUNC_NAME s_scm_even_p
240 long val
= SCM_INUM (n
);
241 return SCM_BOOL ((val
& 1L) == 0);
243 else if (SCM_BIGP (n
))
245 int even_p
= mpz_even_p (SCM_I_BIG_MPZ (n
));
246 scm_remember_upto_here_1 (n
);
247 return SCM_BOOL (even_p
);
249 else if (!SCM_FALSEP (scm_inf_p (n
)))
252 SCM_WRONG_TYPE_ARG (1, n
);
259 #if defined (HAVE_ISINF)
261 #elif defined (HAVE_FINITE) && defined (HAVE_ISNAN)
262 return (! (finite (x
) || isnan (x
)));
271 #if defined (HAVE_ISNAN)
278 SCM_DEFINE (scm_inf_p
, "inf?", 1, 0, 0,
280 "Return @code{#t} if @var{n} is infinite, @code{#f}\n"
282 #define FUNC_NAME s_scm_inf_p
285 return SCM_BOOL (xisinf (SCM_REAL_VALUE (n
)));
286 else if (SCM_COMPLEXP (n
))
287 return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n
))
288 || xisinf (SCM_COMPLEX_IMAG (n
)));
294 SCM_DEFINE (scm_nan_p
, "nan?", 1, 0, 0,
296 "Return @code{#t} if @var{n} is a NaN, @code{#f}\n"
298 #define FUNC_NAME s_scm_nan_p
301 return SCM_BOOL (xisnan (SCM_REAL_VALUE (n
)));
302 else if (SCM_COMPLEXP (n
))
303 return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n
))
304 || xisnan (SCM_COMPLEX_IMAG (n
)));
310 /* Guile's idea of infinity. */
311 static double guile_Inf
;
313 /* Guile's idea of not a number. */
314 static double guile_NaN
;
317 guile_ieee_init (void)
319 #if defined (HAVE_ISINF) || defined (HAVE_FINITE)
321 /* Some version of gcc on some old version of Linux used to crash when
322 trying to make Inf and NaN. */
326 guile_Inf
= 1.0 / (tmp
- tmp
);
327 #elif defined (__alpha__) && ! defined (linux)
328 extern unsigned int DINFINITY
[2];
329 guile_Inf
= (*(X_CAST(double *, DINFINITY
)));
336 if (guile_Inf
== tmp
)
344 #if defined (HAVE_ISNAN)
346 #if defined (__alpha__) && ! defined (linux)
347 extern unsigned int DQNAN
[2];
348 guile_NaN
= (*(X_CAST(double *, DQNAN
)));
350 guile_NaN
= guile_Inf
/ guile_Inf
;
356 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
359 #define FUNC_NAME s_scm_inf
361 static int initialized
= 0;
367 return scm_make_real (guile_Inf
);
371 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
374 #define FUNC_NAME s_scm_nan
376 static int initialized
= 0;
382 return scm_make_real (guile_NaN
);
387 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
389 "Return the absolute value of @var{x}.")
394 long int xx
= SCM_INUM (x
);
397 else if (SCM_POSFIXABLE (-xx
))
398 return SCM_MAKINUM (-xx
);
400 return scm_i_long2big (-xx
);
402 else if (SCM_BIGP (x
))
404 const int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
406 return scm_i_clonebig (x
, 0);
410 else if (SCM_REALP (x
))
411 return scm_make_real (fabs (SCM_REAL_VALUE (x
)));
413 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
418 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
419 /* "Return the quotient of the numbers @var{x} and @var{y}."
422 scm_quotient (SCM x
, SCM y
)
426 long xx
= SCM_INUM (x
);
429 long yy
= SCM_INUM (y
);
431 scm_num_overflow (s_quotient
);
436 return SCM_MAKINUM (z
);
438 return scm_i_long2big (z
);
441 else if (SCM_BIGP (y
))
443 if ((SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
)
444 && (scm_i_bigcmp (abs_most_negative_fixnum
, y
) == 0))
445 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
446 return SCM_MAKINUM (-1);
448 return SCM_MAKINUM (0);
451 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
453 else if (SCM_BIGP (x
))
457 long yy
= SCM_INUM (y
);
459 scm_num_overflow (s_quotient
);
464 SCM result
= scm_i_mkbig ();
467 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result
),
470 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
473 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
474 scm_remember_upto_here_1 (x
);
475 return scm_i_normbig (result
);
478 else if (SCM_BIGP (y
))
480 SCM result
= scm_i_mkbig ();
481 mpz_tdiv_q (SCM_I_BIG_MPZ (result
),
484 scm_remember_upto_here_2 (x
, y
);
485 return scm_i_normbig (result
);
488 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
491 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
494 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
495 /* "Return the remainder of the numbers @var{x} and @var{y}.\n"
497 * "(remainder 13 4) @result{} 1\n"
498 * "(remainder -13 4) @result{} -1\n"
502 scm_remainder (SCM x
, SCM y
)
508 long yy
= SCM_INUM (y
);
510 scm_num_overflow (s_remainder
);
513 long z
= SCM_INUM (x
) % yy
;
514 return SCM_MAKINUM (z
);
517 else if (SCM_BIGP (y
))
519 if ((SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
)
520 && (scm_i_bigcmp (abs_most_negative_fixnum
, y
) == 0))
521 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
522 return SCM_MAKINUM (0);
527 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
529 else if (SCM_BIGP (x
))
533 long yy
= SCM_INUM (y
);
535 scm_num_overflow (s_remainder
);
538 SCM result
= scm_i_mkbig ();
541 mpz_tdiv_r_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ(x
), yy
);
542 scm_remember_upto_here_1 (x
);
543 return scm_i_normbig (result
);
546 else if (SCM_BIGP (y
))
548 SCM result
= scm_i_mkbig ();
549 mpz_tdiv_r (SCM_I_BIG_MPZ (result
),
552 scm_remember_upto_here_2 (x
, y
);
553 return scm_i_normbig (result
);
556 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
559 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
563 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
564 /* "Return the modulo of the numbers @var{x} and @var{y}.\n"
566 * "(modulo 13 4) @result{} 1\n"
567 * "(modulo -13 4) @result{} 3\n"
571 scm_modulo (SCM x
, SCM y
)
575 long xx
= SCM_INUM (x
);
578 long yy
= SCM_INUM (y
);
580 scm_num_overflow (s_modulo
);
583 /* FIXME: I think this may be a bug on some arches -- results
584 of % with negative second arg are undefined... */
602 return SCM_MAKINUM (result
);
605 else if (SCM_BIGP (y
))
607 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
610 scm_num_overflow (s_modulo
);
618 SCM pos_y
= scm_i_clonebig (y
, 0);
619 /* do this after the last scm_op */
620 mpz_init_set_si (z_x
, xx
);
621 result
= pos_y
; /* re-use this bignum */
622 mpz_mod (SCM_I_BIG_MPZ (result
),
624 SCM_I_BIG_MPZ (pos_y
));
625 scm_remember_upto_here_1 (pos_y
);
629 result
= scm_i_mkbig ();
630 /* do this after the last scm_op */
631 mpz_init_set_si (z_x
, xx
);
632 mpz_mod (SCM_I_BIG_MPZ (result
),
635 scm_remember_upto_here_1 (y
);
638 if ((sgn_y
< 0) && mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0)
639 mpz_add (SCM_I_BIG_MPZ (result
),
641 SCM_I_BIG_MPZ (result
));
642 scm_remember_upto_here_1 (y
);
643 /* and do this before the next one */
645 return scm_i_normbig (result
);
649 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
651 else if (SCM_BIGP (x
))
655 long yy
= SCM_INUM (y
);
657 scm_num_overflow (s_modulo
);
660 SCM result
= scm_i_mkbig ();
661 mpz_mod_ui (SCM_I_BIG_MPZ (result
),
663 (yy
< 0) ? - yy
: yy
);
664 scm_remember_upto_here_1 (x
);
665 if ((yy
< 0) && (mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0))
666 mpz_sub_ui (SCM_I_BIG_MPZ (result
),
667 SCM_I_BIG_MPZ (result
),
669 return scm_i_normbig (result
);
672 else if (SCM_BIGP (y
))
674 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
676 scm_num_overflow (s_modulo
);
679 SCM result
= scm_i_mkbig ();
680 int y_sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
681 SCM pos_y
= scm_i_clonebig (y
, y_sgn
>= 0);
682 mpz_mod (SCM_I_BIG_MPZ (result
),
684 SCM_I_BIG_MPZ (pos_y
));
686 scm_remember_upto_here_1 (x
);
687 if ((y_sgn
< 0) && (mpz_sgn (SCM_I_BIG_MPZ (result
)) != 0))
688 mpz_add (SCM_I_BIG_MPZ (result
),
690 SCM_I_BIG_MPZ (result
));
691 scm_remember_upto_here_2 (y
, pos_y
);
692 return scm_i_normbig (result
);
696 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
699 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
702 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
703 /* "Return the greatest common divisor of all arguments.\n"
704 * "If called without arguments, 0 is returned."
707 scm_gcd (SCM x
, SCM y
)
710 return SCM_UNBNDP (x
) ? SCM_INUM0
: x
;
716 long xx
= SCM_INUM (x
);
717 long yy
= SCM_INUM (y
);
718 long u
= xx
< 0 ? -xx
: xx
;
719 long v
= yy
< 0 ? -yy
: yy
;
729 /* Determine a common factor 2^k */
730 while (!(1 & (u
| v
)))
736 /* Now, any factor 2^n can be eliminated */
756 return (SCM_POSFIXABLE (result
)
757 ? SCM_MAKINUM (result
)
758 : scm_i_long2big (result
));
760 else if (SCM_BIGP (y
))
762 SCM result
= scm_i_mkbig ();
763 SCM mx
= scm_i_mkbig ();
764 mpz_set_si (SCM_I_BIG_MPZ (mx
), SCM_INUM (x
));
765 scm_remember_upto_here_1 (x
);
766 mpz_gcd (SCM_I_BIG_MPZ (result
),
769 scm_remember_upto_here_2 (mx
, y
);
770 return scm_i_normbig (result
);
773 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
775 else if (SCM_BIGP (x
))
779 unsigned long result
;
780 long yy
= SCM_INUM (y
);
785 result
= mpz_gcd_ui (NULL
, SCM_I_BIG_MPZ (x
), yy
);
786 scm_remember_upto_here_1 (x
);
787 return (SCM_POSFIXABLE (result
)
788 ? SCM_MAKINUM (result
)
789 : scm_ulong2num (result
));
791 else if (SCM_BIGP (y
))
793 SCM result
= scm_i_mkbig ();
794 mpz_gcd (SCM_I_BIG_MPZ (result
),
797 scm_remember_upto_here_2 (x
, y
);
798 return scm_i_normbig (result
);
801 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
804 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
807 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
808 /* "Return the least common multiple of the arguments.\n"
809 * "If called without arguments, 1 is returned."
812 scm_lcm (SCM n1
, SCM n2
)
817 return SCM_MAKINUM (1L);
818 n2
= SCM_MAKINUM (1L);
821 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
822 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
823 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
824 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
830 SCM d
= scm_gcd (n1
, n2
);
831 if (SCM_EQ_P (d
, SCM_INUM0
))
834 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
838 /* inum n1, big n2 */
841 SCM result
= scm_i_mkbig ();
842 long nn1
= SCM_INUM (n1
);
843 if (nn1
== 0) return SCM_INUM0
;
844 if (nn1
< 0) nn1
= - nn1
;
845 mpz_lcm_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n2
), nn1
);
846 scm_remember_upto_here_1 (n2
);
861 SCM result
= scm_i_mkbig ();
862 mpz_lcm(SCM_I_BIG_MPZ (result
),
865 scm_remember_upto_here_2(n1
, n2
);
866 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
873 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
875 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
878 /* Emulating 2's complement bignums with sign magnitude arithmetic:
883 + + + x (map digit:logand X Y)
884 + - + x (map digit:logand X (lognot (+ -1 Y)))
885 - + + y (map digit:logand (lognot (+ -1 X)) Y)
886 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
891 + + + (map digit:logior X Y)
892 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
893 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
894 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
899 + + + (map digit:logxor X Y)
900 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
901 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
902 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
907 + + (any digit:logand X Y)
908 + - (any digit:logand X (lognot (+ -1 Y)))
909 - + (any digit:logand (lognot (+ -1 X)) Y)
914 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
916 "Return the bitwise AND of the integer arguments.\n\n"
918 "(logand) @result{} -1\n"
919 "(logand 7) @result{} 7\n"
920 "(logand #b111 #b011 #\b001) @result{} 1\n"
922 #define FUNC_NAME s_scm_logand
929 return SCM_MAKINUM (-1);
930 else if (!SCM_NUMBERP (n1
))
931 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
932 else if (SCM_NUMBERP (n1
))
935 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
943 long nn2
= SCM_INUM (n2
);
944 return SCM_MAKINUM (nn1
& nn2
);
946 else if SCM_BIGP (n2
)
952 SCM result_z
= scm_i_mkbig ();
954 mpz_init_set_si (nn1_z
, nn1
);
955 mpz_and (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
956 scm_remember_upto_here_1 (n2
);
958 return scm_i_normbig (result_z
);
962 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
964 else if (SCM_BIGP (n1
))
972 else if (SCM_BIGP (n2
))
974 SCM result_z
= scm_i_mkbig ();
975 mpz_and (SCM_I_BIG_MPZ (result_z
),
978 scm_remember_upto_here_2 (n1
, n2
);
979 return scm_i_normbig (result_z
);
982 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
985 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
990 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
992 "Return the bitwise OR of the integer arguments.\n\n"
994 "(logior) @result{} 0\n"
995 "(logior 7) @result{} 7\n"
996 "(logior #b000 #b001 #b011) @result{} 3\n"
998 #define FUNC_NAME s_scm_logior
1002 if (SCM_UNBNDP (n2
))
1004 if (SCM_UNBNDP (n1
))
1006 else if (SCM_NUMBERP (n1
))
1009 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1014 nn1
= SCM_INUM (n1
);
1017 long nn2
= SCM_INUM (n2
);
1018 return SCM_MAKINUM (nn1
| nn2
);
1020 else if (SCM_BIGP (n2
))
1026 SCM result_z
= scm_i_mkbig ();
1028 mpz_init_set_si (nn1_z
, nn1
);
1029 mpz_ior (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
1030 scm_remember_upto_here_1 (n2
);
1036 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1038 else if (SCM_BIGP (n1
))
1043 nn1
= SCM_INUM (n1
);
1046 else if (SCM_BIGP (n2
))
1048 SCM result_z
= scm_i_mkbig ();
1049 mpz_ior (SCM_I_BIG_MPZ (result_z
),
1051 SCM_I_BIG_MPZ (n2
));
1052 scm_remember_upto_here_2 (n1
, n2
);
1056 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1059 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1064 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
1066 "Return the bitwise XOR of the integer arguments. A bit is\n"
1067 "set in the result if it is set in an odd number of arguments.\n"
1069 "(logxor) @result{} 0\n"
1070 "(logxor 7) @result{} 7\n"
1071 "(logxor #b000 #b001 #b011) @result{} 2\n"
1072 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
1074 #define FUNC_NAME s_scm_logxor
1078 if (SCM_UNBNDP (n2
))
1080 if (SCM_UNBNDP (n1
))
1082 else if (SCM_NUMBERP (n1
))
1085 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1090 nn1
= SCM_INUM (n1
);
1093 long nn2
= SCM_INUM (n2
);
1094 return SCM_MAKINUM (nn1
^ nn2
);
1096 else if (SCM_BIGP (n2
))
1100 SCM result_z
= scm_i_mkbig ();
1102 mpz_init_set_si (nn1_z
, nn1
);
1103 mpz_xor (SCM_I_BIG_MPZ (result_z
), nn1_z
, SCM_I_BIG_MPZ (n2
));
1104 scm_remember_upto_here_1 (n2
);
1106 return scm_i_normbig (result_z
);
1110 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1112 else if (SCM_BIGP (n1
))
1117 nn1
= SCM_INUM (n1
);
1120 else if (SCM_BIGP (n2
))
1122 SCM result_z
= scm_i_mkbig ();
1123 mpz_xor (SCM_I_BIG_MPZ (result_z
),
1125 SCM_I_BIG_MPZ (n2
));
1126 scm_remember_upto_here_2 (n1
, n2
);
1127 return scm_i_normbig (result_z
);
1130 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1133 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1138 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
1141 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
1142 "(logtest #b0100 #b1011) @result{} #f\n"
1143 "(logtest #b0100 #b0111) @result{} #t\n"
1145 #define FUNC_NAME s_scm_logtest
1154 long nk
= SCM_INUM (k
);
1155 return SCM_BOOL (nj
& nk
);
1157 else if (SCM_BIGP (k
))
1165 mpz_init_set_si (nj_z
, nj
);
1166 mpz_and (nj_z
, nj_z
, SCM_I_BIG_MPZ (k
));
1167 scm_remember_upto_here_1 (k
);
1168 result
= SCM_BOOL (mpz_sgn (nj_z
) != 0);
1174 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1176 else if (SCM_BIGP (j
))
1184 else if (SCM_BIGP (k
))
1188 mpz_init (result_z
);
1192 scm_remember_upto_here_2 (j
, k
);
1193 result
= SCM_BOOL (mpz_sgn (result_z
) != 0);
1194 mpz_clear (result_z
);
1198 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1201 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
1206 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
1209 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1210 "(logbit? 0 #b1101) @result{} #t\n"
1211 "(logbit? 1 #b1101) @result{} #f\n"
1212 "(logbit? 2 #b1101) @result{} #t\n"
1213 "(logbit? 3 #b1101) @result{} #t\n"
1214 "(logbit? 4 #b1101) @result{} #f\n"
1216 #define FUNC_NAME s_scm_logbit_p
1218 unsigned long int iindex
;
1220 SCM_VALIDATE_INUM_MIN (SCM_ARG1
, index
, 0);
1221 iindex
= (unsigned long int) SCM_INUM (index
);
1224 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1225 else if (SCM_BIGP (j
))
1227 int val
= mpz_tstbit (SCM_I_BIG_MPZ (j
), iindex
);
1228 scm_remember_upto_here_1 (j
);
1229 return SCM_BOOL (val
);
1232 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1237 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1239 "Return the integer which is the 2s-complement of the integer\n"
1243 "(number->string (lognot #b10000000) 2)\n"
1244 " @result{} \"-10000001\"\n"
1245 "(number->string (lognot #b0) 2)\n"
1246 " @result{} \"-1\"\n"
1248 #define FUNC_NAME s_scm_lognot
1250 if (SCM_INUMP (n
)) {
1251 /* No overflow here, just need to toggle all the bits making up the inum.
1252 Enhancement: No need to strip the tag and add it back, could just xor
1253 a block of 1 bits, if that worked with the various debug versions of
1255 return SCM_MAKINUM (~ SCM_INUM (n
));
1257 } else if (SCM_BIGP (n
)) {
1258 SCM result
= scm_i_mkbig ();
1259 mpz_com (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (n
));
1260 scm_remember_upto_here_1 (n
);
1264 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1269 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1271 "Return @var{n} raised to the non-negative integer exponent\n"
1275 "(integer-expt 2 5)\n"
1277 "(integer-expt -3 3)\n"
1280 #define FUNC_NAME s_scm_integer_expt
1283 SCM z_i2
= SCM_BOOL_F
;
1285 SCM acc
= SCM_MAKINUM (1L);
1287 /* 0^0 == 1 according to R5RS */
1288 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1289 return SCM_FALSEP (scm_zero_p(k
)) ? n
: acc
;
1290 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1291 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1295 else if (SCM_BIGP (k
))
1297 z_i2
= scm_i_clonebig (k
, 1);
1298 mpz_init_set (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (k
));
1299 scm_remember_upto_here_1 (k
);
1302 else if (SCM_REALP (k
))
1304 double r
= SCM_REAL_VALUE (k
);
1306 SCM_WRONG_TYPE_ARG (2, k
);
1307 if ((r
> SCM_MOST_POSITIVE_FIXNUM
) || (r
< SCM_MOST_NEGATIVE_FIXNUM
))
1309 z_i2
= scm_i_mkbig ();
1310 mpz_init_set_d (SCM_I_BIG_MPZ (z_i2
), r
);
1319 SCM_WRONG_TYPE_ARG (2, k
);
1323 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == -1)
1325 mpz_neg (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
));
1326 n
= scm_divide (n
, SCM_UNDEFINED
);
1330 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2
)) == 0)
1332 mpz_clear (SCM_I_BIG_MPZ (z_i2
));
1335 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2
), 1) == 0)
1337 mpz_clear (SCM_I_BIG_MPZ (z_i2
));
1338 return scm_product (acc
, n
);
1340 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2
), 0))
1341 acc
= scm_product (acc
, n
);
1342 n
= scm_product (n
, n
);
1343 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2
), SCM_I_BIG_MPZ (z_i2
), 1);
1351 n
= scm_divide (n
, SCM_UNDEFINED
);
1358 return scm_product (acc
, n
);
1360 acc
= scm_product (acc
, n
);
1361 n
= scm_product (n
, n
);
1368 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1370 "The function ash performs an arithmetic shift left by @var{cnt}\n"
1371 "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n"
1372 "means, that the function does not guarantee to keep the bit\n"
1373 "structure of @var{n}, but rather guarantees that the result\n"
1374 "will always be rounded towards minus infinity. Therefore, the\n"
1375 "results of ash and a corresponding bitwise shift will differ if\n"
1376 "@var{n} is negative.\n"
1378 "Formally, the function returns an integer equivalent to\n"
1379 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n"
1382 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1383 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
1385 #define FUNC_NAME s_scm_ash
1389 SCM_VALIDATE_INUM (2, cnt
);
1391 bits_to_shift
= SCM_INUM (cnt
);
1393 if (bits_to_shift
< 0)
1395 /* Shift right by abs(cnt) bits. This is realized as a division
1396 by div:=2^abs(cnt). However, to guarantee the floor
1397 rounding, negative values require some special treatment.
1399 SCM div
= scm_integer_expt (SCM_MAKINUM (2),
1400 SCM_MAKINUM (-bits_to_shift
));
1401 if (SCM_FALSEP (scm_negative_p (n
)))
1402 return scm_quotient (n
, div
);
1404 return scm_sum (SCM_MAKINUM (-1L),
1405 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1408 /* Shift left is done by multiplication with 2^CNT */
1409 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1414 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1415 (SCM n
, SCM start
, SCM end
),
1416 "Return the integer composed of the @var{start} (inclusive)\n"
1417 "through @var{end} (exclusive) bits of @var{n}. The\n"
1418 "@var{start}th bit becomes the 0-th bit in the result.\n"
1421 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1422 " @result{} \"1010\"\n"
1423 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1424 " @result{} \"10110\"\n"
1426 #define FUNC_NAME s_scm_bit_extract
1428 unsigned long int istart
, iend
;
1429 SCM_VALIDATE_INUM_MIN_COPY (2, start
,0, istart
);
1430 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1431 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1435 long int in
= SCM_INUM (n
);
1436 unsigned long int bits
= iend
- istart
;
1438 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
1440 /* Since we emulate two's complement encoded numbers, this
1441 * special case requires us to produce a result that has
1442 * more bits than can be stored in a fixnum. Thus, we fall
1443 * back to the more general algorithm that is used for
1449 if (istart
< SCM_I_FIXNUM_BIT
)
1452 if (bits
< SCM_I_FIXNUM_BIT
)
1453 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1454 else /* we know: in >= 0 */
1455 return SCM_MAKINUM (in
);
1458 return SCM_MAKINUM (-1L & ((1L << bits
) - 1));
1460 return SCM_MAKINUM (0);
1462 else if (SCM_BIGP (n
))
1466 SCM num1
= SCM_MAKINUM (1L);
1467 SCM num2
= SCM_MAKINUM (2L);
1468 SCM bits
= SCM_MAKINUM (iend
- istart
);
1469 SCM mask
= scm_difference (scm_integer_expt (num2
, bits
), num1
);
1470 return scm_logand (mask
, scm_ash (n
, SCM_MAKINUM (-istart
)));
1474 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1478 static const char scm_logtab
[] = {
1479 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1482 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1484 "Return the number of bits in integer @var{n}. If integer is\n"
1485 "positive, the 1-bits in its binary representation are counted.\n"
1486 "If negative, the 0-bits in its two's-complement binary\n"
1487 "representation are counted. If 0, 0 is returned.\n"
1490 "(logcount #b10101010)\n"
1497 #define FUNC_NAME s_scm_logcount
1501 unsigned long int c
= 0;
1502 long int nn
= SCM_INUM (n
);
1507 c
+= scm_logtab
[15 & nn
];
1510 return SCM_MAKINUM (c
);
1512 else if (SCM_BIGP (n
))
1514 unsigned long count
;
1515 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) >= 0)
1516 count
= mpz_popcount (SCM_I_BIG_MPZ (n
));
1518 count
= mpz_hamdist (SCM_I_BIG_MPZ (n
), z_negative_one
);
1519 scm_remember_upto_here_1 (n
);
1520 return SCM_MAKINUM (count
);
1523 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1528 static const char scm_ilentab
[] = {
1529 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1533 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1535 "Return the number of bits necessary to represent @var{n}.\n"
1538 "(integer-length #b10101010)\n"
1540 "(integer-length 0)\n"
1542 "(integer-length #b1111)\n"
1545 #define FUNC_NAME s_scm_integer_length
1549 unsigned long int c
= 0;
1551 long int nn
= SCM_INUM (n
);
1557 l
= scm_ilentab
[15 & nn
];
1560 return SCM_MAKINUM (c
- 4 + l
);
1562 else if (SCM_BIGP (n
))
1564 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
1565 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
1566 1 too big, so check for that and adjust. */
1567 size_t size
= mpz_sizeinbase (SCM_I_BIG_MPZ (n
), 2);
1568 if (mpz_sgn (SCM_I_BIG_MPZ (n
)) < 0
1569 && mpz_scan0 (SCM_I_BIG_MPZ (n
), /* no 0 bits above the lowest 1 */
1570 mpz_scan1 (SCM_I_BIG_MPZ (n
), 0)) == ULONG_MAX
)
1572 scm_remember_upto_here_1 (n
);
1573 return SCM_MAKINUM (size
);
1576 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1580 /*** NUMBERS -> STRINGS ***/
1582 static const double fx
[] =
1583 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1584 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1585 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1586 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1589 idbl2str (double f
, char *a
)
1591 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1597 #ifdef HAVE_COPYSIGN
1598 double sgn
= copysign (1.0, f
);
1604 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1610 strcpy (a
, "-inf.0");
1612 strcpy (a
, "+inf.0");
1615 else if (xisnan (f
))
1617 strcpy (a
, "+nan.0");
1627 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1628 make-uniform-vector, from causing infinite loops. */
1632 if (exp
-- < DBL_MIN_10_EXP
)
1643 if (exp
++ > DBL_MAX_10_EXP
)
1663 if (f
+ fx
[wp
] >= 10.0)
1670 dpt
= (exp
+ 9999) % 3;
1674 efmt
= (exp
< -3) || (exp
> wp
+ 2);
1699 if (f
+ fx
[wp
] >= 1.0)
1713 if ((dpt
> 4) && (exp
> 6))
1715 d
= (a
[0] == '-' ? 2 : 1);
1716 for (i
= ch
++; i
> d
; i
--)
1729 if (a
[ch
- 1] == '.')
1730 a
[ch
++] = '0'; /* trailing zero */
1739 for (i
= 10; i
<= exp
; i
*= 10);
1740 for (i
/= 10; i
; i
/= 10)
1742 a
[ch
++] = exp
/ i
+ '0';
1751 iflo2str (SCM flt
, char *str
)
1754 if (SCM_REALP (flt
))
1755 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
1758 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
1759 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
1761 double imag
= SCM_COMPLEX_IMAG (flt
);
1762 /* Don't output a '+' for negative numbers or for Inf and
1763 NaN. They will provide their own sign. */
1764 if (0 <= imag
&& !xisinf (imag
) && !xisnan (imag
))
1766 i
+= idbl2str (imag
, &str
[i
]);
1773 /* convert a long to a string (unterminated). returns the number of
1774 characters in the result.
1776 p is destination: worst case (base 2) is SCM_INTBUFLEN */
1778 scm_iint2str (long num
, int rad
, char *p
)
1782 unsigned long n
= (num
< 0) ? -num
: num
;
1784 for (n
/= rad
; n
> 0; n
/= rad
)
1801 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
1807 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
1809 "Return a string holding the external representation of the\n"
1810 "number @var{n} in the given @var{radix}. If @var{n} is\n"
1811 "inexact, a radix of 10 will be used.")
1812 #define FUNC_NAME s_scm_number_to_string
1816 if (SCM_UNBNDP (radix
))
1820 SCM_VALIDATE_INUM (2, radix
);
1821 base
= SCM_INUM (radix
);
1822 /* FIXME: ask if range limit was OK, and if so, document */
1823 SCM_ASSERT_RANGE (2, radix
, (base
>= 2) && (base
<= 36));
1828 char num_buf
[SCM_INTBUFLEN
];
1829 size_t length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
1830 return scm_mem2string (num_buf
, length
);
1832 else if (SCM_BIGP (n
))
1834 char *str
= mpz_get_str (NULL
, base
, SCM_I_BIG_MPZ (n
));
1835 scm_remember_upto_here_1 (n
);
1836 return scm_take0str (str
);
1838 else if (SCM_INEXACTP (n
))
1840 char num_buf
[FLOBUFLEN
];
1841 return scm_mem2string (num_buf
, iflo2str (n
, num_buf
));
1844 SCM_WRONG_TYPE_ARG (1, n
);
1849 /* These print routines used to be stubbed here so that scm_repl.c
1850 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
1853 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1855 char num_buf
[FLOBUFLEN
];
1856 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
1861 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1863 char num_buf
[FLOBUFLEN
];
1864 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
1869 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1871 char *str
= mpz_get_str (NULL
, 10, SCM_I_BIG_MPZ (exp
));
1872 scm_remember_upto_here_1 (exp
);
1873 scm_lfwrite (str
, (size_t) strlen (str
), port
);
1877 /*** END nums->strs ***/
1880 /*** STRINGS -> NUMBERS ***/
1882 /* The following functions implement the conversion from strings to numbers.
1883 * The implementation somehow follows the grammar for numbers as it is given
1884 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
1885 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
1886 * points should be noted about the implementation:
1887 * * Each function keeps a local index variable 'idx' that points at the
1888 * current position within the parsed string. The global index is only
1889 * updated if the function could parse the corresponding syntactic unit
1891 * * Similarly, the functions keep track of indicators of inexactness ('#',
1892 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
1893 * global exactness information is only updated after each part has been
1894 * successfully parsed.
1895 * * Sequences of digits are parsed into temporary variables holding fixnums.
1896 * Only if these fixnums would overflow, the result variables are updated
1897 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
1898 * the temporary variables holding the fixnums are cleared, and the process
1899 * starts over again. If for example fixnums were able to store five decimal
1900 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
1901 * and the result was computed as 12345 * 100000 + 67890. In other words,
1902 * only every five digits two bignum operations were performed.
1905 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
1907 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
1909 /* In non ASCII-style encodings the following macro might not work. */
1910 #define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
1913 mem2uinteger (const char* mem
, size_t len
, unsigned int *p_idx
,
1914 unsigned int radix
, enum t_exactness
*p_exactness
)
1916 unsigned int idx
= *p_idx
;
1917 unsigned int hash_seen
= 0;
1918 scm_t_bits shift
= 1;
1920 unsigned int digit_value
;
1930 digit_value
= XDIGIT2UINT (c
);
1931 if (digit_value
>= radix
)
1935 result
= SCM_MAKINUM (digit_value
);
1943 digit_value
= XDIGIT2UINT (c
);
1944 if (digit_value
>= radix
)
1956 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
1958 result
= scm_product (result
, SCM_MAKINUM (shift
));
1960 result
= scm_sum (result
, SCM_MAKINUM (add
));
1967 shift
= shift
* radix
;
1968 add
= add
* radix
+ digit_value
;
1973 result
= scm_product (result
, SCM_MAKINUM (shift
));
1975 result
= scm_sum (result
, SCM_MAKINUM (add
));
1979 *p_exactness
= INEXACT
;
1985 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
1986 * covers the parts of the rules that start at a potential point. The value
1987 * of the digits up to the point have been parsed by the caller and are given
1988 * in variable result. The content of *p_exactness indicates, whether a hash
1989 * has already been seen in the digits before the point.
1992 /* In non ASCII-style encodings the following macro might not work. */
1993 #define DIGIT2UINT(d) ((d) - '0')
1996 mem2decimal_from_point (SCM result
, const char* mem
, size_t len
,
1997 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
1999 unsigned int idx
= *p_idx
;
2000 enum t_exactness x
= *p_exactness
;
2005 if (mem
[idx
] == '.')
2007 scm_t_bits shift
= 1;
2009 unsigned int digit_value
;
2010 SCM big_shift
= SCM_MAKINUM (1);
2021 digit_value
= DIGIT2UINT (c
);
2032 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
2034 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2035 result
= scm_product (result
, SCM_MAKINUM (shift
));
2037 result
= scm_sum (result
, SCM_MAKINUM (add
));
2045 add
= add
* 10 + digit_value
;
2051 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2052 result
= scm_product (result
, SCM_MAKINUM (shift
));
2053 result
= scm_sum (result
, SCM_MAKINUM (add
));
2056 result
= scm_divide (result
, big_shift
);
2058 /* We've seen a decimal point, thus the value is implicitly inexact. */
2070 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2101 exponent
= DIGIT2UINT (c
);
2108 if (exponent
<= SCM_MAXEXP
)
2109 exponent
= exponent
* 10 + DIGIT2UINT (c
);
2115 if (exponent
> SCM_MAXEXP
)
2117 size_t exp_len
= idx
- start
;
2118 SCM exp_string
= scm_mem2string (&mem
[start
], exp_len
);
2119 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
2120 scm_out_of_range ("string->number", exp_num
);
2123 e
= scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent
));
2125 result
= scm_product (result
, e
);
2127 result
= scm_divide (result
, e
);
2129 /* We've seen an exponent, thus the value is implicitly inexact. */
2147 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2150 mem2ureal (const char* mem
, size_t len
, unsigned int *p_idx
,
2151 unsigned int radix
, enum t_exactness
*p_exactness
)
2153 unsigned int idx
= *p_idx
;
2159 if (idx
+5 <= len
&& !strncmp (mem
+idx
, "inf.0", 5))
2165 if (idx
+4 < len
&& !strncmp (mem
+idx
, "nan.", 4))
2167 enum t_exactness x
= EXACT
;
2169 /* Cobble up the fraction. We might want to set the NaN's
2170 mantissa from it. */
2172 mem2uinteger (mem
, len
, &idx
, 10, &x
);
2177 if (mem
[idx
] == '.')
2181 else if (idx
+ 1 == len
)
2183 else if (!isdigit (mem
[idx
+ 1]))
2186 result
= mem2decimal_from_point (SCM_MAKINUM (0), mem
, len
,
2187 p_idx
, p_exactness
);
2191 enum t_exactness x
= EXACT
;
2194 uinteger
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2195 if (SCM_FALSEP (uinteger
))
2200 else if (mem
[idx
] == '/')
2206 divisor
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2207 if (SCM_FALSEP (divisor
))
2210 result
= scm_divide (uinteger
, divisor
);
2212 else if (radix
== 10)
2214 result
= mem2decimal_from_point (uinteger
, mem
, len
, &idx
, &x
);
2215 if (SCM_FALSEP (result
))
2226 /* When returning an inexact zero, make sure it is represented as a
2227 floating point value so that we can change its sign.
2229 if (SCM_EQ_P (result
, SCM_MAKINUM(0)) && *p_exactness
== INEXACT
)
2230 result
= scm_make_real (0.0);
2236 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2239 mem2complex (const char* mem
, size_t len
, unsigned int idx
,
2240 unsigned int radix
, enum t_exactness
*p_exactness
)
2264 ureal
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2265 if (SCM_FALSEP (ureal
))
2267 /* input must be either +i or -i */
2272 if (mem
[idx
] == 'i' || mem
[idx
] == 'I')
2278 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign
));
2285 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2286 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
2295 /* either +<ureal>i or -<ureal>i */
2302 return scm_make_rectangular (SCM_MAKINUM (0), ureal
);
2305 /* polar input: <real>@<real>. */
2330 angle
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2331 if (SCM_FALSEP (angle
))
2336 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2337 angle
= scm_difference (angle
, SCM_UNDEFINED
);
2339 result
= scm_make_polar (ureal
, angle
);
2344 /* expecting input matching <real>[+-]<ureal>?i */
2351 int sign
= (c
== '+') ? 1 : -1;
2352 SCM imag
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2354 if (SCM_FALSEP (imag
))
2355 imag
= SCM_MAKINUM (sign
);
2356 else if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2357 imag
= scm_difference (imag
, SCM_UNDEFINED
);
2361 if (mem
[idx
] != 'i' && mem
[idx
] != 'I')
2368 return scm_make_rectangular (ureal
, imag
);
2377 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2379 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
2382 scm_i_mem2number (const char* mem
, size_t len
, unsigned int default_radix
)
2384 unsigned int idx
= 0;
2385 unsigned int radix
= NO_RADIX
;
2386 enum t_exactness forced_x
= NO_EXACTNESS
;
2387 enum t_exactness implicit_x
= EXACT
;
2390 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2391 while (idx
+ 2 < len
&& mem
[idx
] == '#')
2393 switch (mem
[idx
+ 1])
2396 if (radix
!= NO_RADIX
)
2401 if (radix
!= NO_RADIX
)
2406 if (forced_x
!= NO_EXACTNESS
)
2411 if (forced_x
!= NO_EXACTNESS
)
2416 if (radix
!= NO_RADIX
)
2421 if (radix
!= NO_RADIX
)
2431 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2432 if (radix
== NO_RADIX
)
2433 result
= mem2complex (mem
, len
, idx
, default_radix
, &implicit_x
);
2435 result
= mem2complex (mem
, len
, idx
, (unsigned int) radix
, &implicit_x
);
2437 if (SCM_FALSEP (result
))
2443 if (SCM_INEXACTP (result
))
2444 /* FIXME: This may change the value. */
2445 return scm_inexact_to_exact (result
);
2449 if (SCM_INEXACTP (result
))
2452 return scm_exact_to_inexact (result
);
2455 if (implicit_x
== INEXACT
)
2457 if (SCM_INEXACTP (result
))
2460 return scm_exact_to_inexact (result
);
2468 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2469 (SCM string
, SCM radix
),
2470 "Return a number of the maximally precise representation\n"
2471 "expressed by the given @var{string}. @var{radix} must be an\n"
2472 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2473 "is a default radix that may be overridden by an explicit radix\n"
2474 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2475 "supplied, then the default radix is 10. If string is not a\n"
2476 "syntactically valid notation for a number, then\n"
2477 "@code{string->number} returns @code{#f}.")
2478 #define FUNC_NAME s_scm_string_to_number
2482 SCM_VALIDATE_STRING (1, string
);
2483 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix
,2,10, base
);
2484 answer
= scm_i_mem2number (SCM_STRING_CHARS (string
),
2485 SCM_STRING_LENGTH (string
),
2487 return scm_return_first (answer
, string
);
2492 /*** END strs->nums ***/
2496 scm_make_real (double x
)
2498 SCM z
= scm_double_cell (scm_tc16_real
, 0, 0, 0);
2500 SCM_REAL_VALUE (z
) = x
;
2506 scm_make_complex (double x
, double y
)
2509 return scm_make_real (x
);
2513 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_gc_malloc (2*sizeof (double),
2515 SCM_COMPLEX_REAL (z
) = x
;
2516 SCM_COMPLEX_IMAG (z
) = y
;
2523 scm_bigequal (SCM x
, SCM y
)
2525 int result
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (x
));
2526 scm_remember_upto_here_2 (x
, y
);
2527 return SCM_BOOL (0 == result
);
2531 scm_real_equalp (SCM x
, SCM y
)
2533 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2537 scm_complex_equalp (SCM x
, SCM y
)
2539 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2540 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2545 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2546 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2547 * "else. Note that the sets of complex, real, rational and\n"
2548 * "integer values form subsets of the set of numbers, i. e. the\n"
2549 * "predicate will be fulfilled for any number."
2551 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2553 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2554 "otherwise. Note that the sets of real, rational and integer\n"
2555 "values form subsets of the set of complex numbers, i. e. the\n"
2556 "predicate will also be fulfilled if @var{x} is a real,\n"
2557 "rational or integer number.")
2558 #define FUNC_NAME s_scm_number_p
2560 return SCM_BOOL (SCM_NUMBERP (x
));
2565 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2566 /* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
2567 * "Note that the sets of integer and rational values form a subset\n"
2568 * "of the set of real numbers, i. e. the predicate will also\n"
2569 * "be fulfilled if @var{x} is an integer or a rational number."
2571 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2573 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
2574 "otherwise. Note that the set of integer values forms a subset of\n"
2575 "the set of rational numbers, i. e. the predicate will also be\n"
2576 "fulfilled if @var{x} is an integer number. Real numbers\n"
2577 "will also satisfy this predicate, because of their limited\n"
2579 #define FUNC_NAME s_scm_real_p
2583 else if (SCM_IMP (x
))
2585 else if (SCM_REALP (x
))
2587 else if (SCM_BIGP (x
))
2595 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2597 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2599 #define FUNC_NAME s_scm_integer_p
2608 if (!SCM_INEXACTP (x
))
2610 if (SCM_COMPLEXP (x
))
2612 r
= SCM_REAL_VALUE (x
);
2620 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
2622 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
2624 #define FUNC_NAME s_scm_inexact_p
2626 return SCM_BOOL (SCM_INEXACTP (x
));
2631 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
2632 /* "Return @code{#t} if all parameters are numerically equal." */
2634 scm_num_eq_p (SCM x
, SCM y
)
2638 long xx
= SCM_INUM (x
);
2641 long yy
= SCM_INUM (y
);
2642 return SCM_BOOL (xx
== yy
);
2644 else if (SCM_BIGP (y
))
2646 else if (SCM_REALP (y
))
2647 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
2648 else if (SCM_COMPLEXP (y
))
2649 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
2650 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2652 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2654 else if (SCM_BIGP (x
))
2658 else if (SCM_BIGP (y
))
2660 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2661 scm_remember_upto_here_2 (x
, y
);
2662 return SCM_BOOL (0 == cmp
);
2664 else if (SCM_REALP (y
))
2667 if (xisnan (SCM_REAL_VALUE (y
)))
2669 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
2670 scm_remember_upto_here_1 (x
);
2671 return SCM_BOOL (0 == cmp
);
2673 else if (SCM_COMPLEXP (y
))
2676 if (0.0 != SCM_COMPLEX_IMAG (y
))
2678 if (xisnan (SCM_COMPLEX_REAL (y
)))
2680 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_COMPLEX_REAL (y
));
2681 scm_remember_upto_here_1 (x
);
2682 return SCM_BOOL (0 == cmp
);
2685 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2687 else if (SCM_REALP (x
))
2690 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
2691 else if (SCM_BIGP (y
))
2694 if (xisnan (SCM_REAL_VALUE (x
)))
2696 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
2697 scm_remember_upto_here_1 (y
);
2698 return SCM_BOOL (0 == cmp
);
2700 else if (SCM_REALP (y
))
2701 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2702 else if (SCM_COMPLEXP (y
))
2703 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
2704 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2706 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2708 else if (SCM_COMPLEXP (x
))
2711 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
2712 && (SCM_COMPLEX_IMAG (x
) == 0.0));
2713 else if (SCM_BIGP (y
))
2716 if (0.0 != SCM_COMPLEX_IMAG (x
))
2718 if (xisnan (SCM_COMPLEX_REAL (x
)))
2720 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_COMPLEX_REAL (x
));
2721 scm_remember_upto_here_1 (y
);
2722 return SCM_BOOL (0 == cmp
);
2724 else if (SCM_REALP (y
))
2725 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
2726 && (SCM_COMPLEX_IMAG (x
) == 0.0));
2727 else if (SCM_COMPLEXP (y
))
2728 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
2729 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
2731 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2734 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
2738 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
2739 /* "Return @code{#t} if the list of parameters is monotonically\n"
2743 scm_less_p (SCM x
, SCM y
)
2747 long xx
= SCM_INUM (x
);
2750 long yy
= SCM_INUM (y
);
2751 return SCM_BOOL (xx
< yy
);
2753 else if (SCM_BIGP (y
))
2755 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2756 scm_remember_upto_here_1 (y
);
2757 return SCM_BOOL (sgn
> 0);
2759 else if (SCM_REALP (y
))
2760 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
2762 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
2764 else if (SCM_BIGP (x
))
2768 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
2769 scm_remember_upto_here_1 (x
);
2770 return SCM_BOOL (sgn
< 0);
2772 else if (SCM_BIGP (y
))
2774 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2775 scm_remember_upto_here_2 (x
, y
);
2776 return SCM_BOOL (cmp
< 0);
2778 else if (SCM_REALP (y
))
2781 if (xisnan (SCM_REAL_VALUE (y
)))
2783 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), SCM_REAL_VALUE (y
));
2784 scm_remember_upto_here_1 (x
);
2785 return SCM_BOOL (cmp
< 0);
2788 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
2790 else if (SCM_REALP (x
))
2793 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
2794 else if (SCM_BIGP (y
))
2797 if (xisnan (SCM_REAL_VALUE (x
)))
2799 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), SCM_REAL_VALUE (x
));
2800 scm_remember_upto_here_1 (y
);
2801 return SCM_BOOL (cmp
> 0);
2803 else if (SCM_REALP (y
))
2804 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
2806 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
2809 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
2813 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
2814 /* "Return @code{#t} if the list of parameters is monotonically\n"
2817 #define FUNC_NAME s_scm_gr_p
2819 scm_gr_p (SCM x
, SCM y
)
2821 if (!SCM_NUMBERP (x
))
2822 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
2823 else if (!SCM_NUMBERP (y
))
2824 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
2826 return scm_less_p (y
, x
);
2831 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
2832 /* "Return @code{#t} if the list of parameters is monotonically\n"
2835 #define FUNC_NAME s_scm_leq_p
2837 scm_leq_p (SCM x
, SCM y
)
2839 if (!SCM_NUMBERP (x
))
2840 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
2841 else if (!SCM_NUMBERP (y
))
2842 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
2843 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
2846 return SCM_BOOL_NOT (scm_less_p (y
, x
));
2851 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
2852 /* "Return @code{#t} if the list of parameters is monotonically\n"
2855 #define FUNC_NAME s_scm_geq_p
2857 scm_geq_p (SCM x
, SCM y
)
2859 if (!SCM_NUMBERP (x
))
2860 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
2861 else if (!SCM_NUMBERP (y
))
2862 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
2863 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
2866 return SCM_BOOL_NOT (scm_less_p (x
, y
));
2871 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
2872 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
2879 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
2880 else if (SCM_BIGP (z
))
2882 else if (SCM_REALP (z
))
2883 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
2884 else if (SCM_COMPLEXP (z
))
2885 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
2886 && SCM_COMPLEX_IMAG (z
) == 0.0);
2888 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
2892 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
2893 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
2897 scm_positive_p (SCM x
)
2900 return SCM_BOOL (SCM_INUM (x
) > 0);
2901 else if (SCM_BIGP (x
))
2903 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
2904 scm_remember_upto_here_1 (x
);
2905 return SCM_BOOL (sgn
> 0);
2907 else if (SCM_REALP (x
))
2908 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
2910 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
2914 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
2915 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
2919 scm_negative_p (SCM x
)
2922 return SCM_BOOL (SCM_INUM (x
) < 0);
2923 else if (SCM_BIGP (x
))
2925 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
2926 scm_remember_upto_here_1 (x
);
2927 return SCM_BOOL (sgn
< 0);
2929 else if (SCM_REALP (x
))
2930 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
2932 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
2936 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
2937 /* "Return the maximum of all parameter values."
2940 scm_max (SCM x
, SCM y
)
2945 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
2946 else if (SCM_NUMBERP (x
))
2949 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
2954 long xx
= SCM_INUM (x
);
2957 long yy
= SCM_INUM (y
);
2958 return (xx
< yy
) ? y
: x
;
2960 else if (SCM_BIGP (y
))
2962 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
2963 scm_remember_upto_here_1 (y
);
2964 return (sgn
< 0) ? x
: y
;
2966 else if (SCM_REALP (y
))
2969 /* if y==NaN then ">" is false and we return NaN */
2970 return (z
> SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
2973 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
2975 else if (SCM_BIGP (x
))
2979 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
2980 scm_remember_upto_here_1 (x
);
2981 return (sgn
< 0) ? y
: x
;
2983 else if (SCM_BIGP (y
))
2985 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
2986 scm_remember_upto_here_2 (x
, y
);
2987 return (cmp
> 0) ? x
: y
;
2989 else if (SCM_REALP (y
))
2991 double yy
= SCM_REAL_VALUE (y
);
2995 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), yy
);
2996 scm_remember_upto_here_1 (x
);
2997 return (cmp
> 0) ? x
: y
;
3000 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3002 else if (SCM_REALP (x
))
3006 double z
= SCM_INUM (y
);
3007 /* if x==NaN then "<" is false and we return NaN */
3008 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3010 else if (SCM_BIGP (y
))
3012 double xx
= SCM_REAL_VALUE (x
);
3016 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
3017 scm_remember_upto_here_1 (y
);
3018 return (cmp
< 0) ? x
: y
;
3020 else if (SCM_REALP (y
))
3022 /* if x==NaN then our explicit check means we return NaN
3023 if y==NaN then ">" is false and we return NaN
3024 calling isnan is unavoidable, since it's the only way to know
3025 which of x or y causes any compares to be false */
3026 double xx
= SCM_REAL_VALUE (x
);
3027 return (xisnan (xx
) || xx
> SCM_REAL_VALUE (y
)) ? x
: y
;
3030 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3033 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3037 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3038 /* "Return the minium of all parameter values."
3041 scm_min (SCM x
, SCM y
)
3046 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
3047 else if (SCM_NUMBERP (x
))
3050 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3055 long xx
= SCM_INUM (x
);
3058 long yy
= SCM_INUM (y
);
3059 return (xx
< yy
) ? x
: y
;
3061 else if (SCM_BIGP (y
))
3063 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3064 scm_remember_upto_here_1 (y
);
3065 return (sgn
< 0) ? y
: x
;
3067 else if (SCM_REALP (y
))
3070 /* if y==NaN then "<" is false and we return NaN */
3071 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3074 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3076 else if (SCM_BIGP (x
))
3080 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3081 scm_remember_upto_here_1 (x
);
3082 return (sgn
< 0) ? x
: y
;
3084 else if (SCM_BIGP (y
))
3086 int cmp
= mpz_cmp (SCM_I_BIG_MPZ (x
), SCM_I_BIG_MPZ (y
));
3087 scm_remember_upto_here_2 (x
, y
);
3088 return (cmp
> 0) ? y
: x
;
3090 else if (SCM_REALP (y
))
3092 double yy
= SCM_REAL_VALUE (y
);
3096 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (x
), yy
);
3097 scm_remember_upto_here_1 (x
);
3098 return (cmp
> 0) ? y
: x
;
3101 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3103 else if (SCM_REALP (x
))
3107 double z
= SCM_INUM (y
);
3108 /* if x==NaN then "<" is false and we return NaN */
3109 return (z
< SCM_REAL_VALUE (x
)) ? scm_make_real (z
) : x
;
3111 else if (SCM_BIGP (y
))
3113 double xx
= SCM_REAL_VALUE (x
);
3117 cmp
= xmpz_cmp_d (SCM_I_BIG_MPZ (y
), xx
);
3118 scm_remember_upto_here_1 (y
);
3119 return (cmp
< 0) ? y
: x
;
3121 else if (SCM_REALP (y
))
3123 /* if x==NaN then our explicit check means we return NaN
3124 if y==NaN then "<" is false and we return NaN
3125 calling isnan is unavoidable, since it's the only way to know
3126 which of x or y causes any compares to be false */
3127 double xx
= SCM_REAL_VALUE (x
);
3128 return (xisnan (xx
) || xx
< SCM_REAL_VALUE (y
)) ? x
: y
;
3131 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3134 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3138 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3139 /* "Return the sum of all parameter values. Return 0 if called without\n"
3143 scm_sum (SCM x
, SCM y
)
3147 if (SCM_NUMBERP (x
)) return x
;
3148 if (SCM_UNBNDP (x
)) return SCM_INUM0
;
3149 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3156 long xx
= SCM_INUM (x
);
3157 long yy
= SCM_INUM (y
);
3158 long int z
= xx
+ yy
;
3159 return SCM_FIXABLE (z
) ? SCM_MAKINUM (z
) : scm_i_long2big (z
);
3161 else if (SCM_BIGP (y
))
3166 else if (SCM_REALP (y
))
3168 long int xx
= SCM_INUM (x
);
3169 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3171 else if (SCM_COMPLEXP (y
))
3173 long int xx
= SCM_INUM (x
);
3174 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3175 SCM_COMPLEX_IMAG (y
));
3178 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3179 } else if (SCM_BIGP (x
))
3186 inum
= SCM_INUM (y
);
3189 bigsgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3192 SCM result
= scm_i_mkbig ();
3193 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), - inum
);
3194 scm_remember_upto_here_1 (x
);
3195 /* we know the result will have to be a bignum */
3198 return scm_i_normbig (result
);
3202 SCM result
= scm_i_mkbig ();
3203 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), inum
);
3204 scm_remember_upto_here_1 (x
);
3205 /* we know the result will have to be a bignum */
3208 return scm_i_normbig (result
);
3211 else if (SCM_BIGP (y
))
3213 SCM result
= scm_i_mkbig ();
3214 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3215 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3216 mpz_add (SCM_I_BIG_MPZ (result
),
3219 scm_remember_upto_here_2 (x
, y
);
3220 /* we know the result will have to be a bignum */
3223 return scm_i_normbig (result
);
3225 else if (SCM_REALP (y
))
3227 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) + SCM_REAL_VALUE (y
);
3228 scm_remember_upto_here_1 (x
);
3229 return scm_make_real (result
);
3231 else if (SCM_COMPLEXP (y
))
3233 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
3234 + SCM_COMPLEX_REAL (y
));
3235 scm_remember_upto_here_1 (x
);
3236 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (y
));
3239 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3241 else if (SCM_REALP (x
))
3244 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3245 else if (SCM_BIGP (y
))
3247 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) + SCM_REAL_VALUE (x
);
3248 scm_remember_upto_here_1 (y
);
3249 return scm_make_real (result
);
3251 else if (SCM_REALP (y
))
3252 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3253 else if (SCM_COMPLEXP (y
))
3254 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3255 SCM_COMPLEX_IMAG (y
));
3257 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3259 else if (SCM_COMPLEXP (x
))
3262 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3263 SCM_COMPLEX_IMAG (x
));
3264 else if (SCM_BIGP (y
))
3266 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (y
))
3267 + SCM_COMPLEX_REAL (x
));
3268 scm_remember_upto_here_1 (y
);
3269 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (x
));
3271 else if (SCM_REALP (y
))
3272 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3273 SCM_COMPLEX_IMAG (x
));
3274 else if (SCM_COMPLEXP (y
))
3275 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3276 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3278 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3281 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3285 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3286 /* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3287 * the sum of all but the first argument are subtracted from the first
3289 #define FUNC_NAME s_difference
3291 scm_difference (SCM x
, SCM y
)
3296 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3300 long xx
= -SCM_INUM (x
);
3301 if (SCM_FIXABLE (xx
))
3302 return SCM_MAKINUM (xx
);
3304 return scm_i_long2big (xx
);
3306 else if (SCM_BIGP (x
))
3307 /* FIXME: do we really need to normalize here? */
3308 return scm_i_normbig (scm_i_clonebig (x
, 0));
3309 else if (SCM_REALP (x
))
3310 return scm_make_real (-SCM_REAL_VALUE (x
));
3311 else if (SCM_COMPLEXP (x
))
3312 return scm_make_complex (-SCM_COMPLEX_REAL (x
),
3313 -SCM_COMPLEX_IMAG (x
));
3315 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3322 long int xx
= SCM_INUM (x
);
3323 long int yy
= SCM_INUM (y
);
3324 long int z
= xx
- yy
;
3325 if (SCM_FIXABLE (z
))
3326 return SCM_MAKINUM (z
);
3328 return scm_i_long2big (z
);
3330 else if (SCM_BIGP (y
))
3332 /* inum-x - big-y */
3333 long xx
= SCM_INUM (x
);
3336 return scm_i_clonebig (y
, 0);
3339 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3340 SCM result
= scm_i_mkbig ();
3343 mpz_ui_sub (SCM_I_BIG_MPZ (result
), xx
, SCM_I_BIG_MPZ (y
));
3346 /* x - y == -(y + -x) */
3347 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), -xx
);
3348 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
3350 scm_remember_upto_here_1 (y
);
3352 if ((xx
< 0 && (sgn_y
> 0)) || ((xx
> 0) && sgn_y
< 0))
3353 /* we know the result will have to be a bignum */
3356 return scm_i_normbig (result
);
3359 else if (SCM_REALP (y
))
3361 long int xx
= SCM_INUM (x
);
3362 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
3364 else if (SCM_COMPLEXP (y
))
3366 long int xx
= SCM_INUM (x
);
3367 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
3368 - SCM_COMPLEX_IMAG (y
));
3371 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3373 else if (SCM_BIGP (x
))
3377 /* big-x - inum-y */
3378 long yy
= SCM_INUM (y
);
3379 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3381 scm_remember_upto_here_1 (x
);
3383 return SCM_FIXABLE (-yy
) ? SCM_MAKINUM (-yy
) : scm_long2num (-yy
);
3386 SCM result
= scm_i_mkbig ();
3389 mpz_sub_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), yy
);
3391 mpz_add_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), -yy
);
3392 scm_remember_upto_here_1 (x
);
3394 if ((sgn_x
< 0 && (yy
> 0)) || ((sgn_x
> 0) && yy
< 0))
3395 /* we know the result will have to be a bignum */
3398 return scm_i_normbig (result
);
3401 else if (SCM_BIGP (y
))
3403 int sgn_x
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3404 int sgn_y
= mpz_sgn (SCM_I_BIG_MPZ (y
));
3405 SCM result
= scm_i_mkbig ();
3406 mpz_sub (SCM_I_BIG_MPZ (result
),
3409 scm_remember_upto_here_2 (x
, y
);
3410 /* we know the result will have to be a bignum */
3411 if ((sgn_x
== 1) && (sgn_y
== -1))
3413 if ((sgn_x
== -1) && (sgn_y
== 1))
3415 return scm_i_normbig (result
);
3417 else if (SCM_REALP (y
))
3419 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) - SCM_REAL_VALUE (y
);
3420 scm_remember_upto_here_1 (x
);
3421 return scm_make_real (result
);
3423 else if (SCM_COMPLEXP (y
))
3425 double real_part
= (mpz_get_d (SCM_I_BIG_MPZ (x
))
3426 - SCM_COMPLEX_REAL (y
));
3427 scm_remember_upto_here_1 (x
);
3428 return scm_make_complex (real_part
, - SCM_COMPLEX_IMAG (y
));
3430 else SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3432 else if (SCM_REALP (x
))
3435 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
3436 else if (SCM_BIGP (y
))
3438 double result
= SCM_REAL_VALUE (x
) - mpz_get_d (SCM_I_BIG_MPZ (y
));
3439 scm_remember_upto_here_1 (x
);
3440 return scm_make_real (result
);
3442 else if (SCM_REALP (y
))
3443 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3444 else if (SCM_COMPLEXP (y
))
3445 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3446 -SCM_COMPLEX_IMAG (y
));
3448 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3450 else if (SCM_COMPLEXP (x
))
3453 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
3454 SCM_COMPLEX_IMAG (x
));
3455 else if (SCM_BIGP (y
))
3457 double real_part
= (SCM_COMPLEX_REAL (x
)
3458 - mpz_get_d (SCM_I_BIG_MPZ (y
)));
3459 scm_remember_upto_here_1 (x
);
3460 return scm_make_complex (real_part
, SCM_COMPLEX_IMAG (y
));
3462 else if (SCM_REALP (y
))
3463 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3464 SCM_COMPLEX_IMAG (x
));
3465 else if (SCM_COMPLEXP (y
))
3466 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3467 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3469 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3472 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3477 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3478 /* "Return the product of all arguments. If called without arguments,\n"
3482 scm_product (SCM x
, SCM y
)
3487 return SCM_MAKINUM (1L);
3488 else if (SCM_NUMBERP (x
))
3491 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3503 case 0: return x
; break;
3504 case 1: return y
; break;
3509 long yy
= SCM_INUM (y
);
3511 SCM k
= SCM_MAKINUM (kk
);
3512 if ((kk
== SCM_INUM (k
)) && (kk
/ xx
== yy
))
3516 SCM result
= scm_i_long2big (xx
);
3517 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
), yy
);
3518 return scm_i_normbig (result
);
3521 else if (SCM_BIGP (y
))
3523 SCM result
= scm_i_mkbig ();
3524 mpz_mul_si (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (y
), xx
);
3525 scm_remember_upto_here_1 (y
);
3528 else if (SCM_REALP (y
))
3529 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3530 else if (SCM_COMPLEXP (y
))
3531 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3532 xx
* SCM_COMPLEX_IMAG (y
));
3534 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3536 else if (SCM_BIGP (x
))
3543 else if (SCM_BIGP (y
))
3545 SCM result
= scm_i_mkbig ();
3546 mpz_mul (SCM_I_BIG_MPZ (result
),
3549 scm_remember_upto_here_2 (x
, y
);
3552 else if (SCM_REALP (y
))
3554 double result
= mpz_get_d (SCM_I_BIG_MPZ (x
)) * SCM_REAL_VALUE (y
);
3555 scm_remember_upto_here_1 (x
);
3556 return scm_make_real (result
);
3558 else if (SCM_COMPLEXP (y
))
3560 double z
= mpz_get_d (SCM_I_BIG_MPZ (x
));
3561 scm_remember_upto_here_1 (x
);
3562 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3563 z
* SCM_COMPLEX_IMAG (y
));
3566 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3568 else if (SCM_REALP (x
))
3571 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3572 else if (SCM_BIGP (y
))
3574 double result
= mpz_get_d (SCM_I_BIG_MPZ (y
)) * SCM_REAL_VALUE (x
);
3575 scm_remember_upto_here_1 (y
);
3576 return scm_make_real (result
);
3578 else if (SCM_REALP (y
))
3579 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
3580 else if (SCM_COMPLEXP (y
))
3581 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
3582 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3584 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3586 else if (SCM_COMPLEXP (x
))
3589 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3590 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3591 else if (SCM_BIGP (y
))
3593 double z
= mpz_get_d (SCM_I_BIG_MPZ (y
));
3594 scm_remember_upto_here_1 (y
);
3595 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
3596 z
* SCM_COMPLEX_IMAG (x
));
3598 else if (SCM_REALP (y
))
3599 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3600 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
3601 else if (SCM_COMPLEXP (y
))
3603 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
3604 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
3605 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3606 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3609 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3612 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3616 scm_num2dbl (SCM a
, const char *why
)
3617 #define FUNC_NAME why
3620 return (double) SCM_INUM (a
);
3621 else if (SCM_BIGP (a
))
3623 double result
= mpz_get_d (SCM_I_BIG_MPZ (a
));
3624 scm_remember_upto_here_1 (a
);
3627 else if (SCM_REALP (a
))
3628 return (SCM_REAL_VALUE (a
));
3630 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3634 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
3635 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
3636 #define ALLOW_DIVIDE_BY_ZERO
3637 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
3640 /* The code below for complex division is adapted from the GNU
3641 libstdc++, which adapted it from f2c's libF77, and is subject to
3644 /****************************************************************
3645 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
3647 Permission to use, copy, modify, and distribute this software
3648 and its documentation for any purpose and without fee is hereby
3649 granted, provided that the above copyright notice appear in all
3650 copies and that both that the copyright notice and this
3651 permission notice and warranty disclaimer appear in supporting
3652 documentation, and that the names of AT&T Bell Laboratories or
3653 Bellcore or any of their entities not be used in advertising or
3654 publicity pertaining to distribution of the software without
3655 specific, written prior permission.
3657 AT&T and Bellcore disclaim all warranties with regard to this
3658 software, including all implied warranties of merchantability
3659 and fitness. In no event shall AT&T or Bellcore be liable for
3660 any special, indirect or consequential damages or any damages
3661 whatsoever resulting from loss of use, data or profits, whether
3662 in an action of contract, negligence or other tortious action,
3663 arising out of or in connection with the use or performance of
3665 ****************************************************************/
3667 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3668 /* Divide the first argument by the product of the remaining
3669 arguments. If called with one argument @var{z1}, 1/@var{z1} is
3671 #define FUNC_NAME s_divide
3673 scm_divide (SCM x
, SCM y
)
3680 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
3681 else if (SCM_INUMP (x
))
3683 long xx
= SCM_INUM (x
);
3684 if (xx
== 1 || xx
== -1)
3686 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3688 scm_num_overflow (s_divide
);
3691 return scm_make_real (1.0 / (double) xx
);
3693 else if (SCM_BIGP (x
))
3694 return scm_make_real (1.0 / scm_i_big2dbl (x
));
3695 else if (SCM_REALP (x
))
3697 double xx
= SCM_REAL_VALUE (x
);
3698 #ifndef ALLOW_DIVIDE_BY_ZERO
3700 scm_num_overflow (s_divide
);
3703 return scm_make_real (1.0 / xx
);
3705 else if (SCM_COMPLEXP (x
))
3707 double r
= SCM_COMPLEX_REAL (x
);
3708 double i
= SCM_COMPLEX_IMAG (x
);
3712 double d
= i
* (1.0 + t
* t
);
3713 return scm_make_complex (t
/ d
, -1.0 / d
);
3718 double d
= r
* (1.0 + t
* t
);
3719 return scm_make_complex (1.0 / d
, -t
/ d
);
3723 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3728 long xx
= SCM_INUM (x
);
3731 long yy
= SCM_INUM (y
);
3734 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3735 scm_num_overflow (s_divide
);
3737 return scm_make_real ((double) xx
/ (double) yy
);
3740 else if (xx
% yy
!= 0)
3741 return scm_make_real ((double) xx
/ (double) yy
);
3745 if (SCM_FIXABLE (z
))
3746 return SCM_MAKINUM (z
);
3748 return scm_i_long2big (z
);
3751 else if (SCM_BIGP (y
))
3752 return scm_make_real ((double) xx
/ scm_i_big2dbl (y
));
3753 else if (SCM_REALP (y
))
3755 double yy
= SCM_REAL_VALUE (y
);
3756 #ifndef ALLOW_DIVIDE_BY_ZERO
3758 scm_num_overflow (s_divide
);
3761 return scm_make_real ((double) xx
/ yy
);
3763 else if (SCM_COMPLEXP (y
))
3766 complex_div
: /* y _must_ be a complex number */
3768 double r
= SCM_COMPLEX_REAL (y
);
3769 double i
= SCM_COMPLEX_IMAG (y
);
3773 double d
= i
* (1.0 + t
* t
);
3774 return scm_make_complex ((a
* t
) / d
, -a
/ d
);
3779 double d
= r
* (1.0 + t
* t
);
3780 return scm_make_complex (a
/ d
, -(a
* t
) / d
);
3785 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3787 else if (SCM_BIGP (x
))
3791 long int yy
= SCM_INUM (y
);
3794 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3795 scm_num_overflow (s_divide
);
3797 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3798 scm_remember_upto_here_1 (x
);
3799 return (sgn
== 0) ? scm_nan () : scm_inf ();
3806 /* FIXME: HMM, what are the relative performance issues here?
3807 We need to test. Is it faster on average to test
3808 divisible_p, then perform whichever operation, or is it
3809 faster to perform the integer div opportunistically and
3810 switch to real if there's a remainder? For now we take the
3811 middle ground: test, then if divisible, use the faster div
3814 long abs_yy
= yy
< 0 ? -yy
: yy
;
3815 int divisible_p
= mpz_divisible_ui_p (SCM_I_BIG_MPZ (x
), abs_yy
);
3819 SCM result
= scm_i_mkbig ();
3820 mpz_divexact_ui (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (x
), abs_yy
);
3821 scm_remember_upto_here_1 (x
);
3823 mpz_neg (SCM_I_BIG_MPZ (result
), SCM_I_BIG_MPZ (result
));
3824 return scm_i_normbig (result
);
3827 return scm_make_real (scm_i_big2dbl (x
) / (double) yy
);
3830 else if (SCM_BIGP (y
))
3832 int y_is_zero
= (mpz_sgn (SCM_I_BIG_MPZ (y
)) == 0);
3835 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3836 scm_num_overflow (s_divide
);
3838 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (x
));
3839 scm_remember_upto_here_1 (x
);
3840 return (sgn
== 0) ? scm_nan () : scm_inf ();
3846 int divisible_p
= mpz_divisible_p (SCM_I_BIG_MPZ (x
),
3850 SCM result
= scm_i_mkbig ();
3851 mpz_divexact (SCM_I_BIG_MPZ (result
),
3854 scm_remember_upto_here_2 (x
, y
);
3855 return scm_i_normbig (result
);
3859 double dbx
= mpz_get_d (SCM_I_BIG_MPZ (x
));
3860 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
3861 scm_remember_upto_here_2 (x
, y
);
3862 return scm_make_real (dbx
/ dby
);
3866 else if (SCM_REALP (y
))
3868 double yy
= SCM_REAL_VALUE (y
);
3869 #ifndef ALLOW_DIVIDE_BY_ZERO
3871 scm_num_overflow (s_divide
);
3874 return scm_make_real (scm_i_big2dbl (x
) / yy
);
3876 else if (SCM_COMPLEXP (y
))
3878 a
= scm_i_big2dbl (x
);
3882 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3884 else if (SCM_REALP (x
))
3886 double rx
= SCM_REAL_VALUE (x
);
3889 long int yy
= SCM_INUM (y
);
3890 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3892 scm_num_overflow (s_divide
);
3895 return scm_make_real (rx
/ (double) yy
);
3897 else if (SCM_BIGP (y
))
3899 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
3900 scm_remember_upto_here_1 (y
);
3901 return scm_make_real (rx
/ dby
);
3903 else if (SCM_REALP (y
))
3905 double yy
= SCM_REAL_VALUE (y
);
3906 #ifndef ALLOW_DIVIDE_BY_ZERO
3908 scm_num_overflow (s_divide
);
3911 return scm_make_real (rx
/ yy
);
3913 else if (SCM_COMPLEXP (y
))
3919 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3921 else if (SCM_COMPLEXP (x
))
3923 double rx
= SCM_COMPLEX_REAL (x
);
3924 double ix
= SCM_COMPLEX_IMAG (x
);
3927 long int yy
= SCM_INUM (y
);
3928 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3930 scm_num_overflow (s_divide
);
3935 return scm_make_complex (rx
/ d
, ix
/ d
);
3938 else if (SCM_BIGP (y
))
3940 double dby
= mpz_get_d (SCM_I_BIG_MPZ (y
));
3941 scm_remember_upto_here_1 (y
);
3942 return scm_make_complex (rx
/ dby
, ix
/ dby
);
3944 else if (SCM_REALP (y
))
3946 double yy
= SCM_REAL_VALUE (y
);
3947 #ifndef ALLOW_DIVIDE_BY_ZERO
3949 scm_num_overflow (s_divide
);
3952 return scm_make_complex (rx
/ yy
, ix
/ yy
);
3954 else if (SCM_COMPLEXP (y
))
3956 double ry
= SCM_COMPLEX_REAL (y
);
3957 double iy
= SCM_COMPLEX_IMAG (y
);
3961 double d
= iy
* (1.0 + t
* t
);
3962 return scm_make_complex ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
3967 double d
= ry
* (1.0 + t
* t
);
3968 return scm_make_complex ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
3972 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3975 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
3981 scm_asinh (double x
)
3986 #define asinh scm_asinh
3987 return log (x
+ sqrt (x
* x
+ 1));
3990 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_dsubr
, (SCM (*)()) asinh
, g_asinh
);
3991 /* "Return the inverse hyperbolic sine of @var{x}."
3996 scm_acosh (double x
)
4001 #define acosh scm_acosh
4002 return log (x
+ sqrt (x
* x
- 1));
4005 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_dsubr
, (SCM (*)()) acosh
, g_acosh
);
4006 /* "Return the inverse hyperbolic cosine of @var{x}."
4011 scm_atanh (double x
)
4016 #define atanh scm_atanh
4017 return 0.5 * log ((1 + x
) / (1 - x
));
4020 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_dsubr
, (SCM (*)()) atanh
, g_atanh
);
4021 /* "Return the inverse hyperbolic tangent of @var{x}."
4026 scm_truncate (double x
)
4031 #define trunc scm_truncate
4037 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_dsubr
, (SCM (*)()) trunc
, g_truncate
);
4038 /* "Round the inexact number @var{x} towards zero."
4042 SCM_GPROC1 (s_round
, "round", scm_tc7_dsubr
, (SCM (*)()) scm_round
, g_round
);
4043 /* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
4044 * "numbers, round towards even."
4047 scm_round (double x
)
4049 double plus_half
= x
+ 0.5;
4050 double result
= floor (plus_half
);
4051 /* Adjust so that the scm_round is towards even. */
4052 return ((plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
4058 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_dsubr
, (SCM (*)()) floor
, g_i_floor
);
4059 /* "Round the number @var{x} towards minus infinity."
4061 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_dsubr
, (SCM (*)()) ceil
, g_i_ceil
);
4062 /* "Round the number @var{x} towards infinity."
4064 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_dsubr
, (SCM (*)()) sqrt
, g_i_sqrt
);
4065 /* "Return the square root of the real number @var{x}."
4067 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_dsubr
, (SCM (*)()) fabs
, g_i_abs
);
4068 /* "Return the absolute value of the real number @var{x}."
4070 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_dsubr
, (SCM (*)()) exp
, g_i_exp
);
4071 /* "Return the @var{x}th power of e."
4073 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_dsubr
, (SCM (*)()) log
, g_i_log
);
4074 /* "Return the natural logarithm of the real number @var{x}."
4076 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_dsubr
, (SCM (*)()) sin
, g_i_sin
);
4077 /* "Return the sine of the real number @var{x}."
4079 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_dsubr
, (SCM (*)()) cos
, g_i_cos
);
4080 /* "Return the cosine of the real number @var{x}."
4082 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_dsubr
, (SCM (*)()) tan
, g_i_tan
);
4083 /* "Return the tangent of the real number @var{x}."
4085 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_dsubr
, (SCM (*)()) asin
, g_i_asin
);
4086 /* "Return the arc sine of the real number @var{x}."
4088 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_dsubr
, (SCM (*)()) acos
, g_i_acos
);
4089 /* "Return the arc cosine of the real number @var{x}."
4091 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_dsubr
, (SCM (*)()) atan
, g_i_atan
);
4092 /* "Return the arc tangent of the real number @var{x}."
4094 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_dsubr
, (SCM (*)()) sinh
, g_i_sinh
);
4095 /* "Return the hyperbolic sine of the real number @var{x}."
4097 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_dsubr
, (SCM (*)()) cosh
, g_i_cosh
);
4098 /* "Return the hyperbolic cosine of the real number @var{x}."
4100 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_dsubr
, (SCM (*)()) tanh
, g_i_tanh
);
4101 /* "Return the hyperbolic tangent of the real number @var{x}."
4109 static void scm_two_doubles (SCM x
,
4111 const char *sstring
,
4115 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
4118 xy
->x
= SCM_INUM (x
);
4119 else if (SCM_BIGP (x
))
4120 xy
->x
= scm_i_big2dbl (x
);
4121 else if (SCM_REALP (x
))
4122 xy
->x
= SCM_REAL_VALUE (x
);
4124 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
4127 xy
->y
= SCM_INUM (y
);
4128 else if (SCM_BIGP (y
))
4129 xy
->y
= scm_i_big2dbl (y
);
4130 else if (SCM_REALP (y
))
4131 xy
->y
= SCM_REAL_VALUE (y
);
4133 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
4137 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
4139 "Return @var{x} raised to the power of @var{y}. This\n"
4140 "procedure does not accept complex arguments.")
4141 #define FUNC_NAME s_scm_sys_expt
4144 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4145 return scm_make_real (pow (xy
.x
, xy
.y
));
4150 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4152 "Return the arc tangent of the two arguments @var{x} and\n"
4153 "@var{y}. This is similar to calculating the arc tangent of\n"
4154 "@var{x} / @var{y}, except that the signs of both arguments\n"
4155 "are used to determine the quadrant of the result. This\n"
4156 "procedure does not accept complex arguments.")
4157 #define FUNC_NAME s_scm_sys_atan2
4160 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4161 return scm_make_real (atan2 (xy
.x
, xy
.y
));
4166 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4167 (SCM real
, SCM imaginary
),
4168 "Return a complex number constructed of the given @var{real} and\n"
4169 "@var{imaginary} parts.")
4170 #define FUNC_NAME s_scm_make_rectangular
4173 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
4174 return scm_make_complex (xy
.x
, xy
.y
);
4180 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4182 "Return the complex number @var{x} * e^(i * @var{y}).")
4183 #define FUNC_NAME s_scm_make_polar
4187 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4189 sincos (xy
.y
, &s
, &c
);
4194 return scm_make_complex (xy
.x
* c
, xy
.x
* s
);
4199 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4200 /* "Return the real part of the number @var{z}."
4203 scm_real_part (SCM z
)
4207 else if (SCM_BIGP (z
))
4209 else if (SCM_REALP (z
))
4211 else if (SCM_COMPLEXP (z
))
4212 return scm_make_real (SCM_COMPLEX_REAL (z
));
4214 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4218 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4219 /* "Return the imaginary part of the number @var{z}."
4222 scm_imag_part (SCM z
)
4226 else if (SCM_BIGP (z
))
4228 else if (SCM_REALP (z
))
4230 else if (SCM_COMPLEXP (z
))
4231 return scm_make_real (SCM_COMPLEX_IMAG (z
));
4233 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4237 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4238 /* "Return the magnitude of the number @var{z}. This is the same as\n"
4239 * "@code{abs} for real arguments, but also allows complex numbers."
4242 scm_magnitude (SCM z
)
4246 long int zz
= SCM_INUM (z
);
4249 else if (SCM_POSFIXABLE (-zz
))
4250 return SCM_MAKINUM (-zz
);
4252 return scm_i_long2big (-zz
);
4254 else if (SCM_BIGP (z
))
4256 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
4257 scm_remember_upto_here_1 (z
);
4259 return scm_i_clonebig (z
, 0);
4263 else if (SCM_REALP (z
))
4264 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
4265 else if (SCM_COMPLEXP (z
))
4266 return scm_make_real (hypot (SCM_COMPLEX_REAL (z
), SCM_COMPLEX_IMAG (z
)));
4268 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4272 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
4273 /* "Return the angle of the complex number @var{z}."
4278 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
4279 scm_flo0 to save allocating a new flonum with scm_make_real each time.
4280 But if atan2 follows the floating point rounding mode, then the value
4281 is not a constant. Maybe it'd be close enough though. */
4284 if (SCM_INUM (z
) >= 0)
4287 return scm_make_real (atan2 (0.0, -1.0));
4289 else if (SCM_BIGP (z
))
4291 int sgn
= mpz_sgn (SCM_I_BIG_MPZ (z
));
4292 scm_remember_upto_here_1 (z
);
4294 return scm_make_real (atan2 (0.0, -1.0));
4298 else if (SCM_REALP (z
))
4300 if (SCM_REAL_VALUE (z
) >= 0)
4303 return scm_make_real (atan2 (0.0, -1.0));
4305 else if (SCM_COMPLEXP (z
))
4306 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
4308 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
4312 SCM_GPROC (s_exact_to_inexact
, "exact->inexact", 1, 0, 0, scm_exact_to_inexact
, g_exact_to_inexact
);
4313 /* Convert the number @var{x} to its inexact representation.\n"
4316 scm_exact_to_inexact (SCM z
)
4319 return scm_make_real ((double) SCM_INUM (z
));
4320 else if (SCM_BIGP (z
))
4321 return scm_make_real (scm_i_big2dbl (z
));
4322 else if (SCM_INEXACTP (z
))
4325 SCM_WTA_DISPATCH_1 (g_exact_to_inexact
, z
, 1, s_exact_to_inexact
);
4329 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4331 "Return an exact number that is numerically closest to @var{z}.")
4332 #define FUNC_NAME s_scm_inexact_to_exact
4336 else if (SCM_BIGP (z
))
4338 else if (SCM_REALP (z
))
4340 double u
= floor (SCM_REAL_VALUE (z
) + 0.5);
4342 if (SCM_FIXABLE (lu
))
4343 return SCM_MAKINUM (lu
);
4344 else if (!xisinf (u
) && !xisnan (u
))
4345 return scm_i_dbl2big (u
);
4347 scm_num_overflow (s_scm_inexact_to_exact
);
4350 SCM_WRONG_TYPE_ARG (1, z
);
4354 /* if you need to change this, change test-num2integral.c as well */
4355 #if SCM_SIZEOF_LONG_LONG != 0
4357 # define ULLONG_MAX ((unsigned long long) (-1))
4358 # define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
4359 # define LLONG_MIN (~LLONG_MAX)
4363 /* Parameters for creating integer conversion routines.
4365 Define the following preprocessor macros before including
4366 "libguile/num2integral.i.c":
4368 NUM2INTEGRAL - the name of the function for converting from a
4369 Scheme object to the integral type. This function will be
4370 defined when including "num2integral.i.c".
4372 INTEGRAL2NUM - the name of the function for converting from the
4373 integral type to a Scheme object. This function will be defined.
4375 INTEGRAL2BIG - the name of an internal function that createas a
4376 bignum from the integral type. This function will be defined.
4377 The name should start with "scm_i_".
4379 ITYPE - the name of the integral type.
4381 UNSIGNED - Define this to 1 when ITYPE is an unsigned type. Define
4384 UNSIGNED_ITYPE - the name of the the unsigned variant of the
4385 integral type. If you don't define this, it defaults to
4386 "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned
4389 SIZEOF_ITYPE - an expression giving the size of the integral type
4390 in bytes. This expression must be computable by the
4391 preprocessor. (SIZEOF_FOO values are calculated by configure.in
4396 #define NUM2INTEGRAL scm_num2short
4397 #define INTEGRAL2NUM scm_short2num
4398 #define INTEGRAL2BIG scm_i_short2big
4401 #define SIZEOF_ITYPE SIZEOF_SHORT
4402 #include "libguile/num2integral.i.c"
4404 #define NUM2INTEGRAL scm_num2ushort
4405 #define INTEGRAL2NUM scm_ushort2num
4406 #define INTEGRAL2BIG scm_i_ushort2big
4408 #define ITYPE unsigned short
4409 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT
4410 #include "libguile/num2integral.i.c"
4412 #define NUM2INTEGRAL scm_num2int
4413 #define INTEGRAL2NUM scm_int2num
4414 #define INTEGRAL2BIG scm_i_int2big
4417 #define SIZEOF_ITYPE SIZEOF_INT
4418 #include "libguile/num2integral.i.c"
4420 #define NUM2INTEGRAL scm_num2uint
4421 #define INTEGRAL2NUM scm_uint2num
4422 #define INTEGRAL2BIG scm_i_uint2big
4424 #define ITYPE unsigned int
4425 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT
4426 #include "libguile/num2integral.i.c"
4428 #define NUM2INTEGRAL scm_num2long
4429 #define INTEGRAL2NUM scm_long2num
4430 #define INTEGRAL2BIG scm_i_long2big
4433 #define SIZEOF_ITYPE SIZEOF_LONG
4434 #include "libguile/num2integral.i.c"
4436 #define NUM2INTEGRAL scm_num2ulong
4437 #define INTEGRAL2NUM scm_ulong2num
4438 #define INTEGRAL2BIG scm_i_ulong2big
4440 #define ITYPE unsigned long
4441 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG
4442 #include "libguile/num2integral.i.c"
4444 #define NUM2INTEGRAL scm_num2ptrdiff
4445 #define INTEGRAL2NUM scm_ptrdiff2num
4446 #define INTEGRAL2BIG scm_i_ptrdiff2big
4448 #define ITYPE scm_t_ptrdiff
4449 #define UNSIGNED_ITYPE size_t
4450 #define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF
4451 #include "libguile/num2integral.i.c"
4453 #define NUM2INTEGRAL scm_num2size
4454 #define INTEGRAL2NUM scm_size2num
4455 #define INTEGRAL2BIG scm_i_size2big
4457 #define ITYPE size_t
4458 #define SIZEOF_ITYPE SIZEOF_SIZE_T
4459 #include "libguile/num2integral.i.c"
4461 #if SCM_SIZEOF_LONG_LONG != 0
4463 #ifndef ULONG_LONG_MAX
4464 #define ULONG_LONG_MAX (~0ULL)
4467 #define NUM2INTEGRAL scm_num2long_long
4468 #define INTEGRAL2NUM scm_long_long2num
4469 #define INTEGRAL2BIG scm_i_long_long2big
4471 #define ITYPE long long
4472 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
4473 #include "libguile/num2integral.i.c"
4475 #define NUM2INTEGRAL scm_num2ulong_long
4476 #define INTEGRAL2NUM scm_ulong_long2num
4477 #define INTEGRAL2BIG scm_i_ulong_long2big
4479 #define ITYPE unsigned long long
4480 #define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG
4481 #include "libguile/num2integral.i.c"
4483 #endif /* SCM_SIZEOF_LONG_LONG != 0 */
4485 #define NUM2FLOAT scm_num2float
4486 #define FLOAT2NUM scm_float2num
4488 #include "libguile/num2float.i.c"
4490 #define NUM2FLOAT scm_num2double
4491 #define FLOAT2NUM scm_double2num
4492 #define FTYPE double
4493 #include "libguile/num2float.i.c"
4498 #define SIZE_MAX ((size_t) (-1))
4501 #define PTRDIFF_MIN \
4502 ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 \
4503 << ((sizeof (scm_t_ptrdiff) * SCM_CHAR_BIT) - 1)))
4506 #define PTRDIFF_MAX (~ PTRDIFF_MIN)
4509 #define CHECK(type, v) \
4512 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
4532 CHECK (ptrdiff
, -1);
4534 CHECK (short, SHRT_MAX
);
4535 CHECK (short, SHRT_MIN
);
4536 CHECK (ushort
, USHRT_MAX
);
4537 CHECK (int, INT_MAX
);
4538 CHECK (int, INT_MIN
);
4539 CHECK (uint
, UINT_MAX
);
4540 CHECK (long, LONG_MAX
);
4541 CHECK (long, LONG_MIN
);
4542 CHECK (ulong
, ULONG_MAX
);
4543 CHECK (size
, SIZE_MAX
);
4544 CHECK (ptrdiff
, PTRDIFF_MAX
);
4545 CHECK (ptrdiff
, PTRDIFF_MIN
);
4547 #if SCM_SIZEOF_LONG_LONG != 0
4548 CHECK (long_long
, 0LL);
4549 CHECK (ulong_long
, 0ULL);
4550 CHECK (long_long
, -1LL);
4551 CHECK (long_long
, LLONG_MAX
);
4552 CHECK (long_long
, LLONG_MIN
);
4553 CHECK (ulong_long
, ULLONG_MAX
);
4560 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
4561 if (!SCM_FALSEP (data)) abort();
4564 check_body (void *data
)
4566 SCM num
= *(SCM
*) data
;
4567 scm_num2ulong (num
, 1, NULL
);
4569 return SCM_UNSPECIFIED
;
4573 check_handler (void *data
, SCM tag
, SCM throw_args
)
4575 SCM
*num
= (SCM
*) data
;
4578 return SCM_UNSPECIFIED
;
4581 SCM_DEFINE (scm_sys_check_number_conversions
, "%check-number-conversions", 0, 0, 0,
4583 "Number conversion sanity checking.")
4584 #define FUNC_NAME s_scm_sys_check_number_conversions
4586 SCM data
= SCM_MAKINUM (-1);
4588 data
= scm_int2num (INT_MIN
);
4590 data
= scm_ulong2num (ULONG_MAX
);
4591 data
= scm_difference (SCM_INUM0
, data
);
4593 data
= scm_ulong2num (ULONG_MAX
);
4594 data
= scm_sum (SCM_MAKINUM (1), data
); data
= scm_difference (SCM_INUM0
, data
);
4596 data
= scm_int2num (-10000); data
= scm_product (data
, data
); data
= scm_product (data
, data
);
4599 return SCM_UNSPECIFIED
;
4608 abs_most_negative_fixnum
= scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM
);
4609 scm_permanent_object (abs_most_negative_fixnum
);
4611 mpz_init_set_si (z_negative_one
, -1);
4613 /* It may be possible to tune the performance of some algorithms by using
4614 * the following constants to avoid the creation of bignums. Please, before
4615 * using these values, remember the two rules of program optimization:
4616 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
4617 scm_c_define ("most-positive-fixnum",
4618 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
4619 scm_c_define ("most-negative-fixnum",
4620 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
4622 scm_add_feature ("complex");
4623 scm_add_feature ("inexact");
4624 scm_flo0
= scm_make_real (0.0);
4626 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4628 { /* determine floating point precision */
4630 double fsum
= 1.0 + f
;
4633 if (++scm_dblprec
> 20)
4641 scm_dblprec
= scm_dblprec
- 1;
4643 #endif /* DBL_DIG */
4649 #include "libguile/numbers.x"