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 program is free software; you can redistribute it and/or modify
8 * it under the terms of the GNU General Public License as published by
9 * the Free Software Foundation; either version 2, or (at your option)
12 * This program 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
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with this software; see the file COPYING. If not, write to
19 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
20 * Boston, MA 02111-1307 USA
22 * As a special exception, the Free Software Foundation gives permission
23 * for additional uses of the text contained in its release of GUILE.
25 * The exception is that, if you link the GUILE library with other files
26 * to produce an executable, this does not by itself cause the
27 * resulting executable to be covered by the GNU General Public License.
28 * Your use of that executable is in no way restricted on account of
29 * linking the GUILE library code into it.
31 * This exception does not however invalidate any other reasons why
32 * the executable file might be covered by the GNU General Public License.
34 * This exception applies only to the code released by the
35 * Free Software Foundation under the name GUILE. If you copy
36 * code from other Free Software Foundation releases into a copy of
37 * GUILE, as the General Public License permits, the exception does
38 * not apply to the code that you add in this way. To avoid misleading
39 * anyone as to the status of such modified files, you must delete
40 * this exception notice from them.
42 * If you write modifications of your own for GUILE, it is your choice
43 * whether to permit this exception to apply to your modifications.
44 * If you do not wish that, delete this exception notice. */
51 #include "libguile/_scm.h"
52 #include "libguile/feature.h"
53 #include "libguile/ports.h"
54 #include "libguile/root.h"
55 #include "libguile/smob.h"
56 #include "libguile/strings.h"
58 #include "libguile/validate.h"
59 #include "libguile/numbers.h"
60 #include "libguile/deprecation.h"
64 static SCM
scm_divbigbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
, int modes
);
65 static SCM
scm_divbigint (SCM x
, long z
, int sgn
, int mode
);
68 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
71 /* FLOBUFLEN is the maximum number of characters neccessary for the
72 * printed or scm_string representation of an inexact number.
74 #define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
77 #if ! defined (HAVE_ISNAN)
82 return (IsNANorINF (x
) && NaN (x
) && ! IsINF (x
)) ? 1 : 0;
85 #if ! defined (HAVE_ISINF)
90 return (IsNANorINF (x
) && IsINF (x
)) ? 1 : 0;
98 static SCM abs_most_negative_fixnum
;
103 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
105 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
107 #define FUNC_NAME s_scm_exact_p
111 } else if (SCM_BIGP (x
)) {
120 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
122 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
124 #define FUNC_NAME s_scm_odd_p
127 return SCM_BOOL ((4 & SCM_UNPACK (n
)) != 0);
128 } else if (SCM_BIGP (n
)) {
129 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) != 0);
130 } else if (scm_inf_p (n
)) {
133 SCM_WRONG_TYPE_ARG (1, n
);
139 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
141 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
143 #define FUNC_NAME s_scm_even_p
146 return SCM_BOOL ((4 & SCM_UNPACK (n
)) == 0);
147 } else if (SCM_BIGP (n
)) {
148 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) == 0);
149 } else if (scm_inf_p (n
)) {
152 SCM_WRONG_TYPE_ARG (1, n
);
160 #if defined (HAVE_ISINF)
162 #elif defined (HAVE_FINITE) && defined (HAVE_ISNAN)
163 return (! (finite (x
) || isnan (x
)));
172 #if defined (HAVE_ISNAN)
179 #define isfinite(x) (! xisinf (x))
181 SCM_DEFINE (scm_inf_p
, "inf?", 1, 0, 0,
183 "Return @code{#t} if @var{n} is infinite, @code{#f}\n"
185 #define FUNC_NAME s_scm_inf_p
188 return SCM_BOOL (xisinf (SCM_REAL_VALUE (n
)));
189 } else if (SCM_COMPLEXP (n
)) {
190 return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n
))
191 || xisinf (SCM_COMPLEX_IMAG (n
)));
198 SCM_DEFINE (scm_nan_p
, "nan?", 1, 0, 0,
200 "Return @code{#t} if @var{n} is a NaN, @code{#f}\n"
202 #define FUNC_NAME s_scm_nan_p
205 return SCM_BOOL (xisnan (SCM_REAL_VALUE (n
)));
206 } else if (SCM_COMPLEXP (n
)) {
207 return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n
))
208 || xisnan (SCM_COMPLEX_IMAG (n
)));
215 /* Guile's idea of infinity. */
216 static double guile_Inf
;
218 /* Guile's idea of not a number. */
219 static double guile_NaN
;
222 guile_ieee_init (void)
224 #if defined (HAVE_ISINF) || defined (HAVE_FINITE)
226 /* Some version of gcc on some old version of Linux used to crash when
227 trying to make Inf and NaN. */
231 guile_Inf
= 1.0 / (tmp
- tmp
);
232 #elif defined (__alpha__) && ! defined (linux)
233 extern unsigned int DINFINITY
[2];
234 guile_Inf
= (*(X_CAST(double *, DINFINITY
)));
241 if (guile_Inf
== tmp
)
249 #if defined (HAVE_ISNAN)
251 #if defined (__alpha__) && ! defined (linux)
252 extern unsigned int DQNAN
[2];
253 guile_NaN
= (*(X_CAST(double *, DQNAN
)));
255 guile_NaN
= guile_Inf
/ guile_Inf
;
261 SCM_DEFINE (scm_inf
, "inf", 0, 0, 0,
264 #define FUNC_NAME s_scm_inf
266 static int initialized
= 0;
272 return scm_make_real (guile_Inf
);
276 SCM_DEFINE (scm_nan
, "nan", 0, 0, 0,
279 #define FUNC_NAME s_scm_nan
281 static int initialized
= 0;
287 return scm_make_real (guile_NaN
);
292 SCM_PRIMITIVE_GENERIC (scm_abs
, "abs", 1, 0, 0,
294 "Return the absolute value of @var{x}.")
298 long int xx
= SCM_INUM (x
);
301 } else if (SCM_POSFIXABLE (-xx
)) {
302 return SCM_MAKINUM (-xx
);
305 return scm_i_long2big (-xx
);
307 scm_num_overflow (s_abs
);
310 } else if (SCM_BIGP (x
)) {
311 if (!SCM_BIGSIGN (x
)) {
314 return scm_i_copybig (x
, 0);
316 } else if (SCM_REALP (x
)) {
317 return scm_make_real (fabs (SCM_REAL_VALUE (x
)));
319 SCM_WTA_DISPATCH_1 (g_scm_abs
, x
, 1, s_scm_abs
);
325 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
326 /* "Return the quotient of the numbers @var{x} and @var{y}."
329 scm_quotient (SCM x
, SCM y
)
332 long xx
= SCM_INUM (x
);
334 long yy
= SCM_INUM (y
);
336 scm_num_overflow (s_quotient
);
339 if (SCM_FIXABLE (z
)) {
340 return SCM_MAKINUM (z
);
343 return scm_i_long2big (z
);
345 scm_num_overflow (s_quotient
);
349 } else if (SCM_BIGP (y
)) {
350 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
351 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
353 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
354 return SCM_MAKINUM (-1);
357 return SCM_MAKINUM (0);
359 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
361 } else if (SCM_BIGP (x
)) {
363 long yy
= SCM_INUM (y
);
365 scm_num_overflow (s_quotient
);
366 } else if (yy
== 1) {
369 long z
= yy
< 0 ? -yy
: yy
;
371 if (z
< SCM_BIGRAD
) {
372 SCM sw
= scm_i_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
373 scm_divbigdig (SCM_BDIGITS (sw
), SCM_NUMDIGS (sw
), (SCM_BIGDIG
) z
);
374 return scm_i_normbig (sw
);
376 #ifndef SCM_DIGSTOOBIG
377 long w
= scm_pseudolong (z
);
378 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
379 (SCM_BIGDIG
*) & w
, SCM_DIGSPERLONG
,
380 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
382 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
383 scm_longdigs (z
, zdigs
);
384 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
385 zdigs
, SCM_DIGSPERLONG
,
386 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
390 } else if (SCM_BIGP (y
)) {
391 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
392 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
393 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 2);
395 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
398 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
403 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
404 /* "Return the remainder of the numbers @var{x} and @var{y}.\n"
406 * "(remainder 13 4) @result{} 1\n"
407 * "(remainder -13 4) @result{} -1\n"
411 scm_remainder (SCM x
, SCM y
)
415 long yy
= SCM_INUM (y
);
417 scm_num_overflow (s_remainder
);
419 long z
= SCM_INUM (x
) % yy
;
420 return SCM_MAKINUM (z
);
422 } else if (SCM_BIGP (y
)) {
423 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
424 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
426 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
427 return SCM_MAKINUM (0);
432 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
434 } else if (SCM_BIGP (x
)) {
436 long yy
= SCM_INUM (y
);
438 scm_num_overflow (s_remainder
);
440 return scm_divbigint (x
, yy
, SCM_BIGSIGN (x
), 0);
442 } else if (SCM_BIGP (y
)) {
443 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
444 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
447 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
450 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
455 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
456 /* "Return the modulo of the numbers @var{x} and @var{y}.\n"
458 * "(modulo 13 4) @result{} 1\n"
459 * "(modulo -13 4) @result{} 3\n"
463 scm_modulo (SCM x
, SCM y
)
466 long xx
= SCM_INUM (x
);
468 long yy
= SCM_INUM (y
);
470 scm_num_overflow (s_modulo
);
473 return SCM_MAKINUM (((yy
< 0) ? (z
> 0) : (z
< 0)) ? z
+ yy
: z
);
475 } else if (SCM_BIGP (y
)) {
476 return (SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0)) ? scm_sum (x
, y
) : x
;
478 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
480 } else if (SCM_BIGP (x
)) {
482 long yy
= SCM_INUM (y
);
484 scm_num_overflow (s_modulo
);
486 return scm_divbigint (x
, yy
, yy
< 0,
487 (SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0)) ? 1 : 0);
489 } else if (SCM_BIGP (y
)) {
490 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
491 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
493 (SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
)) ? 1 : 0);
495 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
498 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
503 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
504 /* "Return the greatest common divisor of all arguments.\n"
505 * "If called without arguments, 0 is returned."
508 scm_gcd (SCM x
, SCM y
)
510 if (SCM_UNBNDP (y
)) {
511 if (SCM_UNBNDP (x
)) {
521 long xx
= SCM_INUM (x
);
522 long yy
= SCM_INUM (y
);
523 long u
= xx
< 0 ? -xx
: xx
;
524 long v
= yy
< 0 ? -yy
: yy
;
529 } else if (yy
== 0) {
535 /* Determine a common factor 2^k */
536 while (!(1 & (u
| v
))) {
542 /* Now, any factor 2^n can be eliminated */
562 if (SCM_POSFIXABLE (result
)) {
563 return SCM_MAKINUM (result
);
566 return scm_i_long2big (result
);
568 scm_num_overflow (s_gcd
);
571 } else if (SCM_BIGP (y
)) {
575 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
577 } else if (SCM_BIGP (x
)) {
580 x
= scm_i_copybig (x
, 0);
583 if (SCM_EQ_P (y
, SCM_INUM0
)) {
588 } else if (SCM_BIGP (y
)) {
590 y
= scm_i_copybig (y
, 0);
591 switch (scm_bigcomp (x
, y
))
596 SCM t
= scm_remainder (x
, y
);
602 y
= scm_remainder (y
, x
);
604 default: /* x == y */
607 /* instead of the switch, we could just
608 return scm_gcd (y, scm_modulo (x, y)); */
610 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
613 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
618 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
619 /* "Return the least common multiple of the arguments.\n"
620 * "If called without arguments, 1 is returned."
623 scm_lcm (SCM n1
, SCM n2
)
625 if (SCM_UNBNDP (n2
)) {
626 if (SCM_UNBNDP (n1
)) {
627 return SCM_MAKINUM (1L);
629 n2
= SCM_MAKINUM (1L);
634 SCM_GASSERT2 (SCM_INUMP (n1
), g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
635 SCM_GASSERT2 (SCM_INUMP (n2
), g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
637 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
638 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
639 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
640 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
644 SCM d
= scm_gcd (n1
, n2
);
645 if (SCM_EQ_P (d
, SCM_INUM0
)) {
648 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
655 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
657 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
661 /* Emulating 2's complement bignums with sign magnitude arithmetic:
666 + + + x (map digit:logand X Y)
667 + - + x (map digit:logand X (lognot (+ -1 Y)))
668 - + + y (map digit:logand (lognot (+ -1 X)) Y)
669 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
674 + + + (map digit:logior X Y)
675 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
676 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
677 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
682 + + + (map digit:logxor X Y)
683 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
684 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
685 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
690 + + (any digit:logand X Y)
691 + - (any digit:logand X (lognot (+ -1 Y)))
692 - + (any digit:logand (lognot (+ -1 X)) Y)
699 SCM
scm_copy_big_dec(SCM b
, int sign
);
700 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, size_t nx
, int zsgn
);
701 SCM
scm_big_ior(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
702 SCM
scm_big_xor(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
703 SCM
scm_big_and(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int zsgn
);
704 SCM
scm_big_test(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
706 SCM
scm_copy_big_dec(SCM b
, int sign
)
709 size_t nx
= SCM_NUMDIGS(b
);
711 SCM ans
= scm_i_mkbig(nx
, sign
);
712 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
713 if SCM_BIGSIGN(b
) do {
715 if (num
< 0) {dst
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
716 else {dst
[i
] = SCM_BIGLO(num
); num
= 0;}
719 while (nx
--) dst
[nx
] = src
[nx
];
723 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, size_t nx
, int zsgn
)
727 SCM z
= scm_i_mkbig(nx
, zsgn
);
728 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
731 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
732 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
734 else do zds
[i
] = x
[i
]; while (++i
< nx
);
738 SCM
scm_big_ior(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
739 /* Assumes nx <= SCM_NUMDIGS(bigy) */
740 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
743 size_t i
= 0, ny
= SCM_NUMDIGS(bigy
);
744 SCM z
= scm_copy_big_dec (bigy
, xsgn
& SCM_BIGSIGN (bigy
));
745 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
749 if (num
< 0) {zds
[i
] |= num
+ SCM_BIGRAD
; num
= -1;}
750 else {zds
[i
] |= SCM_BIGLO(num
); num
= 0;}
752 /* ========= Need to increment zds now =========== */
756 zds
[i
++] = SCM_BIGLO(num
);
757 num
= SCM_BIGDN(num
);
760 scm_i_adjbig(z
, 1 + ny
); /* OOPS, overflowed into next digit. */
761 SCM_BDIGITS(z
)[ny
] = 1;
764 else do zds
[i
] = zds
[i
] | x
[i
]; while (++i
< nx
);
768 SCM
scm_big_xor(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
769 /* Assumes nx <= SCM_NUMDIGS(bigy) */
770 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
773 size_t i
= 0, ny
= SCM_NUMDIGS(bigy
);
774 SCM z
= scm_copy_big_dec(bigy
, xsgn
^ SCM_BIGSIGN(bigy
));
775 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
778 if (num
< 0) {zds
[i
] ^= num
+ SCM_BIGRAD
; num
= -1;}
779 else {zds
[i
] ^= SCM_BIGLO(num
); num
= 0;}
782 zds
[i
] = zds
[i
] ^ x
[i
];
785 if (xsgn
^ SCM_BIGSIGN(bigy
)) {
786 /* ========= Need to increment zds now =========== */
790 zds
[i
++] = SCM_BIGLO(num
);
791 num
= SCM_BIGDN(num
);
792 if (!num
) return scm_i_normbig(z
);
795 return scm_i_normbig(z
);
798 SCM
scm_big_and(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int zsgn
)
799 /* Assumes nx <= SCM_NUMDIGS(bigy) */
800 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
801 /* return sign equals either 0 or SCM_BIGSIGNFLAG */
808 z
= scm_copy_smaller(x
, nx
, zsgn
);
809 x
= SCM_BDIGITS(bigy
);
810 xsgn
= SCM_BIGSIGN(bigy
);
812 else z
= scm_copy_big_dec(bigy
, zsgn
);
813 zds
= SCM_BDIGITS(z
);
818 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
819 else {zds
[i
] &= SCM_BIGLO(num
); num
= 0;}
821 else do zds
[i
] = zds
[i
] & ~x
[i
]; while (++i
< nx
);
822 /* ========= need to increment zds now =========== */
826 zds
[i
++] = SCM_BIGLO(num
);
827 num
= SCM_BIGDN(num
);
828 if (!num
) return scm_i_normbig(z
);
832 unsigned long int carry
= 1;
834 unsigned long int mask
= (SCM_BIGDIG
) ~x
[i
] + carry
;
835 zds
[i
] = zds
[i
] & (SCM_BIGDIG
) mask
;
836 carry
= (mask
>= SCM_BIGRAD
) ? 1 : 0;
838 } else do zds
[i
] = zds
[i
] & x
[i
]; while (++i
< nx
);
839 return scm_i_normbig(z
);
842 SCM
scm_big_test(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
843 /* Assumes nx <= SCM_NUMDIGS(bigy) */
844 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
849 if (SCM_BIGSIGN(bigy
) & xsgn
) return SCM_BOOL_T
;
850 if (SCM_NUMDIGS(bigy
) != nx
&& xsgn
) return SCM_BOOL_T
;
851 y
= SCM_BDIGITS(bigy
);
856 if (y
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
860 if (y
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
864 else if SCM_BIGSIGN(bigy
)
868 if (x
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
872 if (x
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
877 do if (x
[i
] & y
[i
]) return SCM_BOOL_T
;
884 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
886 "Return the bitwise AND of the integer arguments.\n\n"
888 "(logand) @result{} -1\n"
889 "(logand 7) @result{} 7\n"
890 "(logand #b111 #b011 #\b001) @result{} 1\n"
892 #define FUNC_NAME s_scm_logand
896 if (SCM_UNBNDP (n2
)) {
897 if (SCM_UNBNDP (n1
)) {
898 return SCM_MAKINUM (-1);
899 } else if (!SCM_NUMBERP (n1
)) {
900 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
901 } else if (SCM_NUMBERP (n1
)) {
904 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
908 if (SCM_INUMP (n1
)) {
910 if (SCM_INUMP (n2
)) {
911 long nn2
= SCM_INUM (n2
);
912 return SCM_MAKINUM (nn1
& nn2
);
913 } else if SCM_BIGP (n2
) {
916 # ifndef SCM_DIGSTOOBIG
917 long z
= scm_pseudolong (nn1
);
918 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
919 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
920 SCM_BIGSIGNFLAG
, n2
);
922 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
923 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
926 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
927 scm_longdigs (nn1
, zdigs
);
928 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
929 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
931 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
932 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
937 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
939 } else if (SCM_BIGP (n1
)) {
940 if (SCM_INUMP (n2
)) {
944 } else if (SCM_BIGP (n2
)) {
945 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
948 if ((SCM_BIGSIGN (n1
)) && SCM_BIGSIGN (n2
)) {
949 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
950 SCM_BIGSIGNFLAG
, n2
);
952 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
953 SCM_BIGSIGN (n1
), n2
, 0);
956 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
959 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
965 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
967 "Return the bitwise OR of the integer arguments.\n\n"
969 "(logior) @result{} 0\n"
970 "(logior 7) @result{} 7\n"
971 "(logior #b000 #b001 #b011) @result{} 3\n"
973 #define FUNC_NAME s_scm_logior
977 if (SCM_UNBNDP (n2
)) {
978 if (SCM_UNBNDP (n1
)) {
980 } else if (SCM_NUMBERP (n1
)) {
983 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
987 if (SCM_INUMP (n1
)) {
989 if (SCM_INUMP (n2
)) {
990 long nn2
= SCM_INUM (n2
);
991 return SCM_MAKINUM (nn1
| nn2
);
992 } else if (SCM_BIGP (n2
)) {
995 # ifndef SCM_DIGSTOOBIG
996 long z
= scm_pseudolong (nn1
);
997 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
998 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
999 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
1001 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
1002 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
1005 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
1006 scm_longdigs (nn1
, zdigs
);
1007 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
1008 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
,
1009 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
1011 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
1012 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
1017 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1019 } else if (SCM_BIGP (n1
)) {
1020 if (SCM_INUMP (n2
)) {
1022 nn1
= SCM_INUM (n1
);
1024 } else if (SCM_BIGP (n2
)) {
1025 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
1028 if ((!SCM_BIGSIGN (n1
)) && !SCM_BIGSIGN (n2
)) {
1029 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
1030 SCM_BIGSIGN (n1
), n2
);
1032 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
1033 SCM_BIGSIGN (n1
), n2
, SCM_BIGSIGNFLAG
);
1036 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1039 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1045 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
1047 "Return the bitwise XOR of the integer arguments. A bit is\n"
1048 "set in the result if it is set in an odd number of arguments.\n"
1050 "(logxor) @result{} 0\n"
1051 "(logxor 7) @result{} 7\n"
1052 "(logxor #b000 #b001 #b011) @result{} 2\n"
1053 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
1055 #define FUNC_NAME s_scm_logxor
1059 if (SCM_UNBNDP (n2
)) {
1060 if (SCM_UNBNDP (n1
)) {
1062 } else if (SCM_NUMBERP (n1
)) {
1065 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1069 if (SCM_INUMP (n1
)) {
1070 nn1
= SCM_INUM (n1
);
1071 if (SCM_INUMP (n2
)) {
1072 long nn2
= SCM_INUM (n2
);
1073 return SCM_MAKINUM (nn1
^ nn2
);
1074 } else if (SCM_BIGP (n2
)) {
1077 # ifndef SCM_DIGSTOOBIG
1078 long z
= scm_pseudolong (nn1
);
1079 return scm_big_xor ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
1080 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
1082 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
1083 scm_longdigs (nn1
, zdigs
);
1084 return scm_big_xor (zdigs
, SCM_DIGSPERLONG
,
1085 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
1089 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1091 } else if (SCM_BIGP (n1
)) {
1092 if (SCM_INUMP (n2
)) {
1094 nn1
= SCM_INUM (n1
);
1096 } else if (SCM_BIGP (n2
)) {
1097 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {
1100 return scm_big_xor (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
1101 SCM_BIGSIGN (n1
), n2
);
1103 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1106 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1112 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
1115 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
1116 "(logtest #b0100 #b1011) @result{} #f\n"
1117 "(logtest #b0100 #b0111) @result{} #t\n"
1119 #define FUNC_NAME s_scm_logtest
1123 if (SCM_INUMP (j
)) {
1125 if (SCM_INUMP (k
)) {
1126 long nk
= SCM_INUM (k
);
1127 return SCM_BOOL (nj
& nk
);
1128 } else if (SCM_BIGP (k
)) {
1131 # ifndef SCM_DIGSTOOBIG
1132 long z
= scm_pseudolong (nj
);
1133 return scm_big_test ((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
1134 (nj
< 0) ? SCM_BIGSIGNFLAG
: 0, k
);
1136 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
1137 scm_longdigs (nj
, zdigs
);
1138 return scm_big_test (zdigs
, SCM_DIGSPERLONG
,
1139 (nj
< 0) ? SCM_BIGSIGNFLAG
: 0, k
);
1143 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1145 } else if (SCM_BIGP (j
)) {
1146 if (SCM_INUMP (k
)) {
1150 } else if (SCM_BIGP (k
)) {
1151 if (SCM_NUMDIGS (j
) > SCM_NUMDIGS (k
)) {
1154 return scm_big_test (SCM_BDIGITS (j
), SCM_NUMDIGS (j
),
1155 SCM_BIGSIGN (j
), k
);
1157 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1160 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
1166 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
1169 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1170 "(logbit? 0 #b1101) @result{} #t\n"
1171 "(logbit? 1 #b1101) @result{} #f\n"
1172 "(logbit? 2 #b1101) @result{} #t\n"
1173 "(logbit? 3 #b1101) @result{} #t\n"
1174 "(logbit? 4 #b1101) @result{} #f\n"
1176 #define FUNC_NAME s_scm_logbit_p
1178 unsigned long int iindex
;
1180 SCM_VALIDATE_INUM_MIN (SCM_ARG1
, index
, 0);
1181 iindex
= (unsigned long int) SCM_INUM (index
);
1183 if (SCM_INUMP (j
)) {
1184 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1185 } else if (SCM_BIGP (j
)) {
1186 if (SCM_NUMDIGS (j
) * SCM_BITSPERDIG
< iindex
) {
1188 } else if (SCM_BIGSIGN (j
)) {
1191 SCM_BIGDIG
* x
= SCM_BDIGITS (j
);
1192 size_t nx
= iindex
/ SCM_BITSPERDIG
;
1196 return SCM_BOOL (((1L << (iindex
% SCM_BITSPERDIG
)) & num
) == 0);
1197 } else if (num
< 0) {
1204 return SCM_BOOL (SCM_BDIGITS (j
) [iindex
/ SCM_BITSPERDIG
]
1205 & (1L << (iindex
% SCM_BITSPERDIG
)));
1208 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1214 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1216 "Return the integer which is the 2s-complement of the integer\n"
1220 "(number->string (lognot #b10000000) 2)\n"
1221 " @result{} \"-10000001\"\n"
1222 "(number->string (lognot #b0) 2)\n"
1223 " @result{} \"-1\"\n"
1225 #define FUNC_NAME s_scm_lognot
1227 return scm_difference (SCM_MAKINUM (-1L), n
);
1231 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1233 "Return @var{n} raised to the non-negative integer exponent\n"
1237 "(integer-expt 2 5)\n"
1239 "(integer-expt -3 3)\n"
1242 #define FUNC_NAME s_scm_integer_expt
1244 SCM acc
= SCM_MAKINUM (1L);
1247 /* 0^0 == 1 according to R5RS */
1248 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1249 return SCM_FALSEP (scm_zero_p(k
)) ? n
: acc
;
1250 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1251 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1255 double r
= SCM_REAL_VALUE (k
);
1258 SCM_WRONG_TYPE_ARG (2, k
);
1261 SCM_VALIDATE_ULONG_COPY (2, k
, i2
);
1265 n
= scm_divide (n
, SCM_UNDEFINED
);
1272 return scm_product (acc
, n
);
1274 acc
= scm_product (acc
, n
);
1275 n
= scm_product (n
, n
);
1281 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1283 "The function ash performs an arithmetic shift left by @var{cnt}\n"
1284 "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n"
1285 "means, that the function does not guarantee to keep the bit\n"
1286 "structure of @var{n}, but rather guarantees that the result\n"
1287 "will always be rounded towards minus infinity. Therefore, the\n"
1288 "results of ash and a corresponding bitwise shift will differ if\n"
1289 "@var{n} is negative.\n"
1291 "Formally, the function returns an integer equivalent to\n"
1292 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n"
1295 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1296 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
1298 #define FUNC_NAME s_scm_ash
1303 SCM_VALIDATE_INUM (1, n
)
1305 SCM_VALIDATE_INUM (2, cnt
);
1307 bits_to_shift
= SCM_INUM (cnt
);
1309 if (bits_to_shift
< 0) {
1310 /* Shift right by abs(cnt) bits. This is realized as a division by
1311 div:=2^abs(cnt). However, to guarantee the floor rounding, negative
1312 values require some special treatment.
1314 SCM div
= scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift
));
1315 if (SCM_FALSEP (scm_negative_p (n
)))
1316 return scm_quotient (n
, div
);
1318 return scm_sum (SCM_MAKINUM (-1L),
1319 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1321 /* Shift left is done by multiplication with 2^CNT */
1322 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1324 if (bits_to_shift
< 0)
1325 /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */
1326 return SCM_MAKINUM (SCM_SRS (SCM_INUM (n
), -bits_to_shift
));
1328 /* Shift left, but make sure not to leave the range of inums */
1329 SCM res
= SCM_MAKINUM (SCM_INUM (n
) << cnt
);
1330 if (SCM_INUM (res
) >> cnt
!= SCM_INUM (n
))
1331 scm_num_overflow (FUNC_NAME
);
1339 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1340 (SCM n
, SCM start
, SCM end
),
1341 "Return the integer composed of the @var{start} (inclusive)\n"
1342 "through @var{end} (exclusive) bits of @var{n}. The\n"
1343 "@var{start}th bit becomes the 0-th bit in the result.\n"
1346 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1347 " @result{} \"1010\"\n"
1348 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1349 " @result{} \"10110\"\n"
1351 #define FUNC_NAME s_scm_bit_extract
1353 unsigned long int istart
, iend
;
1354 SCM_VALIDATE_INUM_MIN_COPY (2, start
,0, istart
);
1355 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1356 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1358 if (SCM_INUMP (n
)) {
1359 long int in
= SCM_INUM (n
);
1360 unsigned long int bits
= iend
- istart
;
1362 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
1364 /* Since we emulate two's complement encoded numbers, this special
1365 * case requires us to produce a result that has more bits than can be
1366 * stored in a fixnum. Thus, we fall back to the more general
1367 * algorithm that is used for bignums.
1372 if (istart
< SCM_I_FIXNUM_BIT
)
1375 if (bits
< SCM_I_FIXNUM_BIT
)
1376 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1377 else /* we know: in >= 0 */
1378 return SCM_MAKINUM (in
);
1382 return SCM_MAKINUM (-1L & ((1L << bits
) - 1));
1386 return SCM_MAKINUM (0);
1388 } else if (SCM_BIGP (n
)) {
1391 SCM num1
= SCM_MAKINUM (1L);
1392 SCM num2
= SCM_MAKINUM (2L);
1393 SCM bits
= SCM_MAKINUM (iend
- istart
);
1394 SCM mask
= scm_difference (scm_integer_expt (num2
, bits
), num1
);
1395 return scm_logand (mask
, scm_ash (n
, SCM_MAKINUM (-istart
)));
1398 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1404 static const char scm_logtab
[] = {
1405 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1408 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1410 "Return the number of bits in integer @var{n}. If integer is\n"
1411 "positive, the 1-bits in its binary representation are counted.\n"
1412 "If negative, the 0-bits in its two's-complement binary\n"
1413 "representation are counted. If 0, 0 is returned.\n"
1416 "(logcount #b10101010)\n"
1423 #define FUNC_NAME s_scm_logcount
1425 if (SCM_INUMP (n
)) {
1426 unsigned long int c
= 0;
1427 long int nn
= SCM_INUM (n
);
1432 c
+= scm_logtab
[15 & nn
];
1435 return SCM_MAKINUM (c
);
1436 } else if (SCM_BIGP (n
)) {
1437 if (SCM_BIGSIGN (n
)) {
1438 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n
));
1440 unsigned long int c
= 0;
1441 size_t i
= SCM_NUMDIGS (n
);
1442 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1445 for (d
= ds
[i
]; d
; d
>>= 4) {
1446 c
+= scm_logtab
[15 & d
];
1449 return SCM_MAKINUM (c
);
1452 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1458 static const char scm_ilentab
[] = {
1459 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1462 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1464 "Return the number of bits necessary to represent @var{n}.\n"
1467 "(integer-length #b10101010)\n"
1469 "(integer-length 0)\n"
1471 "(integer-length #b1111)\n"
1474 #define FUNC_NAME s_scm_integer_length
1476 if (SCM_INUMP (n
)) {
1477 unsigned long int c
= 0;
1479 long int nn
= SCM_INUM (n
);
1485 l
= scm_ilentab
[15 & nn
];
1488 return SCM_MAKINUM (c
- 4 + l
);
1489 } else if (SCM_BIGP (n
)) {
1490 if (SCM_BIGSIGN (n
)) {
1491 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n
));
1493 unsigned long int digs
= SCM_NUMDIGS (n
) - 1;
1494 unsigned long int c
= digs
* SCM_BITSPERDIG
;
1496 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1497 SCM_BIGDIG d
= ds
[digs
];
1500 l
= scm_ilentab
[15 & d
];
1503 return SCM_MAKINUM (c
- 4 + l
);
1506 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1513 static const char s_bignum
[] = "bignum";
1516 scm_i_mkbig (size_t nlen
, int sign
)
1521 if (((nlen
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1522 scm_memory_error (s_bignum
);
1524 base
= scm_gc_malloc (nlen
* sizeof (SCM_BIGDIG
), s_bignum
);
1526 v
= scm_cell (SCM_MAKE_BIGNUM_TAG (nlen
, sign
), (scm_t_bits
) base
);
1531 scm_i_big2inum (SCM b
, size_t l
)
1533 unsigned long num
= 0;
1534 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1536 num
= SCM_BIGUP (num
) + tmp
[l
];
1537 if (!SCM_BIGSIGN (b
))
1539 if (SCM_POSFIXABLE (num
))
1540 return SCM_MAKINUM (num
);
1542 else if (num
<= -SCM_MOST_NEGATIVE_FIXNUM
)
1543 return SCM_MAKINUM (-num
);
1547 static const char s_adjbig
[] = "scm_i_adjbig";
1550 scm_i_adjbig (SCM b
, size_t nlen
)
1553 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1554 scm_memory_error (s_adjbig
);
1560 scm_gc_realloc (SCM_BDIGITS (b
),
1561 SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
),
1562 nsiz
* sizeof (SCM_BIGDIG
), s_bignum
));
1564 SCM_SET_BIGNUM_BASE (b
, digits
);
1565 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1572 scm_i_normbig (SCM b
)
1575 size_t nlen
= SCM_NUMDIGS (b
);
1577 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1579 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1580 while (nlen
-- && !zds
[nlen
]);
1582 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1583 if (SCM_INUMP (b
= scm_i_big2inum (b
, (size_t) nlen
)))
1585 if (SCM_NUMDIGS (b
) == nlen
)
1587 return scm_i_adjbig (b
, (size_t) nlen
);
1591 scm_i_copybig (SCM b
, int sign
)
1593 size_t i
= SCM_NUMDIGS (b
);
1594 SCM ans
= scm_i_mkbig (i
, sign
);
1595 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1602 scm_bigcomp (SCM x
, SCM y
)
1604 int xsign
= SCM_BIGSIGN (x
);
1605 int ysign
= SCM_BIGSIGN (y
);
1608 /* Look at the signs, first. */
1614 /* They're the same sign, so see which one has more digits. Note
1615 that, if they are negative, the longer number is the lesser. */
1616 ylen
= SCM_NUMDIGS (y
);
1617 xlen
= SCM_NUMDIGS (x
);
1619 return (xsign
) ? -1 : 1;
1621 return (xsign
) ? 1 : -1;
1623 /* They have the same number of digits, so find the most significant
1624 digit where they differ. */
1628 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1629 /* Make the discrimination based on the digit that differs. */
1630 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1632 : (xsign
? 1 : -1));
1635 /* The numbers are identical. */
1639 #ifndef SCM_DIGSTOOBIG
1643 scm_pseudolong (long x
)
1648 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1654 while (i
< SCM_DIGSPERLONG
)
1656 p
.bd
[i
++] = SCM_BIGLO (x
);
1659 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1667 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1672 while (i
< SCM_DIGSPERLONG
)
1674 digs
[i
++] = SCM_BIGLO (x
);
1683 scm_addbig (SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int sgny
)
1685 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1686 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1688 size_t i
= 0, ny
= SCM_NUMDIGS (bigy
);
1689 SCM z
= scm_i_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1690 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1691 if (xsgn
^ SCM_BIGSIGN (z
))
1695 num
+= (long) zds
[i
] - x
[i
];
1698 zds
[i
] = num
+ SCM_BIGRAD
;
1703 zds
[i
] = SCM_BIGLO (num
);
1708 if (num
&& nx
== ny
)
1712 SCM_SET_CELL_WORD_0 (z
, SCM_CELL_WORD_0 (z
) ^ SCM_BIGSIGNFLAG
);
1715 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1716 zds
[i
++] = SCM_BIGLO (num
);
1717 num
= SCM_BIGDN (num
);
1727 zds
[i
++] = num
+ SCM_BIGRAD
;
1732 zds
[i
++] = SCM_BIGLO (num
);
1741 num
+= (long) zds
[i
] + x
[i
];
1742 zds
[i
++] = SCM_BIGLO (num
);
1743 num
= SCM_BIGDN (num
);
1751 zds
[i
++] = SCM_BIGLO (num
);
1752 num
= SCM_BIGDN (num
);
1758 z
= scm_i_adjbig (z
, ny
+ 1);
1759 SCM_BDIGITS (z
)[ny
] = num
;
1763 return scm_i_normbig (z
);
1768 scm_mulbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
)
1770 size_t i
= 0, j
= nx
+ ny
;
1771 unsigned long n
= 0;
1772 SCM z
= scm_i_mkbig (j
, sgn
);
1773 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1783 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1784 zds
[i
+ j
++] = SCM_BIGLO (n
);
1796 return scm_i_normbig (z
);
1801 scm_divbigdig (SCM_BIGDIG
* ds
, size_t h
, SCM_BIGDIG div
)
1803 register unsigned long t2
= 0;
1806 t2
= SCM_BIGUP (t2
) + ds
[h
];
1816 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1822 register unsigned long t2
= 0;
1823 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1824 size_t nd
= SCM_NUMDIGS (x
);
1826 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1829 return SCM_MAKINUM (sgn
? -t2
: t2
);
1832 #ifndef SCM_DIGSTOOBIG
1833 unsigned long t2
= scm_pseudolong (z
);
1834 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1835 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1838 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1839 scm_longdigs (z
, t2
);
1840 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1841 t2
, SCM_DIGSPERLONG
,
1849 scm_divbigbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
, int modes
)
1851 /* modes description
1855 3 quotient but returns SCM_UNDEFINED if division is not exact. */
1856 size_t i
= 0, j
= 0;
1858 unsigned long t2
= 0;
1860 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1861 /* algorithm requires nx >= ny */
1865 case 0: /* remainder -- just return x */
1866 z
= scm_i_mkbig (nx
, sgn
);
1867 zds
= SCM_BDIGITS (z
);
1874 case 1: /* scm_modulo -- return y-x */
1875 z
= scm_i_mkbig (ny
, sgn
);
1876 zds
= SCM_BDIGITS (z
);
1879 num
+= (long) y
[i
] - x
[i
];
1882 zds
[i
] = num
+ SCM_BIGRAD
;
1897 zds
[i
++] = num
+ SCM_BIGRAD
;
1908 return SCM_INUM0
; /* quotient is zero */
1910 return SCM_UNDEFINED
; /* the division is not exact */
1913 z
= scm_i_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1914 zds
= SCM_BDIGITS (z
);
1918 ny
--; /* in case y came in as a psuedolong */
1919 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1920 { /* normalize operands */
1921 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1922 newy
= scm_i_mkbig (ny
, 0);
1923 yds
= SCM_BDIGITS (newy
);
1926 t2
+= (unsigned long) y
[j
] * d
;
1927 yds
[j
++] = SCM_BIGLO (t2
);
1928 t2
= SCM_BIGDN (t2
);
1935 t2
+= (unsigned long) x
[j
] * d
;
1936 zds
[j
++] = SCM_BIGLO (t2
);
1937 t2
= SCM_BIGDN (t2
);
1947 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1949 { /* loop over digits of quotient */
1950 if (zds
[j
] == y
[ny
- 1])
1951 qhat
= SCM_BIGRAD
- 1;
1953 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1960 { /* multiply and subtract */
1961 t2
+= (unsigned long) y
[i
] * qhat
;
1962 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1965 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1970 zds
[j
- ny
+ i
] = num
;
1973 t2
= SCM_BIGDN (t2
);
1976 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1978 { /* "add back" required */
1984 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1985 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1986 num
= SCM_BIGDN (num
);
1997 case 3: /* check that remainder==0 */
1998 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
2000 return SCM_UNDEFINED
;
2001 case 2: /* move quotient down in z */
2002 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
2003 for (i
= 0; i
< j
; i
++)
2004 zds
[i
] = zds
[i
+ ny
];
2007 case 1: /* subtract for scm_modulo */
2013 num
+= y
[i
] - zds
[i
];
2017 zds
[i
] = num
+ SCM_BIGRAD
;
2029 case 0: /* just normalize remainder */
2031 scm_divbigdig (zds
, ny
, d
);
2034 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
2035 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
2036 if (SCM_INUMP (z
= scm_i_big2inum (z
, j
)))
2038 return scm_i_adjbig (z
, j
);
2046 /*** NUMBERS -> STRINGS ***/
2048 static const double fx
[] =
2049 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
2050 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
2051 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
2052 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
2058 idbl2str (double f
, char *a
)
2060 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
2066 #ifdef HAVE_COPYSIGN
2067 double sgn
= copysign (1.0, f
);
2073 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
2079 strcpy (a
, "-inf.0");
2081 strcpy (a
, "+inf.0");
2084 else if (xisnan (f
))
2086 strcpy (a
, "+nan.0");
2096 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
2097 make-uniform-vector, from causing infinite loops. */
2101 if (exp
-- < DBL_MIN_10_EXP
)
2112 if (exp
++ > DBL_MAX_10_EXP
)
2132 if (f
+ fx
[wp
] >= 10.0)
2139 dpt
= (exp
+ 9999) % 3;
2143 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2168 if (f
+ fx
[wp
] >= 1.0)
2182 if ((dpt
> 4) && (exp
> 6))
2184 d
= (a
[0] == '-' ? 2 : 1);
2185 for (i
= ch
++; i
> d
; i
--)
2198 if (a
[ch
- 1] == '.')
2199 a
[ch
++] = '0'; /* trailing zero */
2208 for (i
= 10; i
<= exp
; i
*= 10);
2209 for (i
/= 10; i
; i
/= 10)
2211 a
[ch
++] = exp
/ i
+ '0';
2220 iflo2str (SCM flt
, char *str
)
2223 if (SCM_REALP (flt
))
2224 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2227 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2228 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2230 double imag
= SCM_COMPLEX_IMAG (flt
);
2231 /* Don't output a '+' for negative numbers or for Inf and
2232 NaN. They will provide their own sign. */
2233 if (0 <= imag
&& !xisinf (imag
) && !xisnan (imag
))
2235 i
+= idbl2str (imag
, &str
[i
]);
2242 /* convert a long to a string (unterminated). returns the number of
2243 characters in the result.
2245 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2247 scm_iint2str (long num
, int rad
, char *p
)
2251 unsigned long n
= (num
< 0) ? -num
: num
;
2253 for (n
/= rad
; n
> 0; n
/= rad
)
2270 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2279 big2str (SCM b
, unsigned int radix
)
2281 SCM t
= scm_i_copybig (b
, 0); /* sign of temp doesn't matter */
2282 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2283 size_t i
= SCM_NUMDIGS (t
);
2284 size_t j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2285 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2286 : (SCM_BITSPERDIG
* i
) + 2;
2289 SCM_BIGDIG radpow
= 1, radmod
= 0;
2290 SCM ss
= scm_allocate_string (j
);
2291 char *s
= SCM_STRING_CHARS (ss
), c
;
2295 return scm_makfrom0str ("0");
2298 while ((long) radpow
* radix
< SCM_BIGRAD
)
2303 while ((i
|| radmod
) && j
)
2307 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2315 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2318 if (SCM_BIGSIGN (b
))
2323 /* The pre-reserved string length was too large. */
2324 unsigned long int length
= SCM_STRING_LENGTH (ss
);
2325 ss
= scm_substring (ss
, SCM_MAKINUM (j
), SCM_MAKINUM (length
));
2328 return scm_return_first (ss
, t
);
2333 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2335 "Return a string holding the external representation of the\n"
2336 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2337 "inexact, a radix of 10 will be used.")
2338 #define FUNC_NAME s_scm_number_to_string
2342 if (SCM_UNBNDP (radix
)) {
2345 SCM_VALIDATE_INUM (2, radix
);
2346 base
= SCM_INUM (radix
);
2347 SCM_ASSERT_RANGE (2, radix
, base
>= 2);
2350 if (SCM_INUMP (n
)) {
2351 char num_buf
[SCM_INTBUFLEN
];
2352 size_t length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2353 return scm_mem2string (num_buf
, length
);
2354 } else if (SCM_BIGP (n
)) {
2355 return big2str (n
, (unsigned int) base
);
2356 } else if (SCM_INEXACTP (n
)) {
2357 char num_buf
[FLOBUFLEN
];
2358 return scm_mem2string (num_buf
, iflo2str (n
, num_buf
));
2360 SCM_WRONG_TYPE_ARG (1, n
);
2366 /* These print routines are stubbed here so that scm_repl.c doesn't need
2367 SCM_BIGDIG conditionals */
2370 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2372 char num_buf
[FLOBUFLEN
];
2373 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2378 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2380 char num_buf
[FLOBUFLEN
];
2381 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2386 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2389 exp
= big2str (exp
, (unsigned int) 10);
2390 scm_lfwrite (SCM_STRING_CHARS (exp
), (size_t) SCM_STRING_LENGTH (exp
), port
);
2392 scm_ipruk ("bignum", exp
, port
);
2396 /*** END nums->strs ***/
2399 /*** STRINGS -> NUMBERS ***/
2401 /* The following functions implement the conversion from strings to numbers.
2402 * The implementation somehow follows the grammar for numbers as it is given
2403 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
2404 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
2405 * points should be noted about the implementation:
2406 * * Each function keeps a local index variable 'idx' that points at the
2407 * current position within the parsed string. The global index is only
2408 * updated if the function could parse the corresponding syntactic unit
2410 * * Similarly, the functions keep track of indicators of inexactness ('#',
2411 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
2412 * global exactness information is only updated after each part has been
2413 * successfully parsed.
2414 * * Sequences of digits are parsed into temporary variables holding fixnums.
2415 * Only if these fixnums would overflow, the result variables are updated
2416 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
2417 * the temporary variables holding the fixnums are cleared, and the process
2418 * starts over again. If for example fixnums were able to store five decimal
2419 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
2420 * and the result was computed as 12345 * 100000 + 67890. In other words,
2421 * only every five digits two bignum operations were performed.
2424 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
2426 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
2428 /* In non ASCII-style encodings the following macro might not work. */
2429 #define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
2432 mem2uinteger (const char* mem
, size_t len
, unsigned int *p_idx
,
2433 unsigned int radix
, enum t_exactness
*p_exactness
)
2435 unsigned int idx
= *p_idx
;
2436 unsigned int hash_seen
= 0;
2437 scm_t_bits shift
= 1;
2439 unsigned int digit_value
;
2449 digit_value
= XDIGIT2UINT (c
);
2450 if (digit_value
>= radix
)
2454 result
= SCM_MAKINUM (digit_value
);
2462 digit_value
= XDIGIT2UINT (c
);
2463 if (digit_value
>= radix
)
2475 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
2477 result
= scm_product (result
, SCM_MAKINUM (shift
));
2479 result
= scm_sum (result
, SCM_MAKINUM (add
));
2486 shift
= shift
* radix
;
2487 add
= add
* radix
+ digit_value
;
2492 result
= scm_product (result
, SCM_MAKINUM (shift
));
2494 result
= scm_sum (result
, SCM_MAKINUM (add
));
2498 *p_exactness
= INEXACT
;
2504 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2505 * covers the parts of the rules that start at a potential point. The value
2506 * of the digits up to the point have been parsed by the caller and are given
2507 * in variable result. The content of *p_exactness indicates, whether a hash
2508 * has already been seen in the digits before the point.
2511 /* In non ASCII-style encodings the following macro might not work. */
2512 #define DIGIT2UINT(d) ((d) - '0')
2515 mem2decimal_from_point (SCM result
, const char* mem
, size_t len
,
2516 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
2518 unsigned int idx
= *p_idx
;
2519 enum t_exactness x
= *p_exactness
;
2524 if (mem
[idx
] == '.')
2526 scm_t_bits shift
= 1;
2528 unsigned int digit_value
;
2529 SCM big_shift
= SCM_MAKINUM (1);
2540 digit_value
= DIGIT2UINT (c
);
2551 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
2553 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2554 result
= scm_product (result
, SCM_MAKINUM (shift
));
2556 result
= scm_sum (result
, SCM_MAKINUM (add
));
2564 add
= add
* 10 + digit_value
;
2570 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2571 result
= scm_product (result
, SCM_MAKINUM (shift
));
2572 result
= scm_sum (result
, SCM_MAKINUM (add
));
2575 result
= scm_divide (result
, big_shift
);
2577 /* We've seen a decimal point, thus the value is implicitly inexact. */
2589 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2620 exponent
= DIGIT2UINT (c
);
2627 if (exponent
<= SCM_MAXEXP
)
2628 exponent
= exponent
* 10 + DIGIT2UINT (c
);
2634 if (exponent
> SCM_MAXEXP
)
2636 size_t exp_len
= idx
- start
;
2637 SCM exp_string
= scm_mem2string (&mem
[start
], exp_len
);
2638 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
2639 scm_out_of_range ("string->number", exp_num
);
2642 e
= scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent
));
2644 result
= scm_product (result
, e
);
2646 result
= scm_divide (result
, e
);
2648 /* We've seen an exponent, thus the value is implicitly inexact. */
2666 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2669 mem2ureal (const char* mem
, size_t len
, unsigned int *p_idx
,
2670 unsigned int radix
, enum t_exactness
*p_exactness
)
2672 unsigned int idx
= *p_idx
;
2678 if (idx
+5 <= len
&& !strncmp (mem
+idx
, "inf.0", 5))
2684 if (idx
+4 < len
&& !strncmp (mem
+idx
, "nan.", 4))
2686 enum t_exactness x
= EXACT
;
2688 /* Cobble up the fraction. We might want to set the NaN's
2689 mantissa from it. */
2691 mem2uinteger (mem
, len
, &idx
, 10, &x
);
2696 if (mem
[idx
] == '.')
2700 else if (idx
+ 1 == len
)
2702 else if (!isdigit (mem
[idx
+ 1]))
2705 result
= mem2decimal_from_point (SCM_MAKINUM (0), mem
, len
,
2706 p_idx
, p_exactness
);
2710 enum t_exactness x
= EXACT
;
2713 uinteger
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2714 if (SCM_FALSEP (uinteger
))
2719 else if (mem
[idx
] == '/')
2725 divisor
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2726 if (SCM_FALSEP (divisor
))
2729 result
= scm_divide (uinteger
, divisor
);
2731 else if (radix
== 10)
2733 result
= mem2decimal_from_point (uinteger
, mem
, len
, &idx
, &x
);
2734 if (SCM_FALSEP (result
))
2745 /* When returning an inexact zero, make sure it is represented as a
2746 floating point value so that we can change its sign.
2748 if (SCM_EQ_P (result
, SCM_MAKINUM(0)) && *p_exactness
== INEXACT
)
2749 result
= scm_make_real (0.0);
2755 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2758 mem2complex (const char* mem
, size_t len
, unsigned int idx
,
2759 unsigned int radix
, enum t_exactness
*p_exactness
)
2783 ureal
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2784 if (SCM_FALSEP (ureal
))
2786 /* input must be either +i or -i */
2791 if (mem
[idx
] == 'i' || mem
[idx
] == 'I')
2797 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign
));
2804 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2805 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
2814 /* either +<ureal>i or -<ureal>i */
2821 return scm_make_rectangular (SCM_MAKINUM (0), ureal
);
2824 /* polar input: <real>@<real>. */
2849 angle
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2850 if (SCM_FALSEP (angle
))
2855 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2856 angle
= scm_difference (angle
, SCM_UNDEFINED
);
2858 result
= scm_make_polar (ureal
, angle
);
2863 /* expecting input matching <real>[+-]<ureal>?i */
2870 int sign
= (c
== '+') ? 1 : -1;
2871 SCM imag
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2873 if (SCM_FALSEP (imag
))
2874 imag
= SCM_MAKINUM (sign
);
2875 else if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2876 imag
= scm_difference (imag
, SCM_UNDEFINED
);
2880 if (mem
[idx
] != 'i' && mem
[idx
] != 'I')
2887 return scm_make_rectangular (ureal
, imag
);
2896 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2898 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
2901 scm_i_mem2number (const char* mem
, size_t len
, unsigned int default_radix
)
2903 unsigned int idx
= 0;
2904 unsigned int radix
= NO_RADIX
;
2905 enum t_exactness forced_x
= NO_EXACTNESS
;
2906 enum t_exactness implicit_x
= EXACT
;
2909 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2910 while (idx
+ 2 < len
&& mem
[idx
] == '#')
2912 switch (mem
[idx
+ 1])
2915 if (radix
!= NO_RADIX
)
2920 if (radix
!= NO_RADIX
)
2925 if (forced_x
!= NO_EXACTNESS
)
2930 if (forced_x
!= NO_EXACTNESS
)
2935 if (radix
!= NO_RADIX
)
2940 if (radix
!= NO_RADIX
)
2950 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2951 if (radix
== NO_RADIX
)
2952 result
= mem2complex (mem
, len
, idx
, default_radix
, &implicit_x
);
2954 result
= mem2complex (mem
, len
, idx
, (unsigned int) radix
, &implicit_x
);
2956 if (SCM_FALSEP (result
))
2962 if (SCM_INEXACTP (result
))
2963 /* FIXME: This may change the value. */
2964 return scm_inexact_to_exact (result
);
2968 if (SCM_INEXACTP (result
))
2971 return scm_exact_to_inexact (result
);
2974 if (implicit_x
== INEXACT
)
2976 if (SCM_INEXACTP (result
))
2979 return scm_exact_to_inexact (result
);
2987 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2988 (SCM string
, SCM radix
),
2989 "Return a number of the maximally precise representation\n"
2990 "expressed by the given @var{string}. @var{radix} must be an\n"
2991 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2992 "is a default radix that may be overridden by an explicit radix\n"
2993 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2994 "supplied, then the default radix is 10. If string is not a\n"
2995 "syntactically valid notation for a number, then\n"
2996 "@code{string->number} returns @code{#f}.")
2997 #define FUNC_NAME s_scm_string_to_number
3001 SCM_VALIDATE_STRING (1, string
);
3002 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix
,2,10, base
);
3003 answer
= scm_i_mem2number (SCM_STRING_CHARS (string
),
3004 SCM_STRING_LENGTH (string
),
3006 return scm_return_first (answer
, string
);
3011 /*** END strs->nums ***/
3015 scm_make_real (double x
)
3017 SCM z
= scm_double_cell (scm_tc16_real
, 0, 0, 0);
3019 SCM_REAL_VALUE (z
) = x
;
3025 scm_make_complex (double x
, double y
)
3028 return scm_make_real (x
);
3031 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_gc_malloc (2*sizeof (double),
3033 SCM_COMPLEX_REAL (z
) = x
;
3034 SCM_COMPLEX_IMAG (z
) = y
;
3041 scm_bigequal (SCM x
, SCM y
)
3044 if (0 == scm_bigcomp (x
, y
))
3051 scm_real_equalp (SCM x
, SCM y
)
3053 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3057 scm_complex_equalp (SCM x
, SCM y
)
3059 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
3060 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
3065 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
3066 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
3067 * "else. Note that the sets of complex, real, rational and\n"
3068 * "integer values form subsets of the set of numbers, i. e. the\n"
3069 * "predicate will be fulfilled for any number."
3071 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
3073 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
3074 "otherwise. Note that the sets of real, rational and integer\n"
3075 "values form subsets of the set of complex numbers, i. e. the\n"
3076 "predicate will also be fulfilled if @var{x} is a real,\n"
3077 "rational or integer number.")
3078 #define FUNC_NAME s_scm_number_p
3080 return SCM_BOOL (SCM_NUMBERP (x
));
3085 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
3086 /* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
3087 * "Note that the sets of integer and rational values form a subset\n"
3088 * "of the set of real numbers, i. e. the predicate will also\n"
3089 * "be fulfilled if @var{x} is an integer or a rational number."
3091 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
3093 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
3094 "otherwise. Note that the set of integer values forms a subset of\n"
3095 "the set of rational numbers, i. e. the predicate will also be\n"
3096 "fulfilled if @var{x} is an integer number. Real numbers\n"
3097 "will also satisfy this predicate, because of their limited\n"
3099 #define FUNC_NAME s_scm_real_p
3101 if (SCM_INUMP (x
)) {
3103 } else if (SCM_IMP (x
)) {
3105 } else if (SCM_REALP (x
)) {
3107 } else if (SCM_BIGP (x
)) {
3116 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
3118 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
3120 #define FUNC_NAME s_scm_integer_p
3129 if (!SCM_INEXACTP (x
))
3131 if (SCM_COMPLEXP (x
))
3133 r
= SCM_REAL_VALUE (x
);
3141 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
3143 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
3145 #define FUNC_NAME s_scm_inexact_p
3147 return SCM_BOOL (SCM_INEXACTP (x
));
3152 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
3153 /* "Return @code{#t} if all parameters are numerically equal." */
3155 scm_num_eq_p (SCM x
, SCM y
)
3157 if (SCM_INUMP (x
)) {
3158 long xx
= SCM_INUM (x
);
3159 if (SCM_INUMP (y
)) {
3160 long yy
= SCM_INUM (y
);
3161 return SCM_BOOL (xx
== yy
);
3162 } else if (SCM_BIGP (y
)) {
3164 } else if (SCM_REALP (y
)) {
3165 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
3166 } else if (SCM_COMPLEXP (y
)) {
3167 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
3168 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3170 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3172 } else if (SCM_BIGP (x
)) {
3173 if (SCM_INUMP (y
)) {
3175 } else if (SCM_BIGP (y
)) {
3176 return SCM_BOOL (0 == scm_bigcomp (x
, y
));
3177 } else if (SCM_REALP (y
)) {
3178 return SCM_BOOL (scm_i_big2dbl (x
) == SCM_REAL_VALUE (y
));
3179 } else if (SCM_COMPLEXP (y
)) {
3180 return SCM_BOOL ((scm_i_big2dbl (x
) == SCM_COMPLEX_REAL (y
))
3181 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3183 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3185 } else if (SCM_REALP (x
)) {
3186 if (SCM_INUMP (y
)) {
3187 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3188 } else if (SCM_BIGP (y
)) {
3189 return SCM_BOOL (SCM_REAL_VALUE (x
) == scm_i_big2dbl (y
));
3190 } else if (SCM_REALP (y
)) {
3191 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3192 } else if (SCM_COMPLEXP (y
)) {
3193 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3194 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3196 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3198 } else if (SCM_COMPLEXP (x
)) {
3199 if (SCM_INUMP (y
)) {
3200 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3201 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3202 } else if (SCM_BIGP (y
)) {
3203 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == scm_i_big2dbl (y
))
3204 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3205 } else if (SCM_REALP (y
)) {
3206 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3207 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3208 } else if (SCM_COMPLEXP (y
)) {
3209 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3210 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3212 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3215 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3220 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3221 /* "Return @code{#t} if the list of parameters is monotonically\n"
3225 scm_less_p (SCM x
, SCM y
)
3227 if (SCM_INUMP (x
)) {
3228 long xx
= SCM_INUM (x
);
3229 if (SCM_INUMP (y
)) {
3230 long yy
= SCM_INUM (y
);
3231 return SCM_BOOL (xx
< yy
);
3232 } else if (SCM_BIGP (y
)) {
3233 return SCM_BOOL (!SCM_BIGSIGN (y
));
3234 } else if (SCM_REALP (y
)) {
3235 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3237 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3239 } else if (SCM_BIGP (x
)) {
3240 if (SCM_INUMP (y
)) {
3241 return SCM_BOOL (SCM_BIGSIGN (x
));
3242 } else if (SCM_BIGP (y
)) {
3243 return SCM_BOOL (1 == scm_bigcomp (x
, y
));
3244 } else if (SCM_REALP (y
)) {
3245 return SCM_BOOL (scm_i_big2dbl (x
) < SCM_REAL_VALUE (y
));
3247 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3249 } else if (SCM_REALP (x
)) {
3250 if (SCM_INUMP (y
)) {
3251 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3252 } else if (SCM_BIGP (y
)) {
3253 return SCM_BOOL (SCM_REAL_VALUE (x
) < scm_i_big2dbl (y
));
3254 } else if (SCM_REALP (y
)) {
3255 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3257 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3260 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3265 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3266 /* "Return @code{#t} if the list of parameters is monotonically\n"
3269 #define FUNC_NAME s_scm_gr_p
3271 scm_gr_p (SCM x
, SCM y
)
3273 if (!SCM_NUMBERP (x
))
3274 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3275 else if (!SCM_NUMBERP (y
))
3276 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3278 return scm_less_p (y
, x
);
3283 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3284 /* "Return @code{#t} if the list of parameters is monotonically\n"
3287 #define FUNC_NAME s_scm_leq_p
3289 scm_leq_p (SCM x
, SCM y
)
3291 if (!SCM_NUMBERP (x
))
3292 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3293 else if (!SCM_NUMBERP (y
))
3294 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3295 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
3298 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3303 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3304 /* "Return @code{#t} if the list of parameters is monotonically\n"
3307 #define FUNC_NAME s_scm_geq_p
3309 scm_geq_p (SCM x
, SCM y
)
3311 if (!SCM_NUMBERP (x
))
3312 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3313 else if (!SCM_NUMBERP (y
))
3314 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3315 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
3318 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3323 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3324 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3330 if (SCM_INUMP (z
)) {
3331 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3332 } else if (SCM_BIGP (z
)) {
3334 } else if (SCM_REALP (z
)) {
3335 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3336 } else if (SCM_COMPLEXP (z
)) {
3337 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3338 && SCM_COMPLEX_IMAG (z
) == 0.0);
3340 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3345 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3346 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3350 scm_positive_p (SCM x
)
3352 if (SCM_INUMP (x
)) {
3353 return SCM_BOOL (SCM_INUM (x
) > 0);
3354 } else if (SCM_BIGP (x
)) {
3355 return SCM_BOOL (!SCM_BIGSIGN (x
));
3356 } else if (SCM_REALP (x
)) {
3357 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3359 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3364 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3365 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3369 scm_negative_p (SCM x
)
3371 if (SCM_INUMP (x
)) {
3372 return SCM_BOOL (SCM_INUM (x
) < 0);
3373 } else if (SCM_BIGP (x
)) {
3374 return SCM_BOOL (SCM_BIGSIGN (x
));
3375 } else if (SCM_REALP (x
)) {
3376 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3378 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3383 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3384 /* "Return the maximum of all parameter values."
3387 scm_max (SCM x
, SCM y
)
3389 if (SCM_UNBNDP (y
)) {
3390 if (SCM_UNBNDP (x
)) {
3391 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
3392 } else if (SCM_NUMBERP (x
)) {
3395 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3399 if (SCM_INUMP (x
)) {
3400 long xx
= SCM_INUM (x
);
3401 if (SCM_INUMP (y
)) {
3402 long yy
= SCM_INUM (y
);
3403 return (xx
< yy
) ? y
: x
;
3404 } else if (SCM_BIGP (y
)) {
3405 return SCM_BIGSIGN (y
) ? x
: y
;
3406 } else if (SCM_REALP (y
)) {
3408 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3410 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3412 } else if (SCM_BIGP (x
)) {
3413 if (SCM_INUMP (y
)) {
3414 return SCM_BIGSIGN (x
) ? y
: x
;
3415 } else if (SCM_BIGP (y
)) {
3416 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3417 } else if (SCM_REALP (y
)) {
3418 double z
= scm_i_big2dbl (x
);
3419 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3421 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3423 } else if (SCM_REALP (x
)) {
3424 if (SCM_INUMP (y
)) {
3425 double z
= SCM_INUM (y
);
3426 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3427 } else if (SCM_BIGP (y
)) {
3428 double z
= scm_i_big2dbl (y
);
3429 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3430 } else if (SCM_REALP (y
)) {
3431 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? y
: x
;
3433 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3436 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3441 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3442 /* "Return the minium of all parameter values."
3445 scm_min (SCM x
, SCM y
)
3447 if (SCM_UNBNDP (y
)) {
3448 if (SCM_UNBNDP (x
)) {
3449 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
3450 } else if (SCM_NUMBERP (x
)) {
3453 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3457 if (SCM_INUMP (x
)) {
3458 long xx
= SCM_INUM (x
);
3459 if (SCM_INUMP (y
)) {
3460 long yy
= SCM_INUM (y
);
3461 return (xx
< yy
) ? x
: y
;
3462 } else if (SCM_BIGP (y
)) {
3463 return SCM_BIGSIGN (y
) ? y
: x
;
3464 } else if (SCM_REALP (y
)) {
3466 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3468 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3470 } else if (SCM_BIGP (x
)) {
3471 if (SCM_INUMP (y
)) {
3472 return SCM_BIGSIGN (x
) ? x
: y
;
3473 } else if (SCM_BIGP (y
)) {
3474 return (-1 == scm_bigcomp (x
, y
)) ? y
: x
;
3475 } else if (SCM_REALP (y
)) {
3476 double z
= scm_i_big2dbl (x
);
3477 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3479 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3481 } else if (SCM_REALP (x
)) {
3482 if (SCM_INUMP (y
)) {
3483 double z
= SCM_INUM (y
);
3484 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3485 } else if (SCM_BIGP (y
)) {
3486 double z
= scm_i_big2dbl (y
);
3487 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3488 } else if (SCM_REALP (y
)) {
3489 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? x
: y
;
3491 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3494 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3499 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3500 /* "Return the sum of all parameter values. Return 0 if called without\n"
3504 scm_sum (SCM x
, SCM y
)
3506 if (SCM_UNBNDP (y
)) {
3507 if (SCM_UNBNDP (x
)) {
3509 } else if (SCM_NUMBERP (x
)) {
3512 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3516 if (SCM_INUMP (x
)) {
3517 long int xx
= SCM_INUM (x
);
3518 if (SCM_INUMP (y
)) {
3519 long int yy
= SCM_INUM (y
);
3520 long int z
= xx
+ yy
;
3521 if (SCM_FIXABLE (z
)) {
3522 return SCM_MAKINUM (z
);
3525 return scm_i_long2big (z
);
3526 #else /* SCM_BIGDIG */
3527 return scm_make_real ((double) z
);
3528 #endif /* SCM_BIGDIG */
3530 } else if (SCM_BIGP (y
)) {
3533 long int xx
= SCM_INUM (x
);
3534 #ifndef SCM_DIGSTOOBIG
3535 long z
= scm_pseudolong (xx
);
3536 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3537 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3538 #else /* SCM_DIGSTOOBIG */
3539 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3540 scm_longdigs (xx
, zdigs
);
3541 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3542 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3543 #endif /* SCM_DIGSTOOBIG */
3545 } else if (SCM_REALP (y
)) {
3546 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3547 } else if (SCM_COMPLEXP (y
)) {
3548 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3549 SCM_COMPLEX_IMAG (y
));
3551 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3553 } else if (SCM_BIGP (x
)) {
3554 if (SCM_INUMP (y
)) {
3557 } else if (SCM_BIGP (y
)) {
3558 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
)) {
3561 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3562 SCM_BIGSIGN (x
), y
, 0);
3563 } else if (SCM_REALP (y
)) {
3564 return scm_make_real (scm_i_big2dbl (x
) + SCM_REAL_VALUE (y
));
3565 } else if (SCM_COMPLEXP (y
)) {
3566 return scm_make_complex (scm_i_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3567 SCM_COMPLEX_IMAG (y
));
3569 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3571 } else if (SCM_REALP (x
)) {
3572 if (SCM_INUMP (y
)) {
3573 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3574 } else if (SCM_BIGP (y
)) {
3575 return scm_make_real (SCM_REAL_VALUE (x
) + scm_i_big2dbl (y
));
3576 } else if (SCM_REALP (y
)) {
3577 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3578 } else if (SCM_COMPLEXP (y
)) {
3579 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3580 SCM_COMPLEX_IMAG (y
));
3582 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3584 } else if (SCM_COMPLEXP (x
)) {
3585 if (SCM_INUMP (y
)) {
3586 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3587 SCM_COMPLEX_IMAG (x
));
3588 } else if (SCM_BIGP (y
)) {
3589 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_i_big2dbl (y
),
3590 SCM_COMPLEX_IMAG (x
));
3591 } else if (SCM_REALP (y
)) {
3592 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3593 SCM_COMPLEX_IMAG (x
));
3594 } else if (SCM_COMPLEXP (y
)) {
3595 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3596 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3598 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3601 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3606 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3607 /* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3608 * the sum of all but the first argument are subtracted from the first
3610 #define FUNC_NAME s_difference
3612 scm_difference (SCM x
, SCM y
)
3614 if (SCM_UNBNDP (y
)) {
3615 if (SCM_UNBNDP (x
)) {
3616 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3617 } else if (SCM_INUMP (x
)) {
3618 long xx
= -SCM_INUM (x
);
3619 if (SCM_FIXABLE (xx
)) {
3620 return SCM_MAKINUM (xx
);
3623 return scm_i_long2big (xx
);
3625 return scm_make_real ((double) xx
);
3628 } else if (SCM_BIGP (x
)) {
3629 SCM z
= scm_i_copybig (x
, !SCM_BIGSIGN (x
));
3630 unsigned int digs
= SCM_NUMDIGS (z
);
3631 unsigned int size
= digs
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
;
3632 return size
<= sizeof (SCM
) ? scm_i_big2inum (z
, digs
) : z
;
3633 } else if (SCM_REALP (x
)) {
3634 return scm_make_real (-SCM_REAL_VALUE (x
));
3635 } else if (SCM_COMPLEXP (x
)) {
3636 return scm_make_complex (-SCM_COMPLEX_REAL (x
), -SCM_COMPLEX_IMAG (x
));
3638 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3642 if (SCM_INUMP (x
)) {
3643 long int xx
= SCM_INUM (x
);
3644 if (SCM_INUMP (y
)) {
3645 long int yy
= SCM_INUM (y
);
3646 long int z
= xx
- yy
;
3647 if (SCM_FIXABLE (z
)) {
3648 return SCM_MAKINUM (z
);
3651 return scm_i_long2big (z
);
3653 return scm_make_real ((double) z
);
3656 } else if (SCM_BIGP (y
)) {
3657 #ifndef SCM_DIGSTOOBIG
3658 long z
= scm_pseudolong (xx
);
3659 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3660 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3662 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3663 scm_longdigs (xx
, zdigs
);
3664 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3665 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3667 } else if (SCM_REALP (y
)) {
3668 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
3669 } else if (SCM_COMPLEXP (y
)) {
3670 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
3671 -SCM_COMPLEX_IMAG (y
));
3673 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3675 } else if (SCM_BIGP (x
)) {
3676 if (SCM_INUMP (y
)) {
3677 long int yy
= SCM_INUM (y
);
3678 #ifndef SCM_DIGSTOOBIG
3679 long z
= scm_pseudolong (yy
);
3680 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3681 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3683 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3684 scm_longdigs (yy
, zdigs
);
3685 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3686 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3688 } else if (SCM_BIGP (y
)) {
3689 return (SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3690 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3691 SCM_BIGSIGN (x
), y
, SCM_BIGSIGNFLAG
)
3692 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3693 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
, x
, 0);
3694 } else if (SCM_REALP (y
)) {
3695 return scm_make_real (scm_i_big2dbl (x
) - SCM_REAL_VALUE (y
));
3696 } else if (SCM_COMPLEXP (y
)) {
3697 return scm_make_complex (scm_i_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3698 - SCM_COMPLEX_IMAG (y
));
3700 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3702 } else if (SCM_REALP (x
)) {
3703 if (SCM_INUMP (y
)) {
3704 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
3705 } else if (SCM_BIGP (y
)) {
3706 return scm_make_real (SCM_REAL_VALUE (x
) - scm_i_big2dbl (y
));
3707 } else if (SCM_REALP (y
)) {
3708 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3709 } else if (SCM_COMPLEXP (y
)) {
3710 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3711 -SCM_COMPLEX_IMAG (y
));
3713 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3715 } else if (SCM_COMPLEXP (x
)) {
3716 if (SCM_INUMP (y
)) {
3717 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
3718 SCM_COMPLEX_IMAG (x
));
3719 } else if (SCM_BIGP (y
)) {
3720 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_i_big2dbl (y
),
3721 SCM_COMPLEX_IMAG (x
));
3722 } else if (SCM_REALP (y
)) {
3723 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3724 SCM_COMPLEX_IMAG (x
));
3725 } else if (SCM_COMPLEXP (y
)) {
3726 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3727 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3729 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3732 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3737 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3738 /* "Return the product of all arguments. If called without arguments,\n"
3742 scm_product (SCM x
, SCM y
)
3744 if (SCM_UNBNDP (y
)) {
3745 if (SCM_UNBNDP (x
)) {
3746 return SCM_MAKINUM (1L);
3747 } else if (SCM_NUMBERP (x
)) {
3750 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3754 if (SCM_INUMP (x
)) {
3762 } else if (xx
== 1) {
3766 if (SCM_INUMP (y
)) {
3767 long yy
= SCM_INUM (y
);
3769 SCM k
= SCM_MAKINUM (kk
);
3770 if (kk
!= SCM_INUM (k
) || kk
/ xx
!= yy
) {
3772 int sgn
= (xx
< 0) ^ (yy
< 0);
3773 #ifndef SCM_DIGSTOOBIG
3774 long i
= scm_pseudolong (xx
);
3775 long j
= scm_pseudolong (yy
);
3776 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3777 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3778 #else /* SCM_DIGSTOOBIG */
3779 SCM_BIGDIG xdigs
[SCM_DIGSPERLONG
];
3780 SCM_BIGDIG ydigs
[SCM_DIGSPERLONG
];
3781 scm_longdigs (xx
, xdigs
);
3782 scm_longdigs (yy
, ydigs
);
3783 return scm_mulbig (xdigs
, SCM_DIGSPERLONG
,
3784 ydigs
, SCM_DIGSPERLONG
,
3788 return scm_make_real (((double) xx
) * ((double) yy
));
3793 } else if (SCM_BIGP (y
)) {
3794 #ifndef SCM_DIGSTOOBIG
3795 long z
= scm_pseudolong (xx
);
3796 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3797 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3798 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3800 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3801 scm_longdigs (xx
, zdigs
);
3802 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3803 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3804 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3806 } else if (SCM_REALP (y
)) {
3807 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3808 } else if (SCM_COMPLEXP (y
)) {
3809 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3810 xx
* SCM_COMPLEX_IMAG (y
));
3812 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3814 } else if (SCM_BIGP (x
)) {
3815 if (SCM_INUMP (y
)) {
3818 } else if (SCM_BIGP (y
)) {
3819 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3820 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3821 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3822 } else if (SCM_REALP (y
)) {
3823 return scm_make_real (scm_i_big2dbl (x
) * SCM_REAL_VALUE (y
));
3824 } else if (SCM_COMPLEXP (y
)) {
3825 double z
= scm_i_big2dbl (x
);
3826 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3827 z
* SCM_COMPLEX_IMAG (y
));
3829 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3831 } else if (SCM_REALP (x
)) {
3832 if (SCM_INUMP (y
)) {
3833 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3834 } else if (SCM_BIGP (y
)) {
3835 return scm_make_real (scm_i_big2dbl (y
) * SCM_REAL_VALUE (x
));
3836 } else if (SCM_REALP (y
)) {
3837 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
3838 } else if (SCM_COMPLEXP (y
)) {
3839 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
3840 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3842 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3844 } else if (SCM_COMPLEXP (x
)) {
3845 if (SCM_INUMP (y
)) {
3846 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3847 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3848 } else if (SCM_BIGP (y
)) {
3849 double z
= scm_i_big2dbl (y
);
3850 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
3851 z
* SCM_COMPLEX_IMAG (x
));
3852 } else if (SCM_REALP (y
)) {
3853 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3854 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
3855 } else if (SCM_COMPLEXP (y
)) {
3856 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
3857 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
3858 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3859 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3861 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3864 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3870 scm_num2dbl (SCM a
, const char *why
)
3871 #define FUNC_NAME why
3873 if (SCM_INUMP (a
)) {
3874 return (double) SCM_INUM (a
);
3875 } else if (SCM_BIGP (a
)) {
3876 return scm_i_big2dbl (a
);
3877 } else if (SCM_REALP (a
)) {
3878 return (SCM_REAL_VALUE (a
));
3880 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3885 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
3886 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
3887 #define ALLOW_DIVIDE_BY_ZERO
3888 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
3891 /* The code below for complex division is adapted from the GNU
3892 libstdc++, which adapted it from f2c's libF77, and is subject to
3895 /****************************************************************
3896 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
3898 Permission to use, copy, modify, and distribute this software
3899 and its documentation for any purpose and without fee is hereby
3900 granted, provided that the above copyright notice appear in all
3901 copies and that both that the copyright notice and this
3902 permission notice and warranty disclaimer appear in supporting
3903 documentation, and that the names of AT&T Bell Laboratories or
3904 Bellcore or any of their entities not be used in advertising or
3905 publicity pertaining to distribution of the software without
3906 specific, written prior permission.
3908 AT&T and Bellcore disclaim all warranties with regard to this
3909 software, including all implied warranties of merchantability
3910 and fitness. In no event shall AT&T or Bellcore be liable for
3911 any special, indirect or consequential damages or any damages
3912 whatsoever resulting from loss of use, data or profits, whether
3913 in an action of contract, negligence or other tortious action,
3914 arising out of or in connection with the use or performance of
3916 ****************************************************************/
3918 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3919 /* Divide the first argument by the product of the remaining
3920 arguments. If called with one argument @var{z1}, 1/@var{z1} is
3922 #define FUNC_NAME s_divide
3924 scm_divide (SCM x
, SCM y
)
3928 if (SCM_UNBNDP (y
)) {
3929 if (SCM_UNBNDP (x
)) {
3930 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
3931 } else if (SCM_INUMP (x
)) {
3932 long xx
= SCM_INUM (x
);
3933 if (xx
== 1 || xx
== -1) {
3935 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3936 } else if (xx
== 0) {
3937 scm_num_overflow (s_divide
);
3940 return scm_make_real (1.0 / (double) xx
);
3942 } else if (SCM_BIGP (x
)) {
3943 return scm_make_real (1.0 / scm_i_big2dbl (x
));
3944 } else if (SCM_REALP (x
)) {
3945 double xx
= SCM_REAL_VALUE (x
);
3946 #ifndef ALLOW_DIVIDE_BY_ZERO
3948 scm_num_overflow (s_divide
);
3951 return scm_make_real (1.0 / xx
);
3952 } else if (SCM_COMPLEXP (x
)) {
3953 double r
= SCM_COMPLEX_REAL (x
);
3954 double i
= SCM_COMPLEX_IMAG (x
);
3957 double d
= i
* (1.0 + t
* t
);
3958 return scm_make_complex (t
/ d
, -1.0 / d
);
3961 double d
= r
* (1.0 + t
* t
);
3962 return scm_make_complex (1.0 / d
, -t
/ d
);
3965 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3969 if (SCM_INUMP (x
)) {
3970 long xx
= SCM_INUM (x
);
3971 if (SCM_INUMP (y
)) {
3972 long yy
= SCM_INUM (y
);
3974 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3975 scm_num_overflow (s_divide
);
3977 return scm_make_real ((double) xx
/ (double) yy
);
3979 } else if (xx
% yy
!= 0) {
3980 return scm_make_real ((double) xx
/ (double) yy
);
3983 if (SCM_FIXABLE (z
)) {
3984 return SCM_MAKINUM (z
);
3987 return scm_i_long2big (z
);
3989 return scm_make_real ((double) xx
/ (double) yy
);
3993 } else if (SCM_BIGP (y
)) {
3994 return scm_make_real ((double) xx
/ scm_i_big2dbl (y
));
3995 } else if (SCM_REALP (y
)) {
3996 double yy
= SCM_REAL_VALUE (y
);
3997 #ifndef ALLOW_DIVIDE_BY_ZERO
3999 scm_num_overflow (s_divide
);
4002 return scm_make_real ((double) xx
/ yy
);
4003 } else if (SCM_COMPLEXP (y
)) {
4005 complex_div
: /* y _must_ be a complex number */
4007 double r
= SCM_COMPLEX_REAL (y
);
4008 double i
= SCM_COMPLEX_IMAG (y
);
4011 double d
= i
* (1.0 + t
* t
);
4012 return scm_make_complex ((a
* t
) / d
, -a
/ d
);
4015 double d
= r
* (1.0 + t
* t
);
4016 return scm_make_complex (a
/ d
, -(a
* t
) / d
);
4020 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4022 } else if (SCM_BIGP (x
)) {
4023 if (SCM_INUMP (y
)) {
4024 long int yy
= SCM_INUM (y
);
4026 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4027 scm_num_overflow (s_divide
);
4029 if (scm_bigcomp (x
, scm_i_int2big (0)) == 0)
4034 } else if (yy
== 1) {
4037 long z
= yy
< 0 ? -yy
: yy
;
4038 if (z
< SCM_BIGRAD
) {
4039 SCM w
= scm_i_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
4040 return scm_divbigdig (SCM_BDIGITS (w
), SCM_NUMDIGS (w
),
4042 ? scm_make_real (scm_i_big2dbl (x
) / (double) yy
)
4043 : scm_i_normbig (w
);
4046 #ifndef SCM_DIGSTOOBIG
4047 z
= scm_pseudolong (z
);
4048 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
4049 (SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
4050 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
4052 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
4053 scm_longdigs (z
, zdigs
);
4054 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
4055 zdigs
, SCM_DIGSPERLONG
,
4056 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
4058 return (!SCM_UNBNDP (w
))
4060 : scm_make_real (scm_i_big2dbl (x
) / (double) yy
);
4063 } else if (SCM_BIGP (y
)) {
4064 SCM w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
4065 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
4066 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 3);
4067 return (!SCM_UNBNDP (w
))
4069 : scm_make_real (scm_i_big2dbl (x
) / scm_i_big2dbl (y
));
4070 } else if (SCM_REALP (y
)) {
4071 double yy
= SCM_REAL_VALUE (y
);
4072 #ifndef ALLOW_DIVIDE_BY_ZERO
4074 scm_num_overflow (s_divide
);
4077 return scm_make_real (scm_i_big2dbl (x
) / yy
);
4078 } else if (SCM_COMPLEXP (y
)) {
4079 a
= scm_i_big2dbl (x
);
4082 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4084 } else if (SCM_REALP (x
)) {
4085 double rx
= SCM_REAL_VALUE (x
);
4086 if (SCM_INUMP (y
)) {
4087 long int yy
= SCM_INUM (y
);
4088 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4090 scm_num_overflow (s_divide
);
4093 return scm_make_real (rx
/ (double) yy
);
4094 } else if (SCM_BIGP (y
)) {
4095 return scm_make_real (rx
/ scm_i_big2dbl (y
));
4096 } else if (SCM_REALP (y
)) {
4097 double yy
= SCM_REAL_VALUE (y
);
4098 #ifndef ALLOW_DIVIDE_BY_ZERO
4100 scm_num_overflow (s_divide
);
4103 return scm_make_real (rx
/ yy
);
4104 } else if (SCM_COMPLEXP (y
)) {
4108 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4110 } else if (SCM_COMPLEXP (x
)) {
4111 double rx
= SCM_COMPLEX_REAL (x
);
4112 double ix
= SCM_COMPLEX_IMAG (x
);
4113 if (SCM_INUMP (y
)) {
4114 long int yy
= SCM_INUM (y
);
4115 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4117 scm_num_overflow (s_divide
);
4122 return scm_make_complex (rx
/ d
, ix
/ d
);
4124 } else if (SCM_BIGP (y
)) {
4125 double d
= scm_i_big2dbl (y
);
4126 return scm_make_complex (rx
/ d
, ix
/ d
);
4127 } else if (SCM_REALP (y
)) {
4128 double yy
= SCM_REAL_VALUE (y
);
4129 #ifndef ALLOW_DIVIDE_BY_ZERO
4131 scm_num_overflow (s_divide
);
4134 return scm_make_complex (rx
/ yy
, ix
/ yy
);
4135 } else if (SCM_COMPLEXP (y
)) {
4136 double ry
= SCM_COMPLEX_REAL (y
);
4137 double iy
= SCM_COMPLEX_IMAG (y
);
4140 double d
= iy
* (1.0 + t
* t
);
4141 return scm_make_complex ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
4144 double d
= ry
* (1.0 + t
* t
);
4145 return scm_make_complex ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
4148 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4151 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
4156 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
4157 /* "Return the inverse hyperbolic sine of @var{x}."
4160 scm_asinh (double x
)
4162 return log (x
+ sqrt (x
* x
+ 1));
4168 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
4169 /* "Return the inverse hyperbolic cosine of @var{x}."
4172 scm_acosh (double x
)
4174 return log (x
+ sqrt (x
* x
- 1));
4180 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
4181 /* "Return the inverse hyperbolic tangent of @var{x}."
4184 scm_atanh (double x
)
4186 return 0.5 * log ((1 + x
) / (1 - x
));
4192 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
4193 /* "Round the inexact number @var{x} towards zero."
4196 scm_truncate (double x
)
4205 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
4206 /* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
4207 * "numbers, round towards even."
4210 scm_round (double x
)
4212 double plus_half
= x
+ 0.5;
4213 double result
= floor (plus_half
);
4214 /* Adjust so that the scm_round is towards even. */
4215 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
4216 ? result
- 1 : result
;
4220 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
4221 /* "Round the number @var{x} towards minus infinity."
4223 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
4224 /* "Round the number @var{x} towards infinity."
4226 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
4227 /* "Return the square root of the real number @var{x}."
4229 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
4230 /* "Return the absolute value of the real number @var{x}."
4232 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
4233 /* "Return the @var{x}th power of e."
4235 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
4236 /* "Return the natural logarithm of the real number @var{x}."
4238 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
4239 /* "Return the sine of the real number @var{x}."
4241 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
4242 /* "Return the cosine of the real number @var{x}."
4244 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
4245 /* "Return the tangent of the real number @var{x}."
4247 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
4248 /* "Return the arc sine of the real number @var{x}."
4250 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
4251 /* "Return the arc cosine of the real number @var{x}."
4253 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
4254 /* "Return the arc tangent of the real number @var{x}."
4256 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
4257 /* "Return the hyperbolic sine of the real number @var{x}."
4259 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
4260 /* "Return the hyperbolic cosine of the real number @var{x}."
4262 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
4263 /* "Return the hyperbolic tangent of the real number @var{x}."
4271 static void scm_two_doubles (SCM x
,
4273 const char *sstring
,
4277 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
4279 if (SCM_INUMP (x
)) {
4280 xy
->x
= SCM_INUM (x
);
4281 } else if (SCM_BIGP (x
)) {
4282 xy
->x
= scm_i_big2dbl (x
);
4283 } else if (SCM_REALP (x
)) {
4284 xy
->x
= SCM_REAL_VALUE (x
);
4286 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
4289 if (SCM_INUMP (y
)) {
4290 xy
->y
= SCM_INUM (y
);
4291 } else if (SCM_BIGP (y
)) {
4292 xy
->y
= scm_i_big2dbl (y
);
4293 } else if (SCM_REALP (y
)) {
4294 xy
->y
= SCM_REAL_VALUE (y
);
4296 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
4301 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
4303 "Return @var{x} raised to the power of @var{y}. This\n"
4304 "procedure does not accept complex arguments.")
4305 #define FUNC_NAME s_scm_sys_expt
4308 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4309 return scm_make_real (pow (xy
.x
, xy
.y
));
4314 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4316 "Return the arc tangent of the two arguments @var{x} and\n"
4317 "@var{y}. This is similar to calculating the arc tangent of\n"
4318 "@var{x} / @var{y}, except that the signs of both arguments\n"
4319 "are used to determine the quadrant of the result. This\n"
4320 "procedure does not accept complex arguments.")
4321 #define FUNC_NAME s_scm_sys_atan2
4324 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4325 return scm_make_real (atan2 (xy
.x
, xy
.y
));
4330 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4331 (SCM real
, SCM imaginary
),
4332 "Return a complex number constructed of the given @var{real} and\n"
4333 "@var{imaginary} parts.")
4334 #define FUNC_NAME s_scm_make_rectangular
4337 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
4338 return scm_make_complex (xy
.x
, xy
.y
);
4344 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4346 "Return the complex number @var{x} * e^(i * @var{y}).")
4347 #define FUNC_NAME s_scm_make_polar
4350 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4351 return scm_make_complex (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
4356 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4357 /* "Return the real part of the number @var{z}."
4360 scm_real_part (SCM z
)
4362 if (SCM_INUMP (z
)) {
4364 } else if (SCM_BIGP (z
)) {
4366 } else if (SCM_REALP (z
)) {
4368 } else if (SCM_COMPLEXP (z
)) {
4369 return scm_make_real (SCM_COMPLEX_REAL (z
));
4371 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4376 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4377 /* "Return the imaginary part of the number @var{z}."
4380 scm_imag_part (SCM z
)
4382 if (SCM_INUMP (z
)) {
4384 } else if (SCM_BIGP (z
)) {
4386 } else if (SCM_REALP (z
)) {
4388 } else if (SCM_COMPLEXP (z
)) {
4389 return scm_make_real (SCM_COMPLEX_IMAG (z
));
4391 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4396 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4397 /* "Return the magnitude of the number @var{z}. This is the same as\n"
4398 * "@code{abs} for real arguments, but also allows complex numbers."
4401 scm_magnitude (SCM z
)
4403 if (SCM_INUMP (z
)) {
4404 long int zz
= SCM_INUM (z
);
4407 } else if (SCM_POSFIXABLE (-zz
)) {
4408 return SCM_MAKINUM (-zz
);
4411 return scm_i_long2big (-zz
);
4413 scm_num_overflow (s_magnitude
);
4416 } else if (SCM_BIGP (z
)) {
4417 if (!SCM_BIGSIGN (z
)) {
4420 return scm_i_copybig (z
, 0);
4422 } else if (SCM_REALP (z
)) {
4423 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
4424 } else if (SCM_COMPLEXP (z
)) {
4425 double r
= SCM_COMPLEX_REAL (z
);
4426 double i
= SCM_COMPLEX_IMAG (z
);
4427 return scm_make_real (sqrt (i
* i
+ r
* r
));
4429 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4434 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
4435 /* "Return the angle of the complex number @var{z}."
4440 if (SCM_INUMP (z
)) {
4441 if (SCM_INUM (z
) >= 0) {
4442 return scm_make_real (atan2 (0.0, 1.0));
4444 return scm_make_real (atan2 (0.0, -1.0));
4446 } else if (SCM_BIGP (z
)) {
4447 if (SCM_BIGSIGN (z
)) {
4448 return scm_make_real (atan2 (0.0, -1.0));
4450 return scm_make_real (atan2 (0.0, 1.0));
4452 } else if (SCM_REALP (z
)) {
4453 return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z
)));
4454 } else if (SCM_COMPLEXP (z
)) {
4455 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
4457 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
4462 SCM_GPROC (s_exact_to_inexact
, "exact->inexact", 1, 0, 0, scm_exact_to_inexact
, g_exact_to_inexact
);
4463 /* Convert the number @var{x} to its inexact representation.\n"
4466 scm_exact_to_inexact (SCM z
)
4469 return scm_make_real ((double) SCM_INUM (z
));
4470 else if (SCM_BIGP (z
))
4471 return scm_make_real (scm_i_big2dbl (z
));
4472 else if (SCM_INEXACTP (z
))
4475 SCM_WTA_DISPATCH_1 (g_exact_to_inexact
, z
, 1, s_exact_to_inexact
);
4479 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4481 "Return an exact number that is numerically closest to @var{z}.")
4482 #define FUNC_NAME s_scm_inexact_to_exact
4484 if (SCM_INUMP (z
)) {
4486 } else if (SCM_BIGP (z
)) {
4488 } else if (SCM_REALP (z
)) {
4489 double u
= floor (SCM_REAL_VALUE (z
) + 0.5);
4491 if (SCM_FIXABLE (lu
)) {
4492 return SCM_MAKINUM (lu
);
4494 } else if (isfinite (u
) && !xisnan (u
)) {
4495 return scm_i_dbl2big (u
);
4498 scm_num_overflow (s_scm_inexact_to_exact
);
4501 SCM_WRONG_TYPE_ARG (1, z
);
4508 /* d must be integer */
4511 scm_i_dbl2big (double d
)
4517 double u
= (d
< 0) ? -d
: d
;
4518 while (0 != floor (u
))
4523 ans
= scm_i_mkbig (i
, d
< 0);
4524 digits
= SCM_BDIGITS (ans
);
4533 scm_num_overflow ("dbl2big");
4538 scm_i_big2dbl (SCM b
)
4541 size_t i
= SCM_NUMDIGS (b
);
4542 SCM_BIGDIG
*digits
= SCM_BDIGITS (b
);
4544 ans
= digits
[i
] + SCM_BIGRAD
* ans
;
4545 if (SCM_BIGSIGN (b
))
4552 #ifdef HAVE_LONG_LONGS
4554 # define ULLONG_MAX ((unsigned long long) (-1))
4555 # define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
4556 # define LLONG_MIN (~LLONG_MAX)
4560 /* Parameters for creating integer conversion routines.
4562 Define the following preprocessor macros before including
4563 "libguile/num2integral.i.c":
4565 NUM2INTEGRAL - the name of the function for converting from a
4566 Scheme object to the integral type. This function
4567 will be defined when including "num2integral.i.c".
4569 INTEGRAL2NUM - the name of the function for converting from the
4570 integral type to a Scheme object. This function
4573 INTEGRAL2BIG - the name of an internal function that createas a
4574 bignum from the integral type. This function will
4575 be defined. The name should start with "scm_i_".
4577 ITYPE - the name of the integral type.
4579 UNSIGNED - Define this when ITYPE is an unsigned type. Do not
4580 define it otherwise.
4583 - the name of the the unsigned variant of the
4584 integral type. If you don't define this, it defaults
4585 to "unsigned ITYPE" for signed types and simply "ITYPE"
4588 SIZEOF_ITYPE - an expression giving the size of the integral type in
4589 bytes. This expression must be computable by the
4590 preprocessor. If you don't know a value for this,
4591 don't define it. The purpose of this parameter is
4592 mainly to suppress some warnings. The generated
4593 code will work correctly without it.
4596 #define NUM2INTEGRAL scm_num2short
4597 #define INTEGRAL2NUM scm_short2num
4598 #define INTEGRAL2BIG scm_i_short2big
4600 #define SIZEOF_ITYPE SIZEOF_SHORT
4601 #include "libguile/num2integral.i.c"
4603 #define NUM2INTEGRAL scm_num2ushort
4604 #define INTEGRAL2NUM scm_ushort2num
4605 #define INTEGRAL2BIG scm_i_ushort2big
4607 #define ITYPE unsigned short
4608 #define SIZEOF_ITYPE SIZEOF_SHORT
4609 #include "libguile/num2integral.i.c"
4611 #define NUM2INTEGRAL scm_num2int
4612 #define INTEGRAL2NUM scm_int2num
4613 #define INTEGRAL2BIG scm_i_int2big
4615 #define SIZEOF_ITYPE SIZEOF_INT
4616 #include "libguile/num2integral.i.c"
4618 #define NUM2INTEGRAL scm_num2uint
4619 #define INTEGRAL2NUM scm_uint2num
4620 #define INTEGRAL2BIG scm_i_uint2big
4622 #define ITYPE unsigned int
4623 #define SIZEOF_ITYPE SIZEOF_INT
4624 #include "libguile/num2integral.i.c"
4626 #define NUM2INTEGRAL scm_num2long
4627 #define INTEGRAL2NUM scm_long2num
4628 #define INTEGRAL2BIG scm_i_long2big
4630 #define SIZEOF_ITYPE SIZEOF_LONG
4631 #include "libguile/num2integral.i.c"
4633 #define NUM2INTEGRAL scm_num2ulong
4634 #define INTEGRAL2NUM scm_ulong2num
4635 #define INTEGRAL2BIG scm_i_ulong2big
4637 #define ITYPE unsigned long
4638 #define SIZEOF_ITYPE SIZEOF_LONG
4639 #include "libguile/num2integral.i.c"
4641 #define NUM2INTEGRAL scm_num2ptrdiff
4642 #define INTEGRAL2NUM scm_ptrdiff2num
4643 #define INTEGRAL2BIG scm_i_ptrdiff2big
4644 #define ITYPE ptrdiff_t
4645 #define UNSIGNED_ITYPE size_t
4646 #define SIZEOF_ITYPE SIZEOF_PTRDIFF_T
4647 #include "libguile/num2integral.i.c"
4649 #define NUM2INTEGRAL scm_num2size
4650 #define INTEGRAL2NUM scm_size2num
4651 #define INTEGRAL2BIG scm_i_size2big
4653 #define ITYPE size_t
4654 #define SIZEOF_ITYPE SIZEOF_SIZE_T
4655 #include "libguile/num2integral.i.c"
4657 #ifdef HAVE_LONG_LONGS
4659 #ifndef ULONG_LONG_MAX
4660 #define ULONG_LONG_MAX (~0ULL)
4663 #define NUM2INTEGRAL scm_num2long_long
4664 #define INTEGRAL2NUM scm_long_long2num
4665 #define INTEGRAL2BIG scm_i_long_long2big
4666 #define ITYPE long long
4667 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
4668 #include "libguile/num2integral.i.c"
4670 #define NUM2INTEGRAL scm_num2ulong_long
4671 #define INTEGRAL2NUM scm_ulong_long2num
4672 #define INTEGRAL2BIG scm_i_ulong_long2big
4674 #define ITYPE unsigned long long
4675 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
4676 #include "libguile/num2integral.i.c"
4678 #endif /* HAVE_LONG_LONGS */
4680 #define NUM2FLOAT scm_num2float
4681 #define FLOAT2NUM scm_float2num
4683 #include "libguile/num2float.i.c"
4685 #define NUM2FLOAT scm_num2double
4686 #define FLOAT2NUM scm_double2num
4687 #define FTYPE double
4688 #include "libguile/num2float.i.c"
4693 #define SIZE_MAX ((size_t) (-1))
4696 #define PTRDIFF_MIN \
4697 ((ptrdiff_t) ((ptrdiff_t) 1 << (sizeof (ptrdiff_t) * 8 - 1)))
4700 #define PTRDIFF_MAX (~ PTRDIFF_MIN)
4703 #define CHECK(type, v) \
4705 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
4724 CHECK (ptrdiff
, -1);
4726 CHECK (short, SHRT_MAX
);
4727 CHECK (short, SHRT_MIN
);
4728 CHECK (ushort
, USHRT_MAX
);
4729 CHECK (int, INT_MAX
);
4730 CHECK (int, INT_MIN
);
4731 CHECK (uint
, UINT_MAX
);
4732 CHECK (long, LONG_MAX
);
4733 CHECK (long, LONG_MIN
);
4734 CHECK (ulong
, ULONG_MAX
);
4735 CHECK (size
, SIZE_MAX
);
4736 CHECK (ptrdiff
, PTRDIFF_MAX
);
4737 CHECK (ptrdiff
, PTRDIFF_MIN
);
4739 #ifdef HAVE_LONG_LONGS
4740 CHECK (long_long
, 0LL);
4741 CHECK (ulong_long
, 0ULL);
4742 CHECK (long_long
, -1LL);
4743 CHECK (long_long
, LLONG_MAX
);
4744 CHECK (long_long
, LLONG_MIN
);
4745 CHECK (ulong_long
, ULLONG_MAX
);
4752 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
4753 if (!SCM_FALSEP (data)) abort();
4756 check_body (void *data
)
4758 SCM num
= *(SCM
*) data
;
4759 scm_num2ulong (num
, 1, NULL
);
4761 return SCM_UNSPECIFIED
;
4765 check_handler (void *data
, SCM tag
, SCM throw_args
)
4767 SCM
*num
= (SCM
*) data
;
4770 return SCM_UNSPECIFIED
;
4773 SCM_DEFINE (scm_sys_check_number_conversions
, "%check-number-conversions", 0, 0, 0,
4775 "Number conversion sanity checking.")
4776 #define FUNC_NAME s_scm_sys_check_number_conversions
4778 SCM data
= SCM_MAKINUM (-1);
4780 data
= scm_int2num (INT_MIN
);
4782 data
= scm_ulong2num (ULONG_MAX
);
4783 data
= scm_difference (SCM_INUM0
, data
);
4785 data
= scm_ulong2num (ULONG_MAX
);
4786 data
= scm_sum (SCM_MAKINUM (1), data
); data
= scm_difference (SCM_INUM0
, data
);
4788 data
= scm_int2num (-10000); data
= scm_product (data
, data
); data
= scm_product (data
, data
);
4791 return SCM_UNSPECIFIED
;
4800 abs_most_negative_fixnum
= scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM
);
4801 scm_permanent_object (abs_most_negative_fixnum
);
4803 /* It may be possible to tune the performance of some algorithms by using
4804 * the following constants to avoid the creation of bignums. Please, before
4805 * using these values, remember the two rules of program optimization:
4806 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
4807 scm_c_define ("most-positive-fixnum",
4808 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
4809 scm_c_define ("most-negative-fixnum",
4810 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
4812 scm_add_feature ("complex");
4813 scm_add_feature ("inexact");
4814 scm_flo0
= scm_make_real (0.0);
4816 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4818 { /* determine floating point precision */
4820 double fsum
= 1.0 + f
;
4821 while (fsum
!= 1.0) {
4822 if (++scm_dblprec
> 20) {
4829 scm_dblprec
= scm_dblprec
- 1;
4831 #endif /* DBL_DIG */
4837 #include "libguile/numbers.x"