1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 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_GPROC (s_abs
, "abs", 1, 0, 0, scm_abs
, g_abs
);
293 /* "Return the absolute value of @var{x}."
299 long int xx
= SCM_INUM (x
);
302 } else if (SCM_POSFIXABLE (-xx
)) {
303 return SCM_MAKINUM (-xx
);
306 return scm_i_long2big (-xx
);
308 scm_num_overflow (s_abs
);
311 } else if (SCM_BIGP (x
)) {
312 if (!SCM_BIGSIGN (x
)) {
315 return scm_i_copybig (x
, 0);
317 } else if (SCM_REALP (x
)) {
318 return scm_make_real (fabs (SCM_REAL_VALUE (x
)));
320 SCM_WTA_DISPATCH_1 (g_abs
, x
, 1, s_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 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1249 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1250 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1254 double r
= SCM_REAL_VALUE (k
);
1257 SCM_WRONG_TYPE_ARG (2, k
);
1260 SCM_VALIDATE_ULONG_COPY (2, k
, i2
);
1264 n
= scm_divide (n
, SCM_UNDEFINED
);
1271 return scm_product (acc
, n
);
1273 acc
= scm_product (acc
, n
);
1274 n
= scm_product (n
, n
);
1280 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1282 "The function ash performs an arithmetic shift left by @var{cnt}\n"
1283 "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n"
1284 "means, that the function does not guarantee to keep the bit\n"
1285 "structure of @var{n}, but rather guarantees that the result\n"
1286 "will always be rounded towards minus infinity. Therefore, the\n"
1287 "results of ash and a corresponding bitwise shift will differ if\n"
1288 "@var{n} is negative.\n"
1290 "Formally, the function returns an integer equivalent to\n"
1291 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n"
1294 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1295 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
1297 #define FUNC_NAME s_scm_ash
1302 SCM_VALIDATE_INUM (1, n
)
1304 SCM_VALIDATE_INUM (2, cnt
);
1306 bits_to_shift
= SCM_INUM (cnt
);
1308 if (bits_to_shift
< 0) {
1309 /* Shift right by abs(cnt) bits. This is realized as a division by
1310 div:=2^abs(cnt). However, to guarantee the floor rounding, negative
1311 values require some special treatment.
1313 SCM div
= scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift
));
1314 if (SCM_FALSEP (scm_negative_p (n
)))
1315 return scm_quotient (n
, div
);
1317 return scm_sum (SCM_MAKINUM (-1L),
1318 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1320 /* Shift left is done by multiplication with 2^CNT */
1321 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1323 if (bits_to_shift
< 0)
1324 /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */
1325 return SCM_MAKINUM (SCM_SRS (SCM_INUM (n
), -bits_to_shift
));
1327 /* Shift left, but make sure not to leave the range of inums */
1328 SCM res
= SCM_MAKINUM (SCM_INUM (n
) << cnt
);
1329 if (SCM_INUM (res
) >> cnt
!= SCM_INUM (n
))
1330 scm_num_overflow (FUNC_NAME
);
1338 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1339 (SCM n
, SCM start
, SCM end
),
1340 "Return the integer composed of the @var{start} (inclusive)\n"
1341 "through @var{end} (exclusive) bits of @var{n}. The\n"
1342 "@var{start}th bit becomes the 0-th bit in the result.\n"
1345 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1346 " @result{} \"1010\"\n"
1347 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1348 " @result{} \"10110\"\n"
1350 #define FUNC_NAME s_scm_bit_extract
1352 unsigned long int istart
, iend
;
1353 SCM_VALIDATE_INUM_MIN_COPY (2, start
,0, istart
);
1354 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1355 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1357 if (SCM_INUMP (n
)) {
1358 long int in
= SCM_INUM (n
);
1359 unsigned long int bits
= iend
- istart
;
1361 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
1363 /* Since we emulate two's complement encoded numbers, this special
1364 * case requires us to produce a result that has more bits than can be
1365 * stored in a fixnum. Thus, we fall back to the more general
1366 * algorithm that is used for bignums.
1371 if (istart
< SCM_I_FIXNUM_BIT
)
1374 if (bits
< SCM_I_FIXNUM_BIT
)
1375 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1376 else /* we know: in >= 0 */
1377 return SCM_MAKINUM (in
);
1381 return SCM_MAKINUM (-1L & ((1L << bits
) - 1));
1385 return SCM_MAKINUM (0);
1387 } else if (SCM_BIGP (n
)) {
1390 SCM num1
= SCM_MAKINUM (1L);
1391 SCM num2
= SCM_MAKINUM (2L);
1392 SCM bits
= SCM_MAKINUM (iend
- istart
);
1393 SCM mask
= scm_difference (scm_integer_expt (num2
, bits
), num1
);
1394 return scm_logand (mask
, scm_ash (n
, SCM_MAKINUM (-istart
)));
1397 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1403 static const char scm_logtab
[] = {
1404 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1407 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1409 "Return the number of bits in integer @var{n}. If integer is\n"
1410 "positive, the 1-bits in its binary representation are counted.\n"
1411 "If negative, the 0-bits in its two's-complement binary\n"
1412 "representation are counted. If 0, 0 is returned.\n"
1415 "(logcount #b10101010)\n"
1422 #define FUNC_NAME s_scm_logcount
1424 if (SCM_INUMP (n
)) {
1425 unsigned long int c
= 0;
1426 long int nn
= SCM_INUM (n
);
1431 c
+= scm_logtab
[15 & nn
];
1434 return SCM_MAKINUM (c
);
1435 } else if (SCM_BIGP (n
)) {
1436 if (SCM_BIGSIGN (n
)) {
1437 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n
));
1439 unsigned long int c
= 0;
1440 size_t i
= SCM_NUMDIGS (n
);
1441 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1444 for (d
= ds
[i
]; d
; d
>>= 4) {
1445 c
+= scm_logtab
[15 & d
];
1448 return SCM_MAKINUM (c
);
1451 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1457 static const char scm_ilentab
[] = {
1458 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1461 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1463 "Return the number of bits necessary to represent @var{n}.\n"
1466 "(integer-length #b10101010)\n"
1468 "(integer-length 0)\n"
1470 "(integer-length #b1111)\n"
1473 #define FUNC_NAME s_scm_integer_length
1475 if (SCM_INUMP (n
)) {
1476 unsigned long int c
= 0;
1478 long int nn
= SCM_INUM (n
);
1484 l
= scm_ilentab
[15 & nn
];
1487 return SCM_MAKINUM (c
- 4 + l
);
1488 } else if (SCM_BIGP (n
)) {
1489 if (SCM_BIGSIGN (n
)) {
1490 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n
));
1492 unsigned long int digs
= SCM_NUMDIGS (n
) - 1;
1493 unsigned long int c
= digs
* SCM_BITSPERDIG
;
1495 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1496 SCM_BIGDIG d
= ds
[digs
];
1499 l
= scm_ilentab
[15 & d
];
1502 return SCM_MAKINUM (c
- 4 + l
);
1505 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1512 static const char s_bignum
[] = "bignum";
1515 scm_i_mkbig (size_t nlen
, int sign
)
1520 if (((nlen
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1521 scm_memory_error (s_bignum
);
1523 base
= scm_gc_malloc (nlen
* sizeof (SCM_BIGDIG
), s_bignum
);
1525 v
= scm_cell (SCM_MAKE_BIGNUM_TAG (nlen
, sign
), (scm_t_bits
) base
);
1530 scm_i_big2inum (SCM b
, size_t l
)
1532 unsigned long num
= 0;
1533 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1535 num
= SCM_BIGUP (num
) + tmp
[l
];
1536 if (!SCM_BIGSIGN (b
))
1538 if (SCM_POSFIXABLE (num
))
1539 return SCM_MAKINUM (num
);
1541 else if (num
<= -SCM_MOST_NEGATIVE_FIXNUM
)
1542 return SCM_MAKINUM (-num
);
1546 static const char s_adjbig
[] = "scm_i_adjbig";
1549 scm_i_adjbig (SCM b
, size_t nlen
)
1552 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1553 scm_memory_error (s_adjbig
);
1559 scm_gc_realloc (SCM_BDIGITS (b
),
1560 SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
),
1561 nsiz
* sizeof (SCM_BIGDIG
), s_bignum
));
1563 SCM_SET_BIGNUM_BASE (b
, digits
);
1564 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1571 scm_i_normbig (SCM b
)
1574 size_t nlen
= SCM_NUMDIGS (b
);
1576 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1578 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1579 while (nlen
-- && !zds
[nlen
]);
1581 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1582 if (SCM_INUMP (b
= scm_i_big2inum (b
, (size_t) nlen
)))
1584 if (SCM_NUMDIGS (b
) == nlen
)
1586 return scm_i_adjbig (b
, (size_t) nlen
);
1590 scm_i_copybig (SCM b
, int sign
)
1592 size_t i
= SCM_NUMDIGS (b
);
1593 SCM ans
= scm_i_mkbig (i
, sign
);
1594 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1601 scm_bigcomp (SCM x
, SCM y
)
1603 int xsign
= SCM_BIGSIGN (x
);
1604 int ysign
= SCM_BIGSIGN (y
);
1607 /* Look at the signs, first. */
1613 /* They're the same sign, so see which one has more digits. Note
1614 that, if they are negative, the longer number is the lesser. */
1615 ylen
= SCM_NUMDIGS (y
);
1616 xlen
= SCM_NUMDIGS (x
);
1618 return (xsign
) ? -1 : 1;
1620 return (xsign
) ? 1 : -1;
1622 /* They have the same number of digits, so find the most significant
1623 digit where they differ. */
1627 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1628 /* Make the discrimination based on the digit that differs. */
1629 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1631 : (xsign
? 1 : -1));
1634 /* The numbers are identical. */
1638 #ifndef SCM_DIGSTOOBIG
1642 scm_pseudolong (long x
)
1647 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1653 while (i
< SCM_DIGSPERLONG
)
1655 p
.bd
[i
++] = SCM_BIGLO (x
);
1658 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1666 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1671 while (i
< SCM_DIGSPERLONG
)
1673 digs
[i
++] = SCM_BIGLO (x
);
1682 scm_addbig (SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int sgny
)
1684 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1685 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1687 size_t i
= 0, ny
= SCM_NUMDIGS (bigy
);
1688 SCM z
= scm_i_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1689 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1690 if (xsgn
^ SCM_BIGSIGN (z
))
1694 num
+= (long) zds
[i
] - x
[i
];
1697 zds
[i
] = num
+ SCM_BIGRAD
;
1702 zds
[i
] = SCM_BIGLO (num
);
1707 if (num
&& nx
== ny
)
1711 SCM_SET_CELL_WORD_0 (z
, SCM_CELL_WORD_0 (z
) ^ SCM_BIGSIGNFLAG
);
1714 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1715 zds
[i
++] = SCM_BIGLO (num
);
1716 num
= SCM_BIGDN (num
);
1726 zds
[i
++] = num
+ SCM_BIGRAD
;
1731 zds
[i
++] = SCM_BIGLO (num
);
1740 num
+= (long) zds
[i
] + x
[i
];
1741 zds
[i
++] = SCM_BIGLO (num
);
1742 num
= SCM_BIGDN (num
);
1750 zds
[i
++] = SCM_BIGLO (num
);
1751 num
= SCM_BIGDN (num
);
1757 z
= scm_i_adjbig (z
, ny
+ 1);
1758 SCM_BDIGITS (z
)[ny
] = num
;
1762 return scm_i_normbig (z
);
1767 scm_mulbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
)
1769 size_t i
= 0, j
= nx
+ ny
;
1770 unsigned long n
= 0;
1771 SCM z
= scm_i_mkbig (j
, sgn
);
1772 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1782 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1783 zds
[i
+ j
++] = SCM_BIGLO (n
);
1795 return scm_i_normbig (z
);
1800 scm_divbigdig (SCM_BIGDIG
* ds
, size_t h
, SCM_BIGDIG div
)
1802 register unsigned long t2
= 0;
1805 t2
= SCM_BIGUP (t2
) + ds
[h
];
1815 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1821 register unsigned long t2
= 0;
1822 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1823 size_t nd
= SCM_NUMDIGS (x
);
1825 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1828 return SCM_MAKINUM (sgn
? -t2
: t2
);
1831 #ifndef SCM_DIGSTOOBIG
1832 unsigned long t2
= scm_pseudolong (z
);
1833 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1834 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1837 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1838 scm_longdigs (z
, t2
);
1839 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1840 t2
, SCM_DIGSPERLONG
,
1848 scm_divbigbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
, int modes
)
1850 /* modes description
1854 3 quotient but returns SCM_UNDEFINED if division is not exact. */
1855 size_t i
= 0, j
= 0;
1857 unsigned long t2
= 0;
1859 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1860 /* algorithm requires nx >= ny */
1864 case 0: /* remainder -- just return x */
1865 z
= scm_i_mkbig (nx
, sgn
);
1866 zds
= SCM_BDIGITS (z
);
1873 case 1: /* scm_modulo -- return y-x */
1874 z
= scm_i_mkbig (ny
, sgn
);
1875 zds
= SCM_BDIGITS (z
);
1878 num
+= (long) y
[i
] - x
[i
];
1881 zds
[i
] = num
+ SCM_BIGRAD
;
1896 zds
[i
++] = num
+ SCM_BIGRAD
;
1907 return SCM_INUM0
; /* quotient is zero */
1909 return SCM_UNDEFINED
; /* the division is not exact */
1912 z
= scm_i_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1913 zds
= SCM_BDIGITS (z
);
1917 ny
--; /* in case y came in as a psuedolong */
1918 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1919 { /* normalize operands */
1920 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1921 newy
= scm_i_mkbig (ny
, 0);
1922 yds
= SCM_BDIGITS (newy
);
1925 t2
+= (unsigned long) y
[j
] * d
;
1926 yds
[j
++] = SCM_BIGLO (t2
);
1927 t2
= SCM_BIGDN (t2
);
1934 t2
+= (unsigned long) x
[j
] * d
;
1935 zds
[j
++] = SCM_BIGLO (t2
);
1936 t2
= SCM_BIGDN (t2
);
1946 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1948 { /* loop over digits of quotient */
1949 if (zds
[j
] == y
[ny
- 1])
1950 qhat
= SCM_BIGRAD
- 1;
1952 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1959 { /* multiply and subtract */
1960 t2
+= (unsigned long) y
[i
] * qhat
;
1961 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1964 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1969 zds
[j
- ny
+ i
] = num
;
1972 t2
= SCM_BIGDN (t2
);
1975 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1977 { /* "add back" required */
1983 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1984 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1985 num
= SCM_BIGDN (num
);
1996 case 3: /* check that remainder==0 */
1997 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1999 return SCM_UNDEFINED
;
2000 case 2: /* move quotient down in z */
2001 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
2002 for (i
= 0; i
< j
; i
++)
2003 zds
[i
] = zds
[i
+ ny
];
2006 case 1: /* subtract for scm_modulo */
2012 num
+= y
[i
] - zds
[i
];
2016 zds
[i
] = num
+ SCM_BIGRAD
;
2028 case 0: /* just normalize remainder */
2030 scm_divbigdig (zds
, ny
, d
);
2033 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
2034 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
2035 if (SCM_INUMP (z
= scm_i_big2inum (z
, j
)))
2037 return scm_i_adjbig (z
, j
);
2045 /*** NUMBERS -> STRINGS ***/
2047 static const double fx
[] =
2048 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
2049 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
2050 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
2051 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
2057 idbl2str (double f
, char *a
)
2059 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
2065 #ifdef HAVE_COPYSIGN
2066 double sgn
= copysign (1.0, f
);
2072 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
2078 strcpy (a
, "-inf.0");
2080 strcpy (a
, "+inf.0");
2083 else if (xisnan (f
))
2085 strcpy (a
, "+nan.0");
2095 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
2096 make-uniform-vector, from causing infinite loops. */
2100 if (exp
-- < DBL_MIN_10_EXP
)
2111 if (exp
++ > DBL_MAX_10_EXP
)
2131 if (f
+ fx
[wp
] >= 10.0)
2138 dpt
= (exp
+ 9999) % 3;
2142 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2167 if (f
+ fx
[wp
] >= 1.0)
2181 if ((dpt
> 4) && (exp
> 6))
2183 d
= (a
[0] == '-' ? 2 : 1);
2184 for (i
= ch
++; i
> d
; i
--)
2197 if (a
[ch
- 1] == '.')
2198 a
[ch
++] = '0'; /* trailing zero */
2207 for (i
= 10; i
<= exp
; i
*= 10);
2208 for (i
/= 10; i
; i
/= 10)
2210 a
[ch
++] = exp
/ i
+ '0';
2219 iflo2str (SCM flt
, char *str
)
2222 if (SCM_REALP (flt
))
2223 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2226 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2227 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2229 double imag
= SCM_COMPLEX_IMAG (flt
);
2230 /* Don't output a '+' for negative numbers or for Inf and
2231 NaN. They will provide their own sign. */
2232 if (0 <= imag
&& !xisinf (imag
) && !xisnan (imag
))
2234 i
+= idbl2str (imag
, &str
[i
]);
2241 /* convert a long to a string (unterminated). returns the number of
2242 characters in the result.
2244 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2246 scm_iint2str (long num
, int rad
, char *p
)
2250 unsigned long n
= (num
< 0) ? -num
: num
;
2252 for (n
/= rad
; n
> 0; n
/= rad
)
2269 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2278 big2str (SCM b
, unsigned int radix
)
2280 SCM t
= scm_i_copybig (b
, 0); /* sign of temp doesn't matter */
2281 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2282 size_t i
= SCM_NUMDIGS (t
);
2283 size_t j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2284 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2285 : (SCM_BITSPERDIG
* i
) + 2;
2288 SCM_BIGDIG radpow
= 1, radmod
= 0;
2289 SCM ss
= scm_allocate_string (j
);
2290 char *s
= SCM_STRING_CHARS (ss
), c
;
2294 return scm_makfrom0str ("0");
2297 while ((long) radpow
* radix
< SCM_BIGRAD
)
2302 while ((i
|| radmod
) && j
)
2306 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2314 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2317 if (SCM_BIGSIGN (b
))
2322 /* The pre-reserved string length was too large. */
2323 unsigned long int length
= SCM_STRING_LENGTH (ss
);
2324 ss
= scm_substring (ss
, SCM_MAKINUM (j
), SCM_MAKINUM (length
));
2327 return scm_return_first (ss
, t
);
2332 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2334 "Return a string holding the external representation of the\n"
2335 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2336 "inexact, a radix of 10 will be used.")
2337 #define FUNC_NAME s_scm_number_to_string
2341 if (SCM_UNBNDP (radix
)) {
2344 SCM_VALIDATE_INUM (2, radix
);
2345 base
= SCM_INUM (radix
);
2346 SCM_ASSERT_RANGE (2, radix
, base
>= 2);
2349 if (SCM_INUMP (n
)) {
2350 char num_buf
[SCM_INTBUFLEN
];
2351 size_t length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2352 return scm_mem2string (num_buf
, length
);
2353 } else if (SCM_BIGP (n
)) {
2354 return big2str (n
, (unsigned int) base
);
2355 } else if (SCM_INEXACTP (n
)) {
2356 char num_buf
[FLOBUFLEN
];
2357 return scm_mem2string (num_buf
, iflo2str (n
, num_buf
));
2359 SCM_WRONG_TYPE_ARG (1, n
);
2365 /* These print routines are stubbed here so that scm_repl.c doesn't need
2366 SCM_BIGDIG conditionals */
2369 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2371 char num_buf
[FLOBUFLEN
];
2372 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2377 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2379 char num_buf
[FLOBUFLEN
];
2380 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2385 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2388 exp
= big2str (exp
, (unsigned int) 10);
2389 scm_lfwrite (SCM_STRING_CHARS (exp
), (size_t) SCM_STRING_LENGTH (exp
), port
);
2391 scm_ipruk ("bignum", exp
, port
);
2395 /*** END nums->strs ***/
2398 /*** STRINGS -> NUMBERS ***/
2400 /* The following functions implement the conversion from strings to numbers.
2401 * The implementation somehow follows the grammar for numbers as it is given
2402 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
2403 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
2404 * points should be noted about the implementation:
2405 * * Each function keeps a local index variable 'idx' that points at the
2406 * current position within the parsed string. The global index is only
2407 * updated if the function could parse the corresponding syntactic unit
2409 * * Similarly, the functions keep track of indicators of inexactness ('#',
2410 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
2411 * global exactness information is only updated after each part has been
2412 * successfully parsed.
2413 * * Sequences of digits are parsed into temporary variables holding fixnums.
2414 * Only if these fixnums would overflow, the result variables are updated
2415 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
2416 * the temporary variables holding the fixnums are cleared, and the process
2417 * starts over again. If for example fixnums were able to store five decimal
2418 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
2419 * and the result was computed as 12345 * 100000 + 67890. In other words,
2420 * only every five digits two bignum operations were performed.
2423 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
2425 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
2427 /* In non ASCII-style encodings the following macro might not work. */
2428 #define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
2431 mem2uinteger (const char* mem
, size_t len
, unsigned int *p_idx
,
2432 unsigned int radix
, enum t_exactness
*p_exactness
)
2434 unsigned int idx
= *p_idx
;
2435 unsigned int hash_seen
= 0;
2436 scm_t_bits shift
= 1;
2438 unsigned int digit_value
;
2448 digit_value
= XDIGIT2UINT (c
);
2449 if (digit_value
>= radix
)
2453 result
= SCM_MAKINUM (digit_value
);
2461 digit_value
= XDIGIT2UINT (c
);
2462 if (digit_value
>= radix
)
2474 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
2476 result
= scm_product (result
, SCM_MAKINUM (shift
));
2478 result
= scm_sum (result
, SCM_MAKINUM (add
));
2485 shift
= shift
* radix
;
2486 add
= add
* radix
+ digit_value
;
2491 result
= scm_product (result
, SCM_MAKINUM (shift
));
2493 result
= scm_sum (result
, SCM_MAKINUM (add
));
2497 *p_exactness
= INEXACT
;
2503 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2504 * covers the parts of the rules that start at a potential point. The value
2505 * of the digits up to the point have been parsed by the caller and are given
2506 * in variable result. The content of *p_exactness indicates, whether a hash
2507 * has already been seen in the digits before the point.
2510 /* In non ASCII-style encodings the following macro might not work. */
2511 #define DIGIT2UINT(d) ((d) - '0')
2514 mem2decimal_from_point (SCM result
, const char* mem
, size_t len
,
2515 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
2517 unsigned int idx
= *p_idx
;
2518 enum t_exactness x
= *p_exactness
;
2523 if (mem
[idx
] == '.')
2525 scm_t_bits shift
= 1;
2527 unsigned int digit_value
;
2528 SCM big_shift
= SCM_MAKINUM (1);
2539 digit_value
= DIGIT2UINT (c
);
2550 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
2552 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2553 result
= scm_product (result
, SCM_MAKINUM (shift
));
2555 result
= scm_sum (result
, SCM_MAKINUM (add
));
2563 add
= add
* 10 + digit_value
;
2569 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2570 result
= scm_product (result
, SCM_MAKINUM (shift
));
2571 result
= scm_sum (result
, SCM_MAKINUM (add
));
2574 result
= scm_divide (result
, big_shift
);
2576 /* We've seen a decimal point, thus the value is implicitly inexact. */
2588 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2619 exponent
= DIGIT2UINT (c
);
2626 if (exponent
<= SCM_MAXEXP
)
2627 exponent
= exponent
* 10 + DIGIT2UINT (c
);
2633 if (exponent
> SCM_MAXEXP
)
2635 size_t exp_len
= idx
- start
;
2636 SCM exp_string
= scm_mem2string (&mem
[start
], exp_len
);
2637 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
2638 scm_out_of_range ("string->number", exp_num
);
2641 e
= scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent
));
2643 result
= scm_product (result
, e
);
2645 result
= scm_divide (result
, e
);
2647 /* We've seen an exponent, thus the value is implicitly inexact. */
2665 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2668 mem2ureal (const char* mem
, size_t len
, unsigned int *p_idx
,
2669 unsigned int radix
, enum t_exactness
*p_exactness
)
2671 unsigned int idx
= *p_idx
;
2677 if (idx
+5 <= len
&& !strncmp (mem
+idx
, "inf.0", 5))
2683 if (idx
+4 < len
&& !strncmp (mem
+idx
, "nan.", 4))
2685 enum t_exactness x
= EXACT
;
2687 /* Cobble up the fraction. We might want to set the NaN's
2688 mantissa from it. */
2690 mem2uinteger (mem
, len
, &idx
, 10, &x
);
2695 if (mem
[idx
] == '.')
2699 else if (idx
+ 1 == len
)
2701 else if (!isdigit (mem
[idx
+ 1]))
2704 result
= mem2decimal_from_point (SCM_MAKINUM (0), mem
, len
,
2705 p_idx
, p_exactness
);
2709 enum t_exactness x
= EXACT
;
2712 uinteger
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2713 if (SCM_FALSEP (uinteger
))
2718 else if (mem
[idx
] == '/')
2724 divisor
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2725 if (SCM_FALSEP (divisor
))
2728 result
= scm_divide (uinteger
, divisor
);
2730 else if (radix
== 10)
2732 result
= mem2decimal_from_point (uinteger
, mem
, len
, &idx
, &x
);
2733 if (SCM_FALSEP (result
))
2744 /* When returning an inexact zero, make sure it is represented as a
2745 floating point value so that we can change its sign.
2747 if (SCM_EQ_P (result
, SCM_MAKINUM(0)) && *p_exactness
== INEXACT
)
2748 result
= scm_make_real (0.0);
2754 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2757 mem2complex (const char* mem
, size_t len
, unsigned int idx
,
2758 unsigned int radix
, enum t_exactness
*p_exactness
)
2782 ureal
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2783 if (SCM_FALSEP (ureal
))
2785 /* input must be either +i or -i */
2790 if (mem
[idx
] == 'i' || mem
[idx
] == 'I')
2796 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign
));
2803 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2804 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
2813 /* either +<ureal>i or -<ureal>i */
2820 return scm_make_rectangular (SCM_MAKINUM (0), ureal
);
2823 /* polar input: <real>@<real>. */
2848 angle
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2849 if (SCM_FALSEP (angle
))
2854 if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2855 angle
= scm_difference (angle
, SCM_UNDEFINED
);
2857 result
= scm_make_polar (ureal
, angle
);
2862 /* expecting input matching <real>[+-]<ureal>?i */
2869 int sign
= (c
== '+') ? 1 : -1;
2870 SCM imag
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2872 if (SCM_FALSEP (imag
))
2873 imag
= SCM_MAKINUM (sign
);
2874 else if (sign
== -1 && SCM_FALSEP (scm_nan_p (ureal
)))
2875 imag
= scm_difference (imag
, SCM_UNDEFINED
);
2879 if (mem
[idx
] != 'i' && mem
[idx
] != 'I')
2886 return scm_make_rectangular (ureal
, imag
);
2895 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2897 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
2900 scm_i_mem2number (const char* mem
, size_t len
, unsigned int default_radix
)
2902 unsigned int idx
= 0;
2903 unsigned int radix
= NO_RADIX
;
2904 enum t_exactness forced_x
= NO_EXACTNESS
;
2905 enum t_exactness implicit_x
= EXACT
;
2908 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2909 while (idx
+ 2 < len
&& mem
[idx
] == '#')
2911 switch (mem
[idx
+ 1])
2914 if (radix
!= NO_RADIX
)
2919 if (radix
!= NO_RADIX
)
2924 if (forced_x
!= NO_EXACTNESS
)
2929 if (forced_x
!= NO_EXACTNESS
)
2934 if (radix
!= NO_RADIX
)
2939 if (radix
!= NO_RADIX
)
2949 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2950 if (radix
== NO_RADIX
)
2951 result
= mem2complex (mem
, len
, idx
, default_radix
, &implicit_x
);
2953 result
= mem2complex (mem
, len
, idx
, (unsigned int) radix
, &implicit_x
);
2955 if (SCM_FALSEP (result
))
2961 if (SCM_INEXACTP (result
))
2962 /* FIXME: This may change the value. */
2963 return scm_inexact_to_exact (result
);
2967 if (SCM_INEXACTP (result
))
2970 return scm_exact_to_inexact (result
);
2973 if (implicit_x
== INEXACT
)
2975 if (SCM_INEXACTP (result
))
2978 return scm_exact_to_inexact (result
);
2986 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2987 (SCM string
, SCM radix
),
2988 "Return a number of the maximally precise representation\n"
2989 "expressed by the given @var{string}. @var{radix} must be an\n"
2990 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2991 "is a default radix that may be overridden by an explicit radix\n"
2992 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2993 "supplied, then the default radix is 10. If string is not a\n"
2994 "syntactically valid notation for a number, then\n"
2995 "@code{string->number} returns @code{#f}.")
2996 #define FUNC_NAME s_scm_string_to_number
3000 SCM_VALIDATE_STRING (1, string
);
3001 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix
,2,10, base
);
3002 answer
= scm_i_mem2number (SCM_STRING_CHARS (string
),
3003 SCM_STRING_LENGTH (string
),
3005 return scm_return_first (answer
, string
);
3010 /*** END strs->nums ***/
3014 scm_make_real (double x
)
3017 z
= scm_double_cell (scm_tc16_real
, 0, 0, 0);
3018 SCM_REAL_VALUE (z
) = x
;
3024 scm_make_complex (double x
, double y
)
3027 return scm_make_real (x
);
3030 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_gc_malloc (2*sizeof (double),
3032 SCM_COMPLEX_REAL (z
) = x
;
3033 SCM_COMPLEX_IMAG (z
) = y
;
3040 scm_bigequal (SCM x
, SCM y
)
3043 if (0 == scm_bigcomp (x
, y
))
3050 scm_real_equalp (SCM x
, SCM y
)
3052 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3056 scm_complex_equalp (SCM x
, SCM y
)
3058 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
3059 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
3064 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
3065 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
3066 * "else. Note that the sets of complex, real, rational and\n"
3067 * "integer values form subsets of the set of numbers, i. e. the\n"
3068 * "predicate will be fulfilled for any number."
3070 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
3072 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
3073 "otherwise. Note that the sets of real, rational and integer\n"
3074 "values form subsets of the set of complex numbers, i. e. the\n"
3075 "predicate will also be fulfilled if @var{x} is a real,\n"
3076 "rational or integer number.")
3077 #define FUNC_NAME s_scm_number_p
3079 return SCM_BOOL (SCM_NUMBERP (x
));
3084 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
3085 /* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
3086 * "Note that the sets of integer and rational values form a subset\n"
3087 * "of the set of real numbers, i. e. the predicate will also\n"
3088 * "be fulfilled if @var{x} is an integer or a rational number."
3090 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
3092 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
3093 "otherwise. Note that the set of integer values forms a subset of\n"
3094 "the set of rational numbers, i. e. the predicate will also be\n"
3095 "fulfilled if @var{x} is an integer number. Real numbers\n"
3096 "will also satisfy this predicate, because of their limited\n"
3098 #define FUNC_NAME s_scm_real_p
3100 if (SCM_INUMP (x
)) {
3102 } else if (SCM_IMP (x
)) {
3104 } else if (SCM_REALP (x
)) {
3106 } else if (SCM_BIGP (x
)) {
3115 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
3117 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
3119 #define FUNC_NAME s_scm_integer_p
3128 if (!SCM_INEXACTP (x
))
3130 if (SCM_COMPLEXP (x
))
3132 r
= SCM_REAL_VALUE (x
);
3140 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
3142 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
3144 #define FUNC_NAME s_scm_inexact_p
3146 return SCM_BOOL (SCM_INEXACTP (x
));
3151 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
3152 /* "Return @code{#t} if all parameters are numerically equal." */
3154 scm_num_eq_p (SCM x
, SCM y
)
3156 if (SCM_INUMP (x
)) {
3157 long xx
= SCM_INUM (x
);
3158 if (SCM_INUMP (y
)) {
3159 long yy
= SCM_INUM (y
);
3160 return SCM_BOOL (xx
== yy
);
3161 } else if (SCM_BIGP (y
)) {
3163 } else if (SCM_REALP (y
)) {
3164 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
3165 } else if (SCM_COMPLEXP (y
)) {
3166 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
3167 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3169 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3171 } else if (SCM_BIGP (x
)) {
3172 if (SCM_INUMP (y
)) {
3174 } else if (SCM_BIGP (y
)) {
3175 return SCM_BOOL (0 == scm_bigcomp (x
, y
));
3176 } else if (SCM_REALP (y
)) {
3177 return SCM_BOOL (scm_i_big2dbl (x
) == SCM_REAL_VALUE (y
));
3178 } else if (SCM_COMPLEXP (y
)) {
3179 return SCM_BOOL ((scm_i_big2dbl (x
) == SCM_COMPLEX_REAL (y
))
3180 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3182 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3184 } else if (SCM_REALP (x
)) {
3185 if (SCM_INUMP (y
)) {
3186 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3187 } else if (SCM_BIGP (y
)) {
3188 return SCM_BOOL (SCM_REAL_VALUE (x
) == scm_i_big2dbl (y
));
3189 } else if (SCM_REALP (y
)) {
3190 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3191 } else if (SCM_COMPLEXP (y
)) {
3192 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3193 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3195 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3197 } else if (SCM_COMPLEXP (x
)) {
3198 if (SCM_INUMP (y
)) {
3199 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3200 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3201 } else if (SCM_BIGP (y
)) {
3202 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == scm_i_big2dbl (y
))
3203 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3204 } else if (SCM_REALP (y
)) {
3205 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3206 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3207 } else if (SCM_COMPLEXP (y
)) {
3208 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3209 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3211 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3214 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3219 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3220 /* "Return @code{#t} if the list of parameters is monotonically\n"
3224 scm_less_p (SCM x
, SCM y
)
3226 if (SCM_INUMP (x
)) {
3227 long xx
= SCM_INUM (x
);
3228 if (SCM_INUMP (y
)) {
3229 long yy
= SCM_INUM (y
);
3230 return SCM_BOOL (xx
< yy
);
3231 } else if (SCM_BIGP (y
)) {
3232 return SCM_BOOL (!SCM_BIGSIGN (y
));
3233 } else if (SCM_REALP (y
)) {
3234 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3236 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3238 } else if (SCM_BIGP (x
)) {
3239 if (SCM_INUMP (y
)) {
3240 return SCM_BOOL (SCM_BIGSIGN (x
));
3241 } else if (SCM_BIGP (y
)) {
3242 return SCM_BOOL (1 == scm_bigcomp (x
, y
));
3243 } else if (SCM_REALP (y
)) {
3244 return SCM_BOOL (scm_i_big2dbl (x
) < SCM_REAL_VALUE (y
));
3246 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3248 } else if (SCM_REALP (x
)) {
3249 if (SCM_INUMP (y
)) {
3250 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3251 } else if (SCM_BIGP (y
)) {
3252 return SCM_BOOL (SCM_REAL_VALUE (x
) < scm_i_big2dbl (y
));
3253 } else if (SCM_REALP (y
)) {
3254 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3256 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3259 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3264 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3265 /* "Return @code{#t} if the list of parameters is monotonically\n"
3268 #define FUNC_NAME s_scm_gr_p
3270 scm_gr_p (SCM x
, SCM y
)
3272 if (!SCM_NUMBERP (x
))
3273 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3274 else if (!SCM_NUMBERP (y
))
3275 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3277 return scm_less_p (y
, x
);
3282 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3283 /* "Return @code{#t} if the list of parameters is monotonically\n"
3286 #define FUNC_NAME s_scm_leq_p
3288 scm_leq_p (SCM x
, SCM y
)
3290 if (!SCM_NUMBERP (x
))
3291 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3292 else if (!SCM_NUMBERP (y
))
3293 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3294 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
3297 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3302 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3303 /* "Return @code{#t} if the list of parameters is monotonically\n"
3306 #define FUNC_NAME s_scm_geq_p
3308 scm_geq_p (SCM x
, SCM y
)
3310 if (!SCM_NUMBERP (x
))
3311 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3312 else if (!SCM_NUMBERP (y
))
3313 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3314 else if (SCM_NFALSEP (scm_nan_p (x
)) || SCM_NFALSEP (scm_nan_p (y
)))
3317 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3322 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3323 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3329 if (SCM_INUMP (z
)) {
3330 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3331 } else if (SCM_BIGP (z
)) {
3333 } else if (SCM_REALP (z
)) {
3334 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3335 } else if (SCM_COMPLEXP (z
)) {
3336 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3337 && SCM_COMPLEX_IMAG (z
) == 0.0);
3339 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3344 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3345 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3349 scm_positive_p (SCM x
)
3351 if (SCM_INUMP (x
)) {
3352 return SCM_BOOL (SCM_INUM (x
) > 0);
3353 } else if (SCM_BIGP (x
)) {
3354 return SCM_BOOL (!SCM_BIGSIGN (x
));
3355 } else if (SCM_REALP (x
)) {
3356 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3358 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3363 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3364 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3368 scm_negative_p (SCM x
)
3370 if (SCM_INUMP (x
)) {
3371 return SCM_BOOL (SCM_INUM (x
) < 0);
3372 } else if (SCM_BIGP (x
)) {
3373 return SCM_BOOL (SCM_BIGSIGN (x
));
3374 } else if (SCM_REALP (x
)) {
3375 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3377 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3382 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3383 /* "Return the maximum of all parameter values."
3386 scm_max (SCM x
, SCM y
)
3388 if (SCM_UNBNDP (y
)) {
3389 if (SCM_UNBNDP (x
)) {
3390 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
3391 } else if (SCM_NUMBERP (x
)) {
3394 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3398 if (SCM_INUMP (x
)) {
3399 long xx
= SCM_INUM (x
);
3400 if (SCM_INUMP (y
)) {
3401 long yy
= SCM_INUM (y
);
3402 return (xx
< yy
) ? y
: x
;
3403 } else if (SCM_BIGP (y
)) {
3404 return SCM_BIGSIGN (y
) ? x
: y
;
3405 } else if (SCM_REALP (y
)) {
3407 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3409 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3411 } else if (SCM_BIGP (x
)) {
3412 if (SCM_INUMP (y
)) {
3413 return SCM_BIGSIGN (x
) ? y
: x
;
3414 } else if (SCM_BIGP (y
)) {
3415 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3416 } else if (SCM_REALP (y
)) {
3417 double z
= scm_i_big2dbl (x
);
3418 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3420 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3422 } else if (SCM_REALP (x
)) {
3423 if (SCM_INUMP (y
)) {
3424 double z
= SCM_INUM (y
);
3425 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3426 } else if (SCM_BIGP (y
)) {
3427 double z
= scm_i_big2dbl (y
);
3428 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3429 } else if (SCM_REALP (y
)) {
3430 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? y
: x
;
3432 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3435 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3440 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3441 /* "Return the minium of all parameter values."
3444 scm_min (SCM x
, SCM y
)
3446 if (SCM_UNBNDP (y
)) {
3447 if (SCM_UNBNDP (x
)) {
3448 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
3449 } else if (SCM_NUMBERP (x
)) {
3452 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3456 if (SCM_INUMP (x
)) {
3457 long xx
= SCM_INUM (x
);
3458 if (SCM_INUMP (y
)) {
3459 long yy
= SCM_INUM (y
);
3460 return (xx
< yy
) ? x
: y
;
3461 } else if (SCM_BIGP (y
)) {
3462 return SCM_BIGSIGN (y
) ? y
: x
;
3463 } else if (SCM_REALP (y
)) {
3465 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3467 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3469 } else if (SCM_BIGP (x
)) {
3470 if (SCM_INUMP (y
)) {
3471 return SCM_BIGSIGN (x
) ? x
: y
;
3472 } else if (SCM_BIGP (y
)) {
3473 return (-1 == scm_bigcomp (x
, y
)) ? y
: x
;
3474 } else if (SCM_REALP (y
)) {
3475 double z
= scm_i_big2dbl (x
);
3476 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3478 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3480 } else if (SCM_REALP (x
)) {
3481 if (SCM_INUMP (y
)) {
3482 double z
= SCM_INUM (y
);
3483 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3484 } else if (SCM_BIGP (y
)) {
3485 double z
= scm_i_big2dbl (y
);
3486 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3487 } else if (SCM_REALP (y
)) {
3488 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? x
: y
;
3490 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3493 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3498 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3499 /* "Return the sum of all parameter values. Return 0 if called without\n"
3503 scm_sum (SCM x
, SCM y
)
3505 if (SCM_UNBNDP (y
)) {
3506 if (SCM_UNBNDP (x
)) {
3508 } else if (SCM_NUMBERP (x
)) {
3511 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3515 if (SCM_INUMP (x
)) {
3516 long int xx
= SCM_INUM (x
);
3517 if (SCM_INUMP (y
)) {
3518 long int yy
= SCM_INUM (y
);
3519 long int z
= xx
+ yy
;
3520 if (SCM_FIXABLE (z
)) {
3521 return SCM_MAKINUM (z
);
3524 return scm_i_long2big (z
);
3525 #else /* SCM_BIGDIG */
3526 return scm_make_real ((double) z
);
3527 #endif /* SCM_BIGDIG */
3529 } else if (SCM_BIGP (y
)) {
3532 long int xx
= SCM_INUM (x
);
3533 #ifndef SCM_DIGSTOOBIG
3534 long z
= scm_pseudolong (xx
);
3535 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3536 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3537 #else /* SCM_DIGSTOOBIG */
3538 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3539 scm_longdigs (xx
, zdigs
);
3540 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3541 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3542 #endif /* SCM_DIGSTOOBIG */
3544 } else if (SCM_REALP (y
)) {
3545 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3546 } else if (SCM_COMPLEXP (y
)) {
3547 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3548 SCM_COMPLEX_IMAG (y
));
3550 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3552 } else if (SCM_BIGP (x
)) {
3553 if (SCM_INUMP (y
)) {
3556 } else if (SCM_BIGP (y
)) {
3557 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
)) {
3560 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3561 SCM_BIGSIGN (x
), y
, 0);
3562 } else if (SCM_REALP (y
)) {
3563 return scm_make_real (scm_i_big2dbl (x
) + SCM_REAL_VALUE (y
));
3564 } else if (SCM_COMPLEXP (y
)) {
3565 return scm_make_complex (scm_i_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3566 SCM_COMPLEX_IMAG (y
));
3568 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3570 } else if (SCM_REALP (x
)) {
3571 if (SCM_INUMP (y
)) {
3572 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3573 } else if (SCM_BIGP (y
)) {
3574 return scm_make_real (SCM_REAL_VALUE (x
) + scm_i_big2dbl (y
));
3575 } else if (SCM_REALP (y
)) {
3576 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3577 } else if (SCM_COMPLEXP (y
)) {
3578 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3579 SCM_COMPLEX_IMAG (y
));
3581 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3583 } else if (SCM_COMPLEXP (x
)) {
3584 if (SCM_INUMP (y
)) {
3585 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3586 SCM_COMPLEX_IMAG (x
));
3587 } else if (SCM_BIGP (y
)) {
3588 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_i_big2dbl (y
),
3589 SCM_COMPLEX_IMAG (x
));
3590 } else if (SCM_REALP (y
)) {
3591 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3592 SCM_COMPLEX_IMAG (x
));
3593 } else if (SCM_COMPLEXP (y
)) {
3594 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3595 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3597 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3600 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3605 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3606 /* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3607 * the sum of all but the first argument are subtracted from the first
3609 #define FUNC_NAME s_difference
3611 scm_difference (SCM x
, SCM y
)
3613 if (SCM_UNBNDP (y
)) {
3614 if (SCM_UNBNDP (x
)) {
3615 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3616 } else if (SCM_INUMP (x
)) {
3617 long xx
= -SCM_INUM (x
);
3618 if (SCM_FIXABLE (xx
)) {
3619 return SCM_MAKINUM (xx
);
3622 return scm_i_long2big (xx
);
3624 return scm_make_real ((double) xx
);
3627 } else if (SCM_BIGP (x
)) {
3628 SCM z
= scm_i_copybig (x
, !SCM_BIGSIGN (x
));
3629 unsigned int digs
= SCM_NUMDIGS (z
);
3630 unsigned int size
= digs
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
;
3631 return size
<= sizeof (SCM
) ? scm_i_big2inum (z
, digs
) : z
;
3632 } else if (SCM_REALP (x
)) {
3633 return scm_make_real (-SCM_REAL_VALUE (x
));
3634 } else if (SCM_COMPLEXP (x
)) {
3635 return scm_make_complex (-SCM_COMPLEX_REAL (x
), -SCM_COMPLEX_IMAG (x
));
3637 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3641 if (SCM_INUMP (x
)) {
3642 long int xx
= SCM_INUM (x
);
3643 if (SCM_INUMP (y
)) {
3644 long int yy
= SCM_INUM (y
);
3645 long int z
= xx
- yy
;
3646 if (SCM_FIXABLE (z
)) {
3647 return SCM_MAKINUM (z
);
3650 return scm_i_long2big (z
);
3652 return scm_make_real ((double) z
);
3655 } else if (SCM_BIGP (y
)) {
3656 #ifndef SCM_DIGSTOOBIG
3657 long z
= scm_pseudolong (xx
);
3658 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3659 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3661 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3662 scm_longdigs (xx
, zdigs
);
3663 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3664 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3666 } else if (SCM_REALP (y
)) {
3667 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
3668 } else if (SCM_COMPLEXP (y
)) {
3669 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
3670 -SCM_COMPLEX_IMAG (y
));
3672 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3674 } else if (SCM_BIGP (x
)) {
3675 if (SCM_INUMP (y
)) {
3676 long int yy
= SCM_INUM (y
);
3677 #ifndef SCM_DIGSTOOBIG
3678 long z
= scm_pseudolong (yy
);
3679 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3680 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3682 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3683 scm_longdigs (yy
, zdigs
);
3684 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3685 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3687 } else if (SCM_BIGP (y
)) {
3688 return (SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3689 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3690 SCM_BIGSIGN (x
), y
, SCM_BIGSIGNFLAG
)
3691 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3692 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
, x
, 0);
3693 } else if (SCM_REALP (y
)) {
3694 return scm_make_real (scm_i_big2dbl (x
) - SCM_REAL_VALUE (y
));
3695 } else if (SCM_COMPLEXP (y
)) {
3696 return scm_make_complex (scm_i_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3697 - SCM_COMPLEX_IMAG (y
));
3699 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3701 } else if (SCM_REALP (x
)) {
3702 if (SCM_INUMP (y
)) {
3703 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
3704 } else if (SCM_BIGP (y
)) {
3705 return scm_make_real (SCM_REAL_VALUE (x
) - scm_i_big2dbl (y
));
3706 } else if (SCM_REALP (y
)) {
3707 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3708 } else if (SCM_COMPLEXP (y
)) {
3709 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3710 -SCM_COMPLEX_IMAG (y
));
3712 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3714 } else if (SCM_COMPLEXP (x
)) {
3715 if (SCM_INUMP (y
)) {
3716 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
3717 SCM_COMPLEX_IMAG (x
));
3718 } else if (SCM_BIGP (y
)) {
3719 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_i_big2dbl (y
),
3720 SCM_COMPLEX_IMAG (x
));
3721 } else if (SCM_REALP (y
)) {
3722 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3723 SCM_COMPLEX_IMAG (x
));
3724 } else if (SCM_COMPLEXP (y
)) {
3725 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3726 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3728 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3731 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3736 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3737 /* "Return the product of all arguments. If called without arguments,\n"
3741 scm_product (SCM x
, SCM y
)
3743 if (SCM_UNBNDP (y
)) {
3744 if (SCM_UNBNDP (x
)) {
3745 return SCM_MAKINUM (1L);
3746 } else if (SCM_NUMBERP (x
)) {
3749 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3753 if (SCM_INUMP (x
)) {
3761 } else if (xx
== 1) {
3765 if (SCM_INUMP (y
)) {
3766 long yy
= SCM_INUM (y
);
3768 SCM k
= SCM_MAKINUM (kk
);
3769 if (kk
!= SCM_INUM (k
) || kk
/ xx
!= yy
) {
3771 int sgn
= (xx
< 0) ^ (yy
< 0);
3772 #ifndef SCM_DIGSTOOBIG
3773 long i
= scm_pseudolong (xx
);
3774 long j
= scm_pseudolong (yy
);
3775 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3776 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3777 #else /* SCM_DIGSTOOBIG */
3778 SCM_BIGDIG xdigs
[SCM_DIGSPERLONG
];
3779 SCM_BIGDIG ydigs
[SCM_DIGSPERLONG
];
3780 scm_longdigs (xx
, xdigs
);
3781 scm_longdigs (yy
, ydigs
);
3782 return scm_mulbig (xdigs
, SCM_DIGSPERLONG
,
3783 ydigs
, SCM_DIGSPERLONG
,
3787 return scm_make_real (((double) xx
) * ((double) yy
));
3792 } else if (SCM_BIGP (y
)) {
3793 #ifndef SCM_DIGSTOOBIG
3794 long z
= scm_pseudolong (xx
);
3795 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3796 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3797 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3799 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3800 scm_longdigs (xx
, zdigs
);
3801 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3802 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3803 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3805 } else if (SCM_REALP (y
)) {
3806 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3807 } else if (SCM_COMPLEXP (y
)) {
3808 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3809 xx
* SCM_COMPLEX_IMAG (y
));
3811 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3813 } else if (SCM_BIGP (x
)) {
3814 if (SCM_INUMP (y
)) {
3817 } else if (SCM_BIGP (y
)) {
3818 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3819 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3820 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3821 } else if (SCM_REALP (y
)) {
3822 return scm_make_real (scm_i_big2dbl (x
) * SCM_REAL_VALUE (y
));
3823 } else if (SCM_COMPLEXP (y
)) {
3824 double z
= scm_i_big2dbl (x
);
3825 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3826 z
* SCM_COMPLEX_IMAG (y
));
3828 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3830 } else if (SCM_REALP (x
)) {
3831 if (SCM_INUMP (y
)) {
3832 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3833 } else if (SCM_BIGP (y
)) {
3834 return scm_make_real (scm_i_big2dbl (y
) * SCM_REAL_VALUE (x
));
3835 } else if (SCM_REALP (y
)) {
3836 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
3837 } else if (SCM_COMPLEXP (y
)) {
3838 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
3839 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3841 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3843 } else if (SCM_COMPLEXP (x
)) {
3844 if (SCM_INUMP (y
)) {
3845 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3846 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3847 } else if (SCM_BIGP (y
)) {
3848 double z
= scm_i_big2dbl (y
);
3849 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
3850 z
* SCM_COMPLEX_IMAG (x
));
3851 } else if (SCM_REALP (y
)) {
3852 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3853 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
3854 } else if (SCM_COMPLEXP (y
)) {
3855 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
3856 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
3857 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3858 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3860 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3863 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3869 scm_num2dbl (SCM a
, const char *why
)
3870 #define FUNC_NAME why
3872 if (SCM_INUMP (a
)) {
3873 return (double) SCM_INUM (a
);
3874 } else if (SCM_BIGP (a
)) {
3875 return scm_i_big2dbl (a
);
3876 } else if (SCM_REALP (a
)) {
3877 return (SCM_REAL_VALUE (a
));
3879 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3884 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
3885 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
3886 #define ALLOW_DIVIDE_BY_ZERO
3887 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
3890 /* The code below for complex division is adapted from the GNU
3891 libstdc++, which adapted it from f2c's libF77, and is subject to
3894 /****************************************************************
3895 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
3897 Permission to use, copy, modify, and distribute this software
3898 and its documentation for any purpose and without fee is hereby
3899 granted, provided that the above copyright notice appear in all
3900 copies and that both that the copyright notice and this
3901 permission notice and warranty disclaimer appear in supporting
3902 documentation, and that the names of AT&T Bell Laboratories or
3903 Bellcore or any of their entities not be used in advertising or
3904 publicity pertaining to distribution of the software without
3905 specific, written prior permission.
3907 AT&T and Bellcore disclaim all warranties with regard to this
3908 software, including all implied warranties of merchantability
3909 and fitness. In no event shall AT&T or Bellcore be liable for
3910 any special, indirect or consequential damages or any damages
3911 whatsoever resulting from loss of use, data or profits, whether
3912 in an action of contract, negligence or other tortious action,
3913 arising out of or in connection with the use or performance of
3915 ****************************************************************/
3917 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3918 /* Divide the first argument by the product of the remaining
3919 arguments. If called with one argument @var{z1}, 1/@var{z1} is
3921 #define FUNC_NAME s_divide
3923 scm_divide (SCM x
, SCM y
)
3927 if (SCM_UNBNDP (y
)) {
3928 if (SCM_UNBNDP (x
)) {
3929 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
3930 } else if (SCM_INUMP (x
)) {
3931 long xx
= SCM_INUM (x
);
3932 if (xx
== 1 || xx
== -1) {
3934 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3935 } else if (xx
== 0) {
3936 scm_num_overflow (s_divide
);
3939 return scm_make_real (1.0 / (double) xx
);
3941 } else if (SCM_BIGP (x
)) {
3942 return scm_make_real (1.0 / scm_i_big2dbl (x
));
3943 } else if (SCM_REALP (x
)) {
3944 double xx
= SCM_REAL_VALUE (x
);
3945 #ifndef ALLOW_DIVIDE_BY_ZERO
3947 scm_num_overflow (s_divide
);
3950 return scm_make_real (1.0 / xx
);
3951 } else if (SCM_COMPLEXP (x
)) {
3952 double r
= SCM_COMPLEX_REAL (x
);
3953 double i
= SCM_COMPLEX_IMAG (x
);
3956 double d
= i
* (1.0 + t
* t
);
3957 return scm_make_complex (t
/ d
, -1.0 / d
);
3960 double d
= r
* (1.0 + t
* t
);
3961 return scm_make_complex (1.0 / d
, -t
/ d
);
3964 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3968 if (SCM_INUMP (x
)) {
3969 long xx
= SCM_INUM (x
);
3970 if (SCM_INUMP (y
)) {
3971 long yy
= SCM_INUM (y
);
3973 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
3974 scm_num_overflow (s_divide
);
3976 return scm_make_real ((double) xx
/ (double) yy
);
3978 } else if (xx
% yy
!= 0) {
3979 return scm_make_real ((double) xx
/ (double) yy
);
3982 if (SCM_FIXABLE (z
)) {
3983 return SCM_MAKINUM (z
);
3986 return scm_i_long2big (z
);
3988 return scm_make_real ((double) xx
/ (double) yy
);
3992 } else if (SCM_BIGP (y
)) {
3993 return scm_make_real ((double) xx
/ scm_i_big2dbl (y
));
3994 } else if (SCM_REALP (y
)) {
3995 double yy
= SCM_REAL_VALUE (y
);
3996 #ifndef ALLOW_DIVIDE_BY_ZERO
3998 scm_num_overflow (s_divide
);
4001 return scm_make_real ((double) xx
/ yy
);
4002 } else if (SCM_COMPLEXP (y
)) {
4004 complex_div
: /* y _must_ be a complex number */
4006 double r
= SCM_COMPLEX_REAL (y
);
4007 double i
= SCM_COMPLEX_IMAG (y
);
4010 double d
= i
* (1.0 + t
* t
);
4011 return scm_make_complex ((a
* t
) / d
, -a
/ d
);
4014 double d
= r
* (1.0 + t
* t
);
4015 return scm_make_complex (a
/ d
, -(a
* t
) / d
);
4019 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4021 } else if (SCM_BIGP (x
)) {
4022 if (SCM_INUMP (y
)) {
4023 long int yy
= SCM_INUM (y
);
4025 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4026 scm_num_overflow (s_divide
);
4028 if (scm_bigcomp (x
, scm_i_int2big (0)) == 0)
4033 } else if (yy
== 1) {
4036 long z
= yy
< 0 ? -yy
: yy
;
4037 if (z
< SCM_BIGRAD
) {
4038 SCM w
= scm_i_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
4039 return scm_divbigdig (SCM_BDIGITS (w
), SCM_NUMDIGS (w
),
4041 ? scm_make_real (scm_i_big2dbl (x
) / (double) yy
)
4042 : scm_i_normbig (w
);
4045 #ifndef SCM_DIGSTOOBIG
4046 z
= scm_pseudolong (z
);
4047 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
4048 (SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
4049 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
4051 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
4052 scm_longdigs (z
, zdigs
);
4053 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
4054 zdigs
, SCM_DIGSPERLONG
,
4055 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
4057 return (!SCM_UNBNDP (w
))
4059 : scm_make_real (scm_i_big2dbl (x
) / (double) yy
);
4062 } else if (SCM_BIGP (y
)) {
4063 SCM w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
4064 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
4065 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 3);
4066 return (!SCM_UNBNDP (w
))
4068 : scm_make_real (scm_i_big2dbl (x
) / scm_i_big2dbl (y
));
4069 } else if (SCM_REALP (y
)) {
4070 double yy
= SCM_REAL_VALUE (y
);
4071 #ifndef ALLOW_DIVIDE_BY_ZERO
4073 scm_num_overflow (s_divide
);
4076 return scm_make_real (scm_i_big2dbl (x
) / yy
);
4077 } else if (SCM_COMPLEXP (y
)) {
4078 a
= scm_i_big2dbl (x
);
4081 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4083 } else if (SCM_REALP (x
)) {
4084 double rx
= SCM_REAL_VALUE (x
);
4085 if (SCM_INUMP (y
)) {
4086 long int yy
= SCM_INUM (y
);
4087 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4089 scm_num_overflow (s_divide
);
4092 return scm_make_real (rx
/ (double) yy
);
4093 } else if (SCM_BIGP (y
)) {
4094 return scm_make_real (rx
/ scm_i_big2dbl (y
));
4095 } else if (SCM_REALP (y
)) {
4096 double yy
= SCM_REAL_VALUE (y
);
4097 #ifndef ALLOW_DIVIDE_BY_ZERO
4099 scm_num_overflow (s_divide
);
4102 return scm_make_real (rx
/ yy
);
4103 } else if (SCM_COMPLEXP (y
)) {
4107 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4109 } else if (SCM_COMPLEXP (x
)) {
4110 double rx
= SCM_COMPLEX_REAL (x
);
4111 double ix
= SCM_COMPLEX_IMAG (x
);
4112 if (SCM_INUMP (y
)) {
4113 long int yy
= SCM_INUM (y
);
4114 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4116 scm_num_overflow (s_divide
);
4121 return scm_make_complex (rx
/ d
, ix
/ d
);
4123 } else if (SCM_BIGP (y
)) {
4124 double d
= scm_i_big2dbl (y
);
4125 return scm_make_complex (rx
/ d
, ix
/ d
);
4126 } else if (SCM_REALP (y
)) {
4127 double yy
= SCM_REAL_VALUE (y
);
4128 #ifndef ALLOW_DIVIDE_BY_ZERO
4130 scm_num_overflow (s_divide
);
4133 return scm_make_complex (rx
/ yy
, ix
/ yy
);
4134 } else if (SCM_COMPLEXP (y
)) {
4135 double ry
= SCM_COMPLEX_REAL (y
);
4136 double iy
= SCM_COMPLEX_IMAG (y
);
4139 double d
= iy
* (1.0 + t
* t
);
4140 return scm_make_complex ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
4143 double d
= ry
* (1.0 + t
* t
);
4144 return scm_make_complex ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
4147 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
4150 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
4155 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
4156 /* "Return the inverse hyperbolic sine of @var{x}."
4159 scm_asinh (double x
)
4161 return log (x
+ sqrt (x
* x
+ 1));
4167 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
4168 /* "Return the inverse hyperbolic cosine of @var{x}."
4171 scm_acosh (double x
)
4173 return log (x
+ sqrt (x
* x
- 1));
4179 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
4180 /* "Return the inverse hyperbolic tangent of @var{x}."
4183 scm_atanh (double x
)
4185 return 0.5 * log ((1 + x
) / (1 - x
));
4191 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
4192 /* "Round the inexact number @var{x} towards zero."
4195 scm_truncate (double x
)
4204 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
4205 /* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
4206 * "numbers, round towards even."
4209 scm_round (double x
)
4211 double plus_half
= x
+ 0.5;
4212 double result
= floor (plus_half
);
4213 /* Adjust so that the scm_round is towards even. */
4214 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
4215 ? result
- 1 : result
;
4219 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
4220 /* "Round the number @var{x} towards minus infinity."
4222 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
4223 /* "Round the number @var{x} towards infinity."
4225 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
4226 /* "Return the square root of the real number @var{x}."
4228 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
4229 /* "Return the absolute value of the real number @var{x}."
4231 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
4232 /* "Return the @var{x}th power of e."
4234 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
4235 /* "Return the natural logarithm of the real number @var{x}."
4237 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
4238 /* "Return the sine of the real number @var{x}."
4240 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
4241 /* "Return the cosine of the real number @var{x}."
4243 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
4244 /* "Return the tangent of the real number @var{x}."
4246 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
4247 /* "Return the arc sine of the real number @var{x}."
4249 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
4250 /* "Return the arc cosine of the real number @var{x}."
4252 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
4253 /* "Return the arc tangent of the real number @var{x}."
4255 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
4256 /* "Return the hyperbolic sine of the real number @var{x}."
4258 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
4259 /* "Return the hyperbolic cosine of the real number @var{x}."
4261 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
4262 /* "Return the hyperbolic tangent of the real number @var{x}."
4270 static void scm_two_doubles (SCM x
,
4272 const char *sstring
,
4276 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
4278 if (SCM_INUMP (x
)) {
4279 xy
->x
= SCM_INUM (x
);
4280 } else if (SCM_BIGP (x
)) {
4281 xy
->x
= scm_i_big2dbl (x
);
4282 } else if (SCM_REALP (x
)) {
4283 xy
->x
= SCM_REAL_VALUE (x
);
4285 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
4288 if (SCM_INUMP (y
)) {
4289 xy
->y
= SCM_INUM (y
);
4290 } else if (SCM_BIGP (y
)) {
4291 xy
->y
= scm_i_big2dbl (y
);
4292 } else if (SCM_REALP (y
)) {
4293 xy
->y
= SCM_REAL_VALUE (y
);
4295 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
4300 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
4302 "Return @var{x} raised to the power of @var{y}. This\n"
4303 "procedure does not accept complex arguments.")
4304 #define FUNC_NAME s_scm_sys_expt
4307 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4308 return scm_make_real (pow (xy
.x
, xy
.y
));
4313 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4315 "Return the arc tangent of the two arguments @var{x} and\n"
4316 "@var{y}. This is similar to calculating the arc tangent of\n"
4317 "@var{x} / @var{y}, except that the signs of both arguments\n"
4318 "are used to determine the quadrant of the result. This\n"
4319 "procedure does not accept complex arguments.")
4320 #define FUNC_NAME s_scm_sys_atan2
4323 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4324 return scm_make_real (atan2 (xy
.x
, xy
.y
));
4329 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4330 (SCM real
, SCM imaginary
),
4331 "Return a complex number constructed of the given @var{real} and\n"
4332 "@var{imaginary} parts.")
4333 #define FUNC_NAME s_scm_make_rectangular
4336 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
4337 return scm_make_complex (xy
.x
, xy
.y
);
4343 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4345 "Return the complex number @var{x} * e^(i * @var{y}).")
4346 #define FUNC_NAME s_scm_make_polar
4349 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4350 return scm_make_complex (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
4355 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4356 /* "Return the real part of the number @var{z}."
4359 scm_real_part (SCM z
)
4361 if (SCM_INUMP (z
)) {
4363 } else if (SCM_BIGP (z
)) {
4365 } else if (SCM_REALP (z
)) {
4367 } else if (SCM_COMPLEXP (z
)) {
4368 return scm_make_real (SCM_COMPLEX_REAL (z
));
4370 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4375 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4376 /* "Return the imaginary part of the number @var{z}."
4379 scm_imag_part (SCM z
)
4381 if (SCM_INUMP (z
)) {
4383 } else if (SCM_BIGP (z
)) {
4385 } else if (SCM_REALP (z
)) {
4387 } else if (SCM_COMPLEXP (z
)) {
4388 return scm_make_real (SCM_COMPLEX_IMAG (z
));
4390 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4395 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4396 /* "Return the magnitude of the number @var{z}. This is the same as\n"
4397 * "@code{abs} for real arguments, but also allows complex numbers."
4400 scm_magnitude (SCM z
)
4402 if (SCM_INUMP (z
)) {
4403 long int zz
= SCM_INUM (z
);
4406 } else if (SCM_POSFIXABLE (-zz
)) {
4407 return SCM_MAKINUM (-zz
);
4410 return scm_i_long2big (-zz
);
4412 scm_num_overflow (s_magnitude
);
4415 } else if (SCM_BIGP (z
)) {
4416 if (!SCM_BIGSIGN (z
)) {
4419 return scm_i_copybig (z
, 0);
4421 } else if (SCM_REALP (z
)) {
4422 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
4423 } else if (SCM_COMPLEXP (z
)) {
4424 double r
= SCM_COMPLEX_REAL (z
);
4425 double i
= SCM_COMPLEX_IMAG (z
);
4426 return scm_make_real (sqrt (i
* i
+ r
* r
));
4428 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4433 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
4434 /* "Return the angle of the complex number @var{z}."
4439 if (SCM_INUMP (z
)) {
4440 if (SCM_INUM (z
) >= 0) {
4441 return scm_make_real (atan2 (0.0, 1.0));
4443 return scm_make_real (atan2 (0.0, -1.0));
4445 } else if (SCM_BIGP (z
)) {
4446 if (SCM_BIGSIGN (z
)) {
4447 return scm_make_real (atan2 (0.0, -1.0));
4449 return scm_make_real (atan2 (0.0, 1.0));
4451 } else if (SCM_REALP (z
)) {
4452 return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z
)));
4453 } else if (SCM_COMPLEXP (z
)) {
4454 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
4456 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
4461 SCM_GPROC (s_exact_to_inexact
, "exact->inexact", 1, 0, 0, scm_exact_to_inexact
, g_exact_to_inexact
);
4462 /* Convert the number @var{x} to its inexact representation.\n"
4465 scm_exact_to_inexact (SCM z
)
4468 return scm_make_real ((double) SCM_INUM (z
));
4469 else if (SCM_BIGP (z
))
4470 return scm_make_real (scm_i_big2dbl (z
));
4471 else if (SCM_INEXACTP (z
))
4474 SCM_WTA_DISPATCH_1 (g_exact_to_inexact
, z
, 1, s_exact_to_inexact
);
4478 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4480 "Return an exact number that is numerically closest to @var{z}.")
4481 #define FUNC_NAME s_scm_inexact_to_exact
4483 if (SCM_INUMP (z
)) {
4485 } else if (SCM_BIGP (z
)) {
4487 } else if (SCM_REALP (z
)) {
4488 double u
= floor (SCM_REAL_VALUE (z
) + 0.5);
4490 if (SCM_FIXABLE (lu
)) {
4491 return SCM_MAKINUM (lu
);
4493 } else if (isfinite (u
) && !xisnan (u
)) {
4494 return scm_i_dbl2big (u
);
4497 scm_num_overflow (s_scm_inexact_to_exact
);
4500 SCM_WRONG_TYPE_ARG (1, z
);
4507 /* d must be integer */
4510 scm_i_dbl2big (double d
)
4516 double u
= (d
< 0) ? -d
: d
;
4517 while (0 != floor (u
))
4522 ans
= scm_i_mkbig (i
, d
< 0);
4523 digits
= SCM_BDIGITS (ans
);
4532 scm_num_overflow ("dbl2big");
4537 scm_i_big2dbl (SCM b
)
4540 size_t i
= SCM_NUMDIGS (b
);
4541 SCM_BIGDIG
*digits
= SCM_BDIGITS (b
);
4543 ans
= digits
[i
] + SCM_BIGRAD
* ans
;
4544 if (SCM_BIGSIGN (b
))
4551 #ifdef HAVE_LONG_LONGS
4553 # define ULLONG_MAX ((unsigned long long) (-1))
4554 # define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
4555 # define LLONG_MIN (~LLONG_MAX)
4559 /* Parameters for creating integer conversion routines.
4561 Define the following preprocessor macros before including
4562 "libguile/num2integral.i.c":
4564 NUM2INTEGRAL - the name of the function for converting from a
4565 Scheme object to the integral type. This function
4566 will be defined when including "num2integral.i.c".
4568 INTEGRAL2NUM - the name of the function for converting from the
4569 integral type to a Scheme object. This function
4572 INTEGRAL2BIG - the name of an internal function that createas a
4573 bignum from the integral type. This function will
4574 be defined. The name should start with "scm_i_".
4576 ITYPE - the name of the integral type.
4578 UNSIGNED - Define this when ITYPE is an unsigned type. Do not
4579 define it otherwise.
4582 - the name of the the unsigned variant of the
4583 integral type. If you don't define this, it defaults
4584 to "unsigned ITYPE" for signed types and simply "ITYPE"
4587 SIZEOF_ITYPE - an expression giving the size of the integral type in
4588 bytes. This expression must be computable by the
4589 preprocessor. If you don't know a value for this,
4590 don't define it. The purpose of this parameter is
4591 mainly to suppress some warnings. The generated
4592 code will work correctly without it.
4595 #define NUM2INTEGRAL scm_num2short
4596 #define INTEGRAL2NUM scm_short2num
4597 #define INTEGRAL2BIG scm_i_short2big
4599 #define SIZEOF_ITYPE SIZEOF_SHORT
4600 #include "libguile/num2integral.i.c"
4602 #define NUM2INTEGRAL scm_num2ushort
4603 #define INTEGRAL2NUM scm_ushort2num
4604 #define INTEGRAL2BIG scm_i_ushort2big
4606 #define ITYPE unsigned short
4607 #define SIZEOF_ITYPE SIZEOF_SHORT
4608 #include "libguile/num2integral.i.c"
4610 #define NUM2INTEGRAL scm_num2int
4611 #define INTEGRAL2NUM scm_int2num
4612 #define INTEGRAL2BIG scm_i_int2big
4614 #define SIZEOF_ITYPE SIZEOF_INT
4615 #include "libguile/num2integral.i.c"
4617 #define NUM2INTEGRAL scm_num2uint
4618 #define INTEGRAL2NUM scm_uint2num
4619 #define INTEGRAL2BIG scm_i_uint2big
4621 #define ITYPE unsigned int
4622 #define SIZEOF_ITYPE SIZEOF_INT
4623 #include "libguile/num2integral.i.c"
4625 #define NUM2INTEGRAL scm_num2long
4626 #define INTEGRAL2NUM scm_long2num
4627 #define INTEGRAL2BIG scm_i_long2big
4629 #define SIZEOF_ITYPE SIZEOF_LONG
4630 #include "libguile/num2integral.i.c"
4632 #define NUM2INTEGRAL scm_num2ulong
4633 #define INTEGRAL2NUM scm_ulong2num
4634 #define INTEGRAL2BIG scm_i_ulong2big
4636 #define ITYPE unsigned long
4637 #define SIZEOF_ITYPE SIZEOF_LONG
4638 #include "libguile/num2integral.i.c"
4640 #define NUM2INTEGRAL scm_num2ptrdiff
4641 #define INTEGRAL2NUM scm_ptrdiff2num
4642 #define INTEGRAL2BIG scm_i_ptrdiff2big
4643 #define ITYPE ptrdiff_t
4644 #define UNSIGNED_ITYPE size_t
4645 #define SIZEOF_ITYPE SIZEOF_PTRDIFF_T
4646 #include "libguile/num2integral.i.c"
4648 #define NUM2INTEGRAL scm_num2size
4649 #define INTEGRAL2NUM scm_size2num
4650 #define INTEGRAL2BIG scm_i_size2big
4652 #define ITYPE size_t
4653 #define SIZEOF_ITYPE SIZEOF_SIZE_T
4654 #include "libguile/num2integral.i.c"
4656 #ifdef HAVE_LONG_LONGS
4658 #ifndef ULONG_LONG_MAX
4659 #define ULONG_LONG_MAX (~0ULL)
4662 #define NUM2INTEGRAL scm_num2long_long
4663 #define INTEGRAL2NUM scm_long_long2num
4664 #define INTEGRAL2BIG scm_i_long_long2big
4665 #define ITYPE long long
4666 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
4667 #include "libguile/num2integral.i.c"
4669 #define NUM2INTEGRAL scm_num2ulong_long
4670 #define INTEGRAL2NUM scm_ulong_long2num
4671 #define INTEGRAL2BIG scm_i_ulong_long2big
4673 #define ITYPE unsigned long long
4674 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
4675 #include "libguile/num2integral.i.c"
4677 #endif /* HAVE_LONG_LONGS */
4679 #define NUM2FLOAT scm_num2float
4680 #define FLOAT2NUM scm_float2num
4682 #include "libguile/num2float.i.c"
4684 #define NUM2FLOAT scm_num2double
4685 #define FLOAT2NUM scm_double2num
4686 #define FTYPE double
4687 #include "libguile/num2float.i.c"
4692 #define SIZE_MAX ((size_t) (-1))
4695 #define PTRDIFF_MIN \
4696 ((ptrdiff_t) ((ptrdiff_t) 1 << (sizeof (ptrdiff_t) * 8 - 1)))
4699 #define PTRDIFF_MAX (~ PTRDIFF_MIN)
4702 #define CHECK(type, v) \
4704 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
4723 CHECK (ptrdiff
, -1);
4725 CHECK (short, SHRT_MAX
);
4726 CHECK (short, SHRT_MIN
);
4727 CHECK (ushort
, USHRT_MAX
);
4728 CHECK (int, INT_MAX
);
4729 CHECK (int, INT_MIN
);
4730 CHECK (uint
, UINT_MAX
);
4731 CHECK (long, LONG_MAX
);
4732 CHECK (long, LONG_MIN
);
4733 CHECK (ulong
, ULONG_MAX
);
4734 CHECK (size
, SIZE_MAX
);
4735 CHECK (ptrdiff
, PTRDIFF_MAX
);
4736 CHECK (ptrdiff
, PTRDIFF_MIN
);
4738 #ifdef HAVE_LONG_LONGS
4739 CHECK (long_long
, 0LL);
4740 CHECK (ulong_long
, 0ULL);
4741 CHECK (long_long
, -1LL);
4742 CHECK (long_long
, LLONG_MAX
);
4743 CHECK (long_long
, LLONG_MIN
);
4744 CHECK (ulong_long
, ULLONG_MAX
);
4751 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
4752 if (!SCM_FALSEP (data)) abort();
4755 check_body (void *data
)
4757 SCM num
= *(SCM
*) data
;
4758 scm_num2ulong (num
, 1, NULL
);
4760 return SCM_UNSPECIFIED
;
4764 check_handler (void *data
, SCM tag
, SCM throw_args
)
4766 SCM
*num
= (SCM
*) data
;
4769 return SCM_UNSPECIFIED
;
4772 SCM_DEFINE (scm_sys_check_number_conversions
, "%check-number-conversions", 0, 0, 0,
4774 "Number conversion sanity checking.")
4775 #define FUNC_NAME s_scm_sys_check_number_conversions
4777 SCM data
= SCM_MAKINUM (-1);
4779 data
= scm_int2num (INT_MIN
);
4781 data
= scm_ulong2num (ULONG_MAX
);
4782 data
= scm_difference (SCM_INUM0
, data
);
4784 data
= scm_ulong2num (ULONG_MAX
);
4785 data
= scm_sum (SCM_MAKINUM (1), data
); data
= scm_difference (SCM_INUM0
, data
);
4787 data
= scm_int2num (-10000); data
= scm_product (data
, data
); data
= scm_product (data
, data
);
4790 return SCM_UNSPECIFIED
;
4799 abs_most_negative_fixnum
= scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM
);
4800 scm_permanent_object (abs_most_negative_fixnum
);
4802 /* It may be possible to tune the performance of some algorithms by using
4803 * the following constants to avoid the creation of bignums. Please, before
4804 * using these values, remember the two rules of program optimization:
4805 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
4806 scm_c_define ("most-positive-fixnum",
4807 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
4808 scm_c_define ("most-negative-fixnum",
4809 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
4811 scm_add_feature ("complex");
4812 scm_add_feature ("inexact");
4813 scm_flo0
= scm_make_real (0.0);
4815 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4817 { /* determine floating point precision */
4819 double fsum
= 1.0 + f
;
4820 while (fsum
!= 1.0) {
4821 if (++scm_dblprec
> 20) {
4828 scm_dblprec
= scm_dblprec
- 1;
4830 #endif /* DBL_DIG */
4836 #include "libguile/numbers.x"