1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
48 #include "libguile/_scm.h"
49 #include "libguile/feature.h"
50 #include "libguile/ports.h"
51 #include "libguile/root.h"
52 #include "libguile/smob.h"
53 #include "libguile/strings.h"
55 #include "libguile/validate.h"
56 #include "libguile/numbers.h"
60 static SCM
scm_divbigbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
);
61 static SCM
scm_divbigint (SCM x
, long z
, int sgn
, int mode
);
64 #define DIGITS '0':case '1':case '2':case '3':case '4':\
65 case '5':case '6':case '7':case '8':case '9'
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 /* IS_INF tests its floating point number for infiniteness
78 Dirk:FIXME:: This test does not work if x == 0
81 #define IS_INF(x) ((x) == (x) / 2)
85 /* Return true if X is not infinite and is not a NaN
86 Dirk:FIXME:: Since IS_INF is broken, this test does not work if x == 0
89 #define isfinite(x) (!IS_INF (x) && (x) == (x))
94 static SCM abs_most_negative_fixnum
;
99 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
101 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
103 #define FUNC_NAME s_scm_exact_p
107 } else if (SCM_BIGP (x
)) {
116 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
118 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
120 #define FUNC_NAME s_scm_odd_p
123 return SCM_BOOL ((4 & SCM_UNPACK (n
)) != 0);
124 } else if (SCM_BIGP (n
)) {
125 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) != 0);
127 SCM_WRONG_TYPE_ARG (1, n
);
133 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
135 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
137 #define FUNC_NAME s_scm_even_p
140 return SCM_BOOL ((4 & SCM_UNPACK (n
)) == 0);
141 } else if (SCM_BIGP (n
)) {
142 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) == 0);
144 SCM_WRONG_TYPE_ARG (1, n
);
150 SCM_GPROC (s_abs
, "abs", 1, 0, 0, scm_abs
, g_abs
);
151 /* "Return the absolute value of @var{x}."
157 long int xx
= SCM_INUM (x
);
160 } else if (SCM_POSFIXABLE (-xx
)) {
161 return SCM_MAKINUM (-xx
);
164 return scm_long2big (-xx
);
166 scm_num_overflow (s_abs
);
169 } else if (SCM_BIGP (x
)) {
170 if (!SCM_BIGSIGN (x
)) {
173 return scm_copybig (x
, 0);
175 } else if (SCM_REALP (x
)) {
176 return scm_make_real (fabs (SCM_REAL_VALUE (x
)));
178 SCM_WTA_DISPATCH_1 (g_abs
, x
, 1, s_abs
);
183 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
184 /* "Return the quotient of the numbers @var{x} and @var{y}."
187 scm_quotient (SCM x
, SCM y
)
190 long xx
= SCM_INUM (x
);
192 long yy
= SCM_INUM (y
);
194 scm_num_overflow (s_quotient
);
197 if (SCM_FIXABLE (z
)) {
198 return SCM_MAKINUM (z
);
201 return scm_long2big (z
);
203 scm_num_overflow (s_quotient
);
207 } else if (SCM_BIGP (y
)) {
208 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
209 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
211 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
212 return SCM_MAKINUM (-1);
215 return SCM_MAKINUM (0);
217 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
219 } else if (SCM_BIGP (x
)) {
221 long yy
= SCM_INUM (y
);
223 scm_num_overflow (s_quotient
);
224 } else if (yy
== 1) {
227 long z
= yy
< 0 ? -yy
: yy
;
229 if (z
< SCM_BIGRAD
) {
230 SCM sw
= scm_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
231 scm_divbigdig (SCM_BDIGITS (sw
), SCM_NUMDIGS (sw
), (SCM_BIGDIG
) z
);
232 return scm_normbig (sw
);
234 #ifndef SCM_DIGSTOOBIG
235 long w
= scm_pseudolong (z
);
236 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
237 (SCM_BIGDIG
*) & w
, SCM_DIGSPERLONG
,
238 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
240 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
241 scm_longdigs (z
, zdigs
);
242 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
243 zdigs
, SCM_DIGSPERLONG
,
244 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
248 } else if (SCM_BIGP (y
)) {
249 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
250 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
251 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 2);
253 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
256 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
261 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
262 /* "Return the remainder of the numbers @var{x} and @var{y}.\n"
264 * "(remainder 13 4) @result{} 1\n"
265 * "(remainder -13 4) @result{} -1\n"
269 scm_remainder (SCM x
, SCM y
)
273 long yy
= SCM_INUM (y
);
275 scm_num_overflow (s_remainder
);
277 long z
= SCM_INUM (x
) % yy
;
278 return SCM_MAKINUM (z
);
280 } else if (SCM_BIGP (y
)) {
281 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
282 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
284 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
285 return SCM_MAKINUM (0);
290 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
292 } else if (SCM_BIGP (x
)) {
294 long yy
= SCM_INUM (y
);
296 scm_num_overflow (s_remainder
);
298 return scm_divbigint (x
, yy
, SCM_BIGSIGN (x
), 0);
300 } else if (SCM_BIGP (y
)) {
301 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
302 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
305 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
308 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
313 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
314 /* "Return the modulo of the numbers @var{x} and @var{y}.\n"
316 * "(modulo 13 4) @result{} 1\n"
317 * "(modulo -13 4) @result{} 3\n"
321 scm_modulo (SCM x
, SCM y
)
324 long xx
= SCM_INUM (x
);
326 long yy
= SCM_INUM (y
);
328 scm_num_overflow (s_modulo
);
331 return SCM_MAKINUM (((yy
< 0) ? (z
> 0) : (z
< 0)) ? z
+ yy
: z
);
333 } else if (SCM_BIGP (y
)) {
334 return (SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0)) ? scm_sum (x
, y
) : x
;
336 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
338 } else if (SCM_BIGP (x
)) {
340 long yy
= SCM_INUM (y
);
342 scm_num_overflow (s_modulo
);
344 return scm_divbigint (x
, yy
, yy
< 0,
345 (SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0)) ? 1 : 0);
347 } else if (SCM_BIGP (y
)) {
348 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
349 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
351 (SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
)) ? 1 : 0);
353 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
356 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
361 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
362 /* "Return the greatest common divisor of all arguments.\n"
363 * "If called without arguments, 0 is returned."
366 scm_gcd (SCM x
, SCM y
)
368 if (SCM_UNBNDP (y
)) {
369 if (SCM_UNBNDP (x
)) {
379 long xx
= SCM_INUM (x
);
380 long yy
= SCM_INUM (y
);
381 long u
= xx
< 0 ? -xx
: xx
;
382 long v
= yy
< 0 ? -yy
: yy
;
387 } else if (yy
== 0) {
393 /* Determine a common factor 2^k */
394 while (!(1 & (u
| v
))) {
400 /* Now, any factor 2^n can be eliminated */
420 if (SCM_POSFIXABLE (result
)) {
421 return SCM_MAKINUM (result
);
424 return scm_long2big (result
);
426 scm_num_overflow (s_gcd
);
429 } else if (SCM_BIGP (y
)) {
433 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
435 } else if (SCM_BIGP (x
)) {
438 x
= scm_copybig (x
, 0);
441 if (SCM_EQ_P (y
, SCM_INUM0
)) {
446 } else if (SCM_BIGP (y
)) {
448 y
= scm_copybig (y
, 0);
449 switch (scm_bigcomp (x
, y
))
454 SCM t
= scm_remainder (x
, y
);
460 y
= scm_remainder (y
, x
);
462 default: /* x == y */
465 /* instead of the switch, we could just
466 return scm_gcd (y, scm_modulo (x, y)); */
468 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
471 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
476 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
477 /* "Return the least common multiple of the arguments.\n"
478 * "If called without arguments, 1 is returned."
481 scm_lcm (SCM n1
, SCM n2
)
483 if (SCM_UNBNDP (n2
)) {
484 if (SCM_UNBNDP (n1
)) {
485 return SCM_MAKINUM (1L);
487 n2
= SCM_MAKINUM (1L);
492 SCM_GASSERT2 (SCM_INUMP (n1
), g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
493 SCM_GASSERT2 (SCM_INUMP (n2
), g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
495 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
496 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
497 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
498 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
502 SCM d
= scm_gcd (n1
, n2
);
503 if (SCM_EQ_P (d
, SCM_INUM0
)) {
506 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
513 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
515 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
519 /* Emulating 2's complement bignums with sign magnitude arithmetic:
524 + + + x (map digit:logand X Y)
525 + - + x (map digit:logand X (lognot (+ -1 Y)))
526 - + + y (map digit:logand (lognot (+ -1 X)) Y)
527 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
532 + + + (map digit:logior X Y)
533 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
534 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
535 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
540 + + + (map digit:logxor X Y)
541 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
542 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
543 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
548 + + (any digit:logand X Y)
549 + - (any digit:logand X (lognot (+ -1 Y)))
550 - + (any digit:logand (lognot (+ -1 X)) Y)
557 SCM
scm_copy_big_dec(SCM b
, int sign
);
558 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
);
559 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
560 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
561 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
);
562 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
564 SCM
scm_copy_big_dec(SCM b
, int sign
)
567 scm_sizet nx
= SCM_NUMDIGS(b
);
569 SCM ans
= scm_mkbig(nx
, sign
);
570 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
571 if SCM_BIGSIGN(b
) do {
573 if (num
< 0) {dst
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
574 else {dst
[i
] = SCM_BIGLO(num
); num
= 0;}
577 while (nx
--) dst
[nx
] = src
[nx
];
581 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
)
585 SCM z
= scm_mkbig(nx
, zsgn
);
586 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
589 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
590 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
592 else do zds
[i
] = x
[i
]; while (++i
< nx
);
596 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
597 /* Assumes nx <= SCM_NUMDIGS(bigy) */
598 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
601 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
602 SCM z
= scm_copy_big_dec (bigy
, xsgn
& SCM_BIGSIGN (bigy
));
603 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
607 if (num
< 0) {zds
[i
] |= num
+ SCM_BIGRAD
; num
= -1;}
608 else {zds
[i
] |= SCM_BIGLO(num
); num
= 0;}
610 /* ========= Need to increment zds now =========== */
614 zds
[i
++] = SCM_BIGLO(num
);
615 num
= SCM_BIGDN(num
);
618 scm_adjbig(z
, 1 + ny
); /* OOPS, overflowed into next digit. */
619 SCM_BDIGITS(z
)[ny
] = 1;
622 else do zds
[i
] = zds
[i
] | x
[i
]; while (++i
< nx
);
626 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
627 /* Assumes nx <= SCM_NUMDIGS(bigy) */
628 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
631 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
632 SCM z
= scm_copy_big_dec(bigy
, xsgn
^ SCM_BIGSIGN(bigy
));
633 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
636 if (num
< 0) {zds
[i
] ^= num
+ SCM_BIGRAD
; num
= -1;}
637 else {zds
[i
] ^= SCM_BIGLO(num
); num
= 0;}
640 zds
[i
] = zds
[i
] ^ x
[i
];
643 if (xsgn
^ SCM_BIGSIGN(bigy
)) {
644 /* ========= Need to increment zds now =========== */
648 zds
[i
++] = SCM_BIGLO(num
);
649 num
= SCM_BIGDN(num
);
650 if (!num
) return scm_normbig(z
);
653 return scm_normbig(z
);
656 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
)
657 /* Assumes nx <= SCM_NUMDIGS(bigy) */
658 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
659 /* return sign equals either 0 or SCM_BIGSIGNFLAG */
666 z
= scm_copy_smaller(x
, nx
, zsgn
);
667 x
= SCM_BDIGITS(bigy
);
668 xsgn
= SCM_BIGSIGN(bigy
);
670 else z
= scm_copy_big_dec(bigy
, zsgn
);
671 zds
= SCM_BDIGITS(z
);
676 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
677 else {zds
[i
] &= SCM_BIGLO(num
); num
= 0;}
679 else do zds
[i
] = zds
[i
] & ~x
[i
]; while (++i
< nx
);
680 /* ========= need to increment zds now =========== */
684 zds
[i
++] = SCM_BIGLO(num
);
685 num
= SCM_BIGDN(num
);
686 if (!num
) return scm_normbig(z
);
690 unsigned long int carry
= 1;
692 unsigned long int mask
= (SCM_BIGDIG
) ~x
[i
] + carry
;
693 zds
[i
] = zds
[i
] & (SCM_BIGDIG
) mask
;
694 carry
= (mask
>= SCM_BIGRAD
) ? 1 : 0;
696 } else do zds
[i
] = zds
[i
] & x
[i
]; while (++i
< nx
);
697 return scm_normbig(z
);
700 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
701 /* Assumes nx <= SCM_NUMDIGS(bigy) */
702 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
707 if (SCM_BIGSIGN(bigy
) & xsgn
) return SCM_BOOL_T
;
708 if (SCM_NUMDIGS(bigy
) != nx
&& xsgn
) return SCM_BOOL_T
;
709 y
= SCM_BDIGITS(bigy
);
714 if (y
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
718 if (y
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
722 else if SCM_BIGSIGN(bigy
)
726 if (x
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
730 if (x
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
735 do if (x
[i
] & y
[i
]) return SCM_BOOL_T
;
743 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
745 "Return the integer which is the bit-wise AND of the two integer\n"
749 "(number->string (logand #b1100 #b1010) 2)\n"
750 " @result{} \"1000\"\n"
752 #define FUNC_NAME s_scm_logand
756 if (SCM_UNBNDP (n2
)) {
757 if (SCM_UNBNDP (n1
)) {
758 return SCM_MAKINUM (-1);
759 } else if (!SCM_NUMBERP (n1
)) {
760 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
762 } else if (SCM_NUMBERP (n1
)) {
765 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
773 if (SCM_INUMP (n1
)) {
775 if (SCM_INUMP (n2
)) {
776 long nn2
= SCM_INUM (n2
);
777 return SCM_MAKINUM (nn1
& nn2
);
778 } else if SCM_BIGP (n2
) {
781 # ifndef SCM_DIGSTOOBIG
782 long z
= scm_pseudolong (nn1
);
783 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
784 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
785 SCM_BIGSIGNFLAG
, n2
);
787 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
788 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
791 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
792 scm_longdigs (nn1
, zdigs
);
793 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
794 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
796 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
797 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
802 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
804 } else if (SCM_BIGP (n1
)) {
805 if (SCM_INUMP (n2
)) {
809 } else if (SCM_BIGP (n2
)) {
810 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
813 if ((SCM_BIGSIGN (n1
)) && SCM_BIGSIGN (n2
)) {
814 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
815 SCM_BIGSIGNFLAG
, n2
);
817 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
818 SCM_BIGSIGN (n1
), n2
, 0);
821 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
824 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
830 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
832 "Return the integer which is the bit-wise OR of the two integer\n"
836 "(number->string (logior #b1100 #b1010) 2)\n"
837 " @result{} \"1110\"\n"
839 #define FUNC_NAME s_scm_logior
843 if (SCM_UNBNDP (n2
)) {
844 if (SCM_UNBNDP (n1
)) {
847 } else if (SCM_NUMBERP (n1
)) {
850 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
858 if (SCM_INUMP (n1
)) {
860 if (SCM_INUMP (n2
)) {
861 long nn2
= SCM_INUM (n2
);
862 return SCM_MAKINUM (nn1
| nn2
);
863 } else if (SCM_BIGP (n2
)) {
866 # ifndef SCM_DIGSTOOBIG
867 long z
= scm_pseudolong (nn1
);
868 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
869 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
870 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
872 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
873 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
876 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
877 scm_longdigs (nn1
, zdigs
);
878 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
879 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
,
880 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
882 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
883 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
888 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
890 } else if (SCM_BIGP (n1
)) {
891 if (SCM_INUMP (n2
)) {
895 } else if (SCM_BIGP (n2
)) {
896 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
899 if ((!SCM_BIGSIGN (n1
)) && !SCM_BIGSIGN (n2
)) {
900 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
901 SCM_BIGSIGN (n1
), n2
);
903 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
904 SCM_BIGSIGN (n1
), n2
, SCM_BIGSIGNFLAG
);
907 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
910 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
916 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
918 "Return the integer which is the bit-wise XOR of the two integer\n"
922 "(number->string (logxor #b1100 #b1010) 2)\n"
923 " @result{} \"110\"\n"
925 #define FUNC_NAME s_scm_logxor
929 if (SCM_UNBNDP (n2
)) {
930 if (SCM_UNBNDP (n1
)) {
933 } else if (SCM_NUMBERP (n1
)) {
936 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
944 if (SCM_INUMP (n1
)) {
946 if (SCM_INUMP (n2
)) {
947 long nn2
= SCM_INUM (n2
);
948 return SCM_MAKINUM (nn1
^ nn2
);
949 } else if (SCM_BIGP (n2
)) {
952 # ifndef SCM_DIGSTOOBIG
953 long z
= scm_pseudolong (nn1
);
954 return scm_big_xor ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
955 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
957 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
958 scm_longdigs (nn1
, zdigs
);
959 return scm_big_xor (zdigs
, SCM_DIGSPERLONG
,
960 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
964 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
966 } else if (SCM_BIGP (n1
)) {
967 if (SCM_INUMP (n2
)) {
971 } else if (SCM_BIGP (n2
)) {
972 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {
975 return scm_big_xor (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
976 SCM_BIGSIGN (n1
), n2
);
978 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
981 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
987 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
990 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
991 "(logtest #b0100 #b1011) @result{} #f\n"
992 "(logtest #b0100 #b0111) @result{} #t\n"
994 #define FUNC_NAME s_scm_logtest
1000 if (SCM_INUMP (k
)) {
1001 long nk
= SCM_INUM (k
);
1002 return SCM_BOOL (nj
& nk
);
1003 } else if (SCM_BIGP (k
)) {
1006 # ifndef SCM_DIGSTOOBIG
1007 long z
= scm_pseudolong (nj
);
1008 return scm_big_test ((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
1009 (nj
< 0) ? SCM_BIGSIGNFLAG
: 0, k
);
1011 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
1012 scm_longdigs (nj
, zdigs
);
1013 return scm_big_test (zdigs
, SCM_DIGSPERLONG
,
1014 (nj
< 0) ? SCM_BIGSIGNFLAG
: 0, k
);
1018 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1020 } else if (SCM_BIGP (j
)) {
1021 if (SCM_INUMP (k
)) {
1025 } else if (SCM_BIGP (k
)) {
1026 if (SCM_NUMDIGS (j
) > SCM_NUMDIGS (k
)) {
1029 return scm_big_test (SCM_BDIGITS (j
), SCM_NUMDIGS (j
),
1030 SCM_BIGSIGN (j
), k
);
1032 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1035 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
1041 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
1044 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1045 "(logbit? 0 #b1101) @result{} #t\n"
1046 "(logbit? 1 #b1101) @result{} #f\n"
1047 "(logbit? 2 #b1101) @result{} #t\n"
1048 "(logbit? 3 #b1101) @result{} #t\n"
1049 "(logbit? 4 #b1101) @result{} #f\n"
1051 #define FUNC_NAME s_scm_logbit_p
1053 unsigned long int iindex
;
1055 SCM_VALIDATE_INUM_MIN (SCM_ARG1
, index
, 0);
1056 iindex
= (unsigned long int) SCM_INUM (index
);
1058 if (SCM_INUMP (j
)) {
1059 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1060 } else if (SCM_BIGP (j
)) {
1061 if (SCM_NUMDIGS (j
) * SCM_BITSPERDIG
< iindex
) {
1063 } else if (SCM_BIGSIGN (j
)) {
1066 SCM_BIGDIG
* x
= SCM_BDIGITS (j
);
1067 scm_sizet nx
= iindex
/ SCM_BITSPERDIG
;
1071 return SCM_BOOL (((1L << (iindex
% SCM_BITSPERDIG
)) & num
) == 0);
1072 } else if (num
< 0) {
1079 return SCM_BOOL (SCM_BDIGITS (j
) [iindex
/ SCM_BITSPERDIG
]
1080 & (1L << (iindex
% SCM_BITSPERDIG
)));
1083 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1089 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1091 "Return the integer which is the 2s-complement of the integer\n"
1095 "(number->string (lognot #b10000000) 2)\n"
1096 " @result{} \"-10000001\"\n"
1097 "(number->string (lognot #b0) 2)\n"
1098 " @result{} \"-1\"\n"
1100 #define FUNC_NAME s_scm_lognot
1102 return scm_difference (SCM_MAKINUM (-1L), n
);
1106 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1108 "Return @var{n} raised to the non-negative integer exponent\n"
1112 "(integer-expt 2 5)\n"
1114 "(integer-expt -3 3)\n"
1117 #define FUNC_NAME s_scm_integer_expt
1119 SCM acc
= SCM_MAKINUM (1L);
1122 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1124 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1125 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1127 SCM_VALIDATE_ULONG_COPY (2,k
,i2
);
1131 n
= scm_divide (n
, SCM_UNDEFINED
);
1138 return scm_product (acc
, n
);
1140 acc
= scm_product (acc
, n
);
1141 n
= scm_product (n
, n
);
1147 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1149 "The function ash performs an arithmetic shift left by @var{cnt}\n"
1150 "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n"
1151 "means, that the function does not guarantee to keep the bit\n"
1152 "structure of @var{n}, but rather guarantees that the result\n"
1153 "will always be rounded towards minus infinity. Therefore, the\n"
1154 "results of ash and a corresponding bitwise shift will differ if\n"
1155 "@var{n} is negative.\n"
1157 "Formally, the function returns an integer equivalent to\n"
1158 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n"
1161 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1162 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
1164 #define FUNC_NAME s_scm_ash
1169 SCM_VALIDATE_INUM (1, n
)
1171 SCM_VALIDATE_INUM (2, cnt
);
1173 bits_to_shift
= SCM_INUM (cnt
);
1175 if (bits_to_shift
< 0) {
1176 /* Shift right by abs(cnt) bits. This is realized as a division by
1177 div:=2^abs(cnt). However, to guarantee the floor rounding, negative
1178 values require some special treatment.
1180 SCM div
= scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift
));
1181 if (SCM_FALSEP (scm_negative_p (n
)))
1182 return scm_quotient (n
, div
);
1184 return scm_sum (SCM_MAKINUM (-1L),
1185 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1187 /* Shift left is done by multiplication with 2^CNT */
1188 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1190 if (bits_to_shift
< 0)
1191 /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */
1192 return SCM_MAKINUM (SCM_SRS (SCM_INUM (n
), -bits_to_shift
));
1194 /* Shift left, but make sure not to leave the range of inums */
1195 SCM res
= SCM_MAKINUM (SCM_INUM (n
) << cnt
);
1196 if (SCM_INUM (res
) >> cnt
!= SCM_INUM (n
))
1197 scm_num_overflow (FUNC_NAME
);
1205 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1206 (SCM n
, SCM start
, SCM end
),
1207 "Return the integer composed of the @var{start} (inclusive)\n"
1208 "through @var{end} (exclusive) bits of @var{n}. The\n"
1209 "@var{start}th bit becomes the 0-th bit in the result.\n"
1212 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1213 " @result{} \"1010\"\n"
1214 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1215 " @result{} \"10110\"\n"
1217 #define FUNC_NAME s_scm_bit_extract
1219 unsigned long int istart
, iend
;
1220 SCM_VALIDATE_INUM_MIN_COPY (2,start
,0,istart
);
1221 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1222 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1224 if (SCM_INUMP (n
)) {
1225 long int in
= SCM_INUM (n
);
1226 unsigned long int bits
= iend
- istart
;
1228 if (in
< 0 && bits
>= SCM_FIXNUM_BIT
)
1230 /* Since we emulate two's complement encoded numbers, this special
1231 * case requires us to produce a result that has more bits than can be
1232 * stored in a fixnum. Thus, we fall back to the more general
1233 * algorithm that is used for bignums.
1238 if (istart
< SCM_FIXNUM_BIT
)
1241 if (bits
< SCM_FIXNUM_BIT
)
1242 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1243 else /* we know: in >= 0 */
1244 return SCM_MAKINUM (in
);
1248 return SCM_MAKINUM (-1L & ((1L << bits
) - 1));
1252 return SCM_MAKINUM (0);
1254 } else if (SCM_BIGP (n
)) {
1257 SCM num1
= SCM_MAKINUM (1L);
1258 SCM num2
= SCM_MAKINUM (2L);
1259 SCM bits
= SCM_MAKINUM (iend
- istart
);
1260 SCM mask
= scm_difference (scm_integer_expt (num2
, bits
), num1
);
1261 return scm_logand (mask
, scm_ash (n
, SCM_MAKINUM (-istart
)));
1264 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1270 static const char scm_logtab
[] = {
1271 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1274 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1276 "Return the number of bits in integer @var{n}. If integer is\n"
1277 "positive, the 1-bits in its binary representation are counted.\n"
1278 "If negative, the 0-bits in its two's-complement binary\n"
1279 "representation are counted. If 0, 0 is returned.\n"
1282 "(logcount #b10101010)\n"
1289 #define FUNC_NAME s_scm_logcount
1291 if (SCM_INUMP (n
)) {
1292 unsigned long int c
= 0;
1293 long int nn
= SCM_INUM (n
);
1298 c
+= scm_logtab
[15 & nn
];
1301 return SCM_MAKINUM (c
);
1302 } else if (SCM_BIGP (n
)) {
1303 if (SCM_BIGSIGN (n
)) {
1304 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n
));
1306 unsigned long int c
= 0;
1307 scm_sizet i
= SCM_NUMDIGS (n
);
1308 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1311 for (d
= ds
[i
]; d
; d
>>= 4) {
1312 c
+= scm_logtab
[15 & d
];
1315 return SCM_MAKINUM (c
);
1318 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1324 static const char scm_ilentab
[] = {
1325 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1328 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1330 "Return the number of bits neccessary to represent @var{n}.\n"
1333 "(integer-length #b10101010)\n"
1335 "(integer-length 0)\n"
1337 "(integer-length #b1111)\n"
1340 #define FUNC_NAME s_scm_integer_length
1342 if (SCM_INUMP (n
)) {
1343 unsigned long int c
= 0;
1345 long int nn
= SCM_INUM (n
);
1351 l
= scm_ilentab
[15 & nn
];
1354 return SCM_MAKINUM (c
- 4 + l
);
1355 } else if (SCM_BIGP (n
)) {
1356 if (SCM_BIGSIGN (n
)) {
1357 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n
));
1359 unsigned long int digs
= SCM_NUMDIGS (n
) - 1;
1360 unsigned long int c
= digs
* SCM_BITSPERDIG
;
1362 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1363 SCM_BIGDIG d
= ds
[digs
];
1366 l
= scm_ilentab
[15 & d
];
1369 return SCM_MAKINUM (c
- 4 + l
);
1372 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1379 static const char s_bignum
[] = "bignum";
1382 scm_mkbig (scm_sizet nlen
, int sign
)
1385 /* Cast to long int to avoid signed/unsigned comparison warnings. */
1386 if ((( ((long int) nlen
) << SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
)
1388 scm_memory_error (s_bignum
);
1392 SCM_SET_BIGNUM_BASE (v
, scm_must_malloc (nlen
* sizeof (SCM_BIGDIG
), s_bignum
));
1393 SCM_SETNUMDIGS (v
, nlen
, sign
);
1400 scm_big2inum (SCM b
, scm_sizet l
)
1402 unsigned long num
= 0;
1403 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1405 num
= SCM_BIGUP (num
) + tmp
[l
];
1406 if (!SCM_BIGSIGN (b
))
1408 if (SCM_POSFIXABLE (num
))
1409 return SCM_MAKINUM (num
);
1411 else if (num
<= -SCM_MOST_NEGATIVE_FIXNUM
)
1412 return SCM_MAKINUM (-num
);
1417 static const char s_adjbig
[] = "scm_adjbig";
1420 scm_adjbig (SCM b
, scm_sizet nlen
)
1422 scm_sizet nsiz
= nlen
;
1423 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1424 scm_memory_error (s_adjbig
);
1430 scm_must_realloc ((char *) SCM_BDIGITS (b
),
1431 (long) (SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
)),
1432 (long) (nsiz
* sizeof (SCM_BIGDIG
)), s_bignum
));
1434 SCM_SET_BIGNUM_BASE (b
, digits
);
1435 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1447 scm_sizet nlen
= SCM_NUMDIGS (b
);
1449 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1451 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1452 while (nlen
-- && !zds
[nlen
]);
1454 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1455 if (SCM_INUMP (b
= scm_big2inum (b
, (scm_sizet
) nlen
)))
1457 if (SCM_NUMDIGS (b
) == nlen
)
1459 return scm_adjbig (b
, (scm_sizet
) nlen
);
1465 scm_copybig (SCM b
, int sign
)
1467 scm_sizet i
= SCM_NUMDIGS (b
);
1468 SCM ans
= scm_mkbig (i
, sign
);
1469 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1478 scm_long2big (long n
)
1482 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, n
< 0);
1483 digits
= SCM_BDIGITS (ans
);
1486 while (i
< SCM_DIGSPERLONG
)
1488 digits
[i
++] = SCM_BIGLO (n
);
1489 n
= SCM_BIGDN ((unsigned long) n
);
1494 #ifdef HAVE_LONG_LONGS
1497 scm_long_long2big (long_long n
)
1507 if ((long long) tn
== n
)
1508 return scm_long2big (tn
);
1514 for (tn
= n
, n_digits
= 0;
1516 ++n_digits
, tn
= SCM_BIGDN ((ulong_long
) tn
))
1521 ans
= scm_mkbig (n_digits
, n
< 0);
1522 digits
= SCM_BDIGITS (ans
);
1525 while (i
< n_digits
)
1527 digits
[i
++] = SCM_BIGLO (n
);
1528 n
= SCM_BIGDN ((ulong_long
) n
);
1532 #endif /* HAVE_LONG_LONGS */
1536 scm_2ulong2big (unsigned long *np
)
1543 ans
= scm_mkbig (2 * SCM_DIGSPERLONG
, 0);
1544 digits
= SCM_BDIGITS (ans
);
1547 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1549 digits
[i
] = SCM_BIGLO (n
);
1550 n
= SCM_BIGDN ((unsigned long) n
);
1553 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1555 digits
[i
+ SCM_DIGSPERLONG
] = SCM_BIGLO (n
);
1556 n
= SCM_BIGDN ((unsigned long) n
);
1564 scm_ulong2big (unsigned long n
)
1568 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, 0);
1569 digits
= SCM_BDIGITS (ans
);
1570 while (i
< SCM_DIGSPERLONG
)
1572 digits
[i
++] = SCM_BIGLO (n
);
1581 scm_bigcomp (SCM x
, SCM y
)
1583 int xsign
= SCM_BIGSIGN (x
);
1584 int ysign
= SCM_BIGSIGN (y
);
1585 scm_sizet xlen
, ylen
;
1587 /* Look at the signs, first. */
1593 /* They're the same sign, so see which one has more digits. Note
1594 that, if they are negative, the longer number is the lesser. */
1595 ylen
= SCM_NUMDIGS (y
);
1596 xlen
= SCM_NUMDIGS (x
);
1598 return (xsign
) ? -1 : 1;
1600 return (xsign
) ? 1 : -1;
1602 /* They have the same number of digits, so find the most significant
1603 digit where they differ. */
1607 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1608 /* Make the discrimination based on the digit that differs. */
1609 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1611 : (xsign
? 1 : -1));
1614 /* The numbers are identical. */
1618 #ifndef SCM_DIGSTOOBIG
1622 scm_pseudolong (long x
)
1627 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1633 while (i
< SCM_DIGSPERLONG
)
1635 p
.bd
[i
++] = SCM_BIGLO (x
);
1638 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1646 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1651 while (i
< SCM_DIGSPERLONG
)
1653 digs
[i
++] = SCM_BIGLO (x
);
1662 scm_addbig (SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int sgny
)
1664 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1665 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1667 scm_sizet i
= 0, ny
= SCM_NUMDIGS (bigy
);
1668 SCM z
= scm_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1669 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1670 if (xsgn
^ SCM_BIGSIGN (z
))
1674 num
+= (long) zds
[i
] - x
[i
];
1677 zds
[i
] = num
+ SCM_BIGRAD
;
1682 zds
[i
] = SCM_BIGLO (num
);
1687 if (num
&& nx
== ny
)
1691 SCM_SET_CELL_WORD_0 (z
, SCM_CELL_WORD_0 (z
) ^ SCM_BIGSIGNFLAG
);
1694 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1695 zds
[i
++] = SCM_BIGLO (num
);
1696 num
= SCM_BIGDN (num
);
1706 zds
[i
++] = num
+ SCM_BIGRAD
;
1711 zds
[i
++] = SCM_BIGLO (num
);
1720 num
+= (long) zds
[i
] + x
[i
];
1721 zds
[i
++] = SCM_BIGLO (num
);
1722 num
= SCM_BIGDN (num
);
1730 zds
[i
++] = SCM_BIGLO (num
);
1731 num
= SCM_BIGDN (num
);
1737 z
= scm_adjbig (z
, ny
+ 1);
1738 SCM_BDIGITS (z
)[ny
] = num
;
1742 return scm_normbig (z
);
1747 scm_mulbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
)
1749 scm_sizet i
= 0, j
= nx
+ ny
;
1750 unsigned long n
= 0;
1751 SCM z
= scm_mkbig (j
, sgn
);
1752 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1762 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1763 zds
[i
+ j
++] = SCM_BIGLO (n
);
1775 return scm_normbig (z
);
1780 scm_divbigdig (SCM_BIGDIG
* ds
, scm_sizet h
, SCM_BIGDIG div
)
1782 register unsigned long t2
= 0;
1785 t2
= SCM_BIGUP (t2
) + ds
[h
];
1795 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1801 register unsigned long t2
= 0;
1802 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1803 scm_sizet nd
= SCM_NUMDIGS (x
);
1805 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1808 return SCM_MAKINUM (sgn
? -t2
: t2
);
1811 #ifndef SCM_DIGSTOOBIG
1812 unsigned long t2
= scm_pseudolong (z
);
1813 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1814 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1817 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1818 scm_longdigs (z
, t2
);
1819 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1820 t2
, SCM_DIGSPERLONG
,
1828 scm_divbigbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
)
1830 /* modes description
1834 3 quotient but returns SCM_UNDEFINED if division is not exact. */
1835 scm_sizet i
= 0, j
= 0;
1837 unsigned long t2
= 0;
1839 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1840 /* algorithm requires nx >= ny */
1844 case 0: /* remainder -- just return x */
1845 z
= scm_mkbig (nx
, sgn
);
1846 zds
= SCM_BDIGITS (z
);
1853 case 1: /* scm_modulo -- return y-x */
1854 z
= scm_mkbig (ny
, sgn
);
1855 zds
= SCM_BDIGITS (z
);
1858 num
+= (long) y
[i
] - x
[i
];
1861 zds
[i
] = num
+ SCM_BIGRAD
;
1876 zds
[i
++] = num
+ SCM_BIGRAD
;
1887 return SCM_INUM0
; /* quotient is zero */
1889 return SCM_UNDEFINED
; /* the division is not exact */
1892 z
= scm_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1893 zds
= SCM_BDIGITS (z
);
1897 ny
--; /* in case y came in as a psuedolong */
1898 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1899 { /* normalize operands */
1900 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1901 newy
= scm_mkbig (ny
, 0);
1902 yds
= SCM_BDIGITS (newy
);
1905 t2
+= (unsigned long) y
[j
] * d
;
1906 yds
[j
++] = SCM_BIGLO (t2
);
1907 t2
= SCM_BIGDN (t2
);
1914 t2
+= (unsigned long) x
[j
] * d
;
1915 zds
[j
++] = SCM_BIGLO (t2
);
1916 t2
= SCM_BIGDN (t2
);
1926 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1928 { /* loop over digits of quotient */
1929 if (zds
[j
] == y
[ny
- 1])
1930 qhat
= SCM_BIGRAD
- 1;
1932 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1939 { /* multiply and subtract */
1940 t2
+= (unsigned long) y
[i
] * qhat
;
1941 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1944 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1949 zds
[j
- ny
+ i
] = num
;
1952 t2
= SCM_BIGDN (t2
);
1955 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1957 { /* "add back" required */
1963 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1964 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1965 num
= SCM_BIGDN (num
);
1976 case 3: /* check that remainder==0 */
1977 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1979 return SCM_UNDEFINED
;
1980 case 2: /* move quotient down in z */
1981 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
1982 for (i
= 0; i
< j
; i
++)
1983 zds
[i
] = zds
[i
+ ny
];
1986 case 1: /* subtract for scm_modulo */
1992 num
+= y
[i
] - zds
[i
];
1996 zds
[i
] = num
+ SCM_BIGRAD
;
2008 case 0: /* just normalize remainder */
2010 scm_divbigdig (zds
, ny
, d
);
2013 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
2014 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
2015 if (SCM_INUMP (z
= scm_big2inum (z
, j
)))
2017 return scm_adjbig (z
, j
);
2025 /*** NUMBERS -> STRINGS ***/
2027 static const double fx
[] =
2028 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
2029 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
2030 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
2031 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
2037 idbl2str (double f
, char *a
)
2039 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
2044 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
2063 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
2064 make-uniform-vector, from causing infinite loops. */
2068 if (exp
-- < DBL_MIN_10_EXP
)
2074 if (exp
++ > DBL_MAX_10_EXP
)
2089 if (f
+ fx
[wp
] >= 10.0)
2096 dpt
= (exp
+ 9999) % 3;
2100 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2125 if (f
+ fx
[wp
] >= 1.0)
2139 if ((dpt
> 4) && (exp
> 6))
2141 d
= (a
[0] == '-' ? 2 : 1);
2142 for (i
= ch
++; i
> d
; i
--)
2155 if (a
[ch
- 1] == '.')
2156 a
[ch
++] = '0'; /* trailing zero */
2165 for (i
= 10; i
<= exp
; i
*= 10);
2166 for (i
/= 10; i
; i
/= 10)
2168 a
[ch
++] = exp
/ i
+ '0';
2177 iflo2str (SCM flt
, char *str
)
2180 if (SCM_SLOPPY_REALP (flt
))
2181 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2184 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2185 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2187 if (0 <= SCM_COMPLEX_IMAG (flt
))
2189 i
+= idbl2str (SCM_COMPLEX_IMAG (flt
), &str
[i
]);
2196 /* convert a long to a string (unterminated). returns the number of
2197 characters in the result.
2199 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2201 scm_iint2str (long num
, int rad
, char *p
)
2205 unsigned long n
= (num
< 0) ? -num
: num
;
2207 for (n
/= rad
; n
> 0; n
/= rad
)
2224 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2233 big2str (SCM b
, unsigned int radix
)
2235 SCM t
= scm_copybig (b
, 0); /* sign of temp doesn't matter */
2236 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2237 scm_sizet i
= SCM_NUMDIGS (t
);
2238 scm_sizet j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2239 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2240 : (SCM_BITSPERDIG
* i
) + 2;
2242 scm_sizet radct
= 0;
2243 SCM_BIGDIG radpow
= 1, radmod
= 0;
2244 SCM ss
= scm_allocate_string (j
);
2245 char *s
= SCM_STRING_CHARS (ss
), c
;
2246 while ((long) radpow
* radix
< SCM_BIGRAD
)
2251 while ((i
|| radmod
) && j
)
2255 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2263 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2266 if (SCM_BIGSIGN (b
))
2271 /* The pre-reserved string length was too large. */
2272 unsigned long int length
= SCM_STRING_LENGTH (ss
);
2273 ss
= scm_substring (ss
, SCM_MAKINUM (j
), SCM_MAKINUM (length
));
2276 return scm_return_first (ss
, t
);
2281 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2283 "Return a string holding the external representation of the\n"
2284 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2285 "inexact, a radix of 10 will be used.")
2286 #define FUNC_NAME s_scm_number_to_string
2290 if (SCM_UNBNDP (radix
)) {
2293 SCM_VALIDATE_INUM (2, radix
);
2294 base
= SCM_INUM (radix
);
2295 SCM_ASSERT_RANGE (2, radix
, base
>= 2);
2298 if (SCM_INUMP (n
)) {
2299 char num_buf
[SCM_INTBUFLEN
];
2300 scm_sizet length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2301 return scm_makfromstr (num_buf
, length
, 0);
2302 } else if (SCM_BIGP (n
)) {
2303 return big2str (n
, (unsigned int) base
);
2304 } else if (SCM_INEXACTP (n
)) {
2305 char num_buf
[FLOBUFLEN
];
2306 return scm_makfromstr (num_buf
, iflo2str (n
, num_buf
), 0);
2308 SCM_WRONG_TYPE_ARG (1, n
);
2314 /* These print routines are stubbed here so that scm_repl.c doesn't need
2315 SCM_BIGDIG conditionals */
2318 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2320 char num_buf
[FLOBUFLEN
];
2321 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2326 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2328 char num_buf
[FLOBUFLEN
];
2329 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2334 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate
)
2337 exp
= big2str (exp
, (unsigned int) 10);
2338 scm_lfwrite (SCM_STRING_CHARS (exp
), (scm_sizet
) SCM_STRING_LENGTH (exp
), port
);
2340 scm_ipruk ("bignum", exp
, port
);
2344 /*** END nums->strs ***/
2346 /*** STRINGS -> NUMBERS ***/
2349 scm_small_istr2int (char *str
, long len
, long radix
)
2351 register long n
= 0, ln
;
2356 return SCM_BOOL_F
; /* zero scm_length */
2358 { /* leading sign */
2363 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2368 switch (c
= str
[i
++])
2390 return SCM_BOOL_F
; /* bad digit for radix */
2393 /* Negation is a workaround for HP700 cc bug */
2394 if (n
> ln
|| (-n
> -SCM_MOST_NEGATIVE_FIXNUM
))
2398 return SCM_BOOL_F
; /* not a digit */
2403 if ((n
= -n
) > SCM_MOST_POSITIVE_FIXNUM
)
2405 return SCM_MAKINUM (n
);
2406 ovfl
: /* overflow scheme integer */
2413 scm_istr2int (char *str
, long len
, long radix
)
2416 register scm_sizet k
, blen
= 1;
2420 register SCM_BIGDIG
*ds
;
2421 register unsigned long t2
;
2424 return SCM_BOOL_F
; /* zero scm_length */
2426 /* Short numbers we parse directly into an int, to avoid the overhead
2427 of creating a bignum. */
2429 return scm_small_istr2int (str
, len
, radix
);
2432 j
= 1 + (4 * len
* sizeof (char)) / (SCM_BITSPERDIG
);
2433 else if (10 <= radix
)
2434 j
= 1 + (84 * len
* sizeof (char)) / (SCM_BITSPERDIG
* 25);
2436 j
= 1 + (len
* sizeof (char)) / (SCM_BITSPERDIG
);
2438 { /* leading sign */
2441 if (++i
== (unsigned) len
)
2442 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2444 res
= scm_mkbig (j
, '-' == str
[0]);
2445 ds
= SCM_BDIGITS (res
);
2450 switch (c
= str
[i
++])
2472 return SCM_BOOL_F
; /* bad digit for radix */
2478 /* printf ("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]); */
2479 t2
+= ds
[k
] * radix
;
2480 ds
[k
++] = SCM_BIGLO (t2
);
2481 t2
= SCM_BIGDN (t2
);
2484 scm_num_overflow ("bignum");
2492 return SCM_BOOL_F
; /* not a digit */
2495 while (i
< (unsigned) len
);
2496 if (blen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
2497 if (SCM_INUMP (res
= scm_big2inum (res
, blen
)))
2501 return scm_adjbig (res
, blen
);
2505 scm_istr2flo (char *str
, long len
, long radix
)
2507 register int c
, i
= 0;
2509 double res
= 0.0, tmp
= 0.0;
2515 return SCM_BOOL_F
; /* zero scm_length */
2518 { /* leading sign */
2531 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2533 if (str
[i
] == 'i' || str
[i
] == 'I')
2534 { /* handle `+i' and `-i' */
2535 if (lead_sgn
== 0.0)
2536 return SCM_BOOL_F
; /* must have leading sign */
2538 return SCM_BOOL_F
; /* `i' not last character */
2539 return scm_make_complex (0.0, lead_sgn
);
2542 { /* check initial digits */
2552 goto out1
; /* must be exponent */
2569 return SCM_BOOL_F
; /* bad digit for radix */
2570 res
= res
* radix
+ c
;
2571 flg
= 1; /* res is valid */
2580 /* if true, then we did see a digit above, and res is valid */
2584 /* By here, must have seen a digit,
2585 or must have next char be a `.' with radix==10 */
2587 if (!(str
[i
] == '.' && radix
== 10))
2590 while (str
[i
] == '#')
2591 { /* optional sharps */
2624 tmp
= tmp
* radix
+ c
;
2632 return SCM_BOOL_F
; /* `slash zero' not allowed */
2634 while (str
[i
] == '#')
2635 { /* optional sharps */
2645 { /* decimal point notation */
2647 return SCM_BOOL_F
; /* must be radix 10 */
2654 res
= res
* 10.0 + c
- '0';
2663 return SCM_BOOL_F
; /* no digits before or after decimal point */
2666 while (str
[i
] == '#')
2667 { /* ignore remaining sharps */
2686 int expsgn
= 1, expon
= 0;
2688 return SCM_BOOL_F
; /* only in radix 10 */
2690 return SCM_BOOL_F
; /* bad exponent */
2697 return SCM_BOOL_F
; /* bad exponent */
2699 if (str
[i
] < '0' || str
[i
] > '9')
2700 return SCM_BOOL_F
; /* bad exponent */
2706 expon
= expon
* 10 + c
- '0';
2707 if (expon
> SCM_MAXEXP
)
2708 scm_out_of_range ("string->number", SCM_MAKINUM (expon
));
2716 point
+= expsgn
* expon
;
2734 /* at this point, we have a legitimate floating point result */
2735 if (lead_sgn
== -1.0)
2738 return scm_make_real (res
);
2740 if (str
[i
] == 'i' || str
[i
] == 'I')
2741 { /* pure imaginary number */
2742 if (lead_sgn
== 0.0)
2743 return SCM_BOOL_F
; /* must have leading sign */
2745 return SCM_BOOL_F
; /* `i' not last character */
2746 return scm_make_complex (0.0, res
);
2758 { /* polar input for complex number */
2759 /* get a `real' for scm_angle */
2760 second
= scm_istr2flo (&str
[i
], (long) (len
- i
), radix
);
2761 if (!SCM_SLOPPY_INEXACTP (second
))
2762 return SCM_BOOL_F
; /* not `real' */
2763 if (SCM_SLOPPY_COMPLEXP (second
))
2764 return SCM_BOOL_F
; /* not `real' */
2765 tmp
= SCM_REAL_VALUE (second
);
2766 return scm_make_complex (res
* cos (tmp
), res
* sin (tmp
));
2772 /* at this point, last char must be `i' */
2773 if (str
[len
- 1] != 'i' && str
[len
- 1] != 'I')
2775 /* handles `x+i' and `x-i' */
2777 return scm_make_complex (res
, lead_sgn
);
2778 /* get a `ureal' for complex part */
2779 second
= scm_istr2flo (&str
[i
], (long) ((len
- i
) - 1), radix
);
2780 if (!SCM_INEXACTP (second
))
2781 return SCM_BOOL_F
; /* not `ureal' */
2782 if (SCM_SLOPPY_COMPLEXP (second
))
2783 return SCM_BOOL_F
; /* not `ureal' */
2784 tmp
= SCM_REAL_VALUE (second
);
2786 return SCM_BOOL_F
; /* not `ureal' */
2787 return scm_make_complex (res
, (lead_sgn
* tmp
));
2793 scm_istring2number (char *str
, long len
, long radix
)
2797 char ex_p
= 0, rx_p
= 0; /* Only allow 1 exactness and 1 radix prefix */
2800 if (*str
== '+' || *str
== '-') /* Catches lone `+' and `-' for speed */
2803 while ((len
- i
) >= 2 && str
[i
] == '#' && ++i
)
2849 return scm_istr2int (&str
[i
], len
- i
, radix
);
2851 res
= scm_istr2int (&str
[i
], len
- i
, radix
);
2852 if (SCM_NFALSEP (res
))
2855 return scm_istr2flo (&str
[i
], len
- i
, radix
);
2861 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2862 (SCM string
, SCM radix
),
2863 "Return a number of the maximally precise representation\n"
2864 "expressed by the given @var{string}. @var{radix} must be an\n"
2865 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2866 "is a default radix that may be overridden by an explicit radix\n"
2867 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2868 "supplied, then the default radix is 10. If string is not a\n"
2869 "syntactically valid notation for a number, then\n"
2870 "@code{string->number} returns @code{#f}.")
2871 #define FUNC_NAME s_scm_string_to_number
2875 SCM_VALIDATE_STRING (1, string
);
2876 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2877 answer
= scm_istring2number (SCM_STRING_CHARS (string
),
2878 SCM_STRING_LENGTH (string
),
2880 return scm_return_first (answer
, string
);
2883 /*** END strs->nums ***/
2887 scm_make_real (double x
)
2891 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
2892 SCM_REAL_VALUE (z
) = x
;
2898 scm_make_complex (double x
, double y
)
2901 return scm_make_real (x
);
2904 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_must_malloc (2L * sizeof (double), "complex"));
2905 SCM_COMPLEX_REAL (z
) = x
;
2906 SCM_COMPLEX_IMAG (z
) = y
;
2913 scm_bigequal (SCM x
, SCM y
)
2916 if (0 == scm_bigcomp (x
, y
))
2923 scm_real_equalp (SCM x
, SCM y
)
2925 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2929 scm_complex_equalp (SCM x
, SCM y
)
2931 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2932 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2937 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2938 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2939 * "else. Note that the sets of complex, real, rational and\n"
2940 * "integer values form subsets of the set of numbers, i. e. the\n"
2941 * "predicate will be fulfilled for any number."
2943 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2945 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2946 "else. Note that the sets of real, rational and integer\n"
2947 "values form subsets of the set of complex numbers, i. e. the\n"
2948 "predicate will also be fulfilled if @var{x} is a real,\n"
2949 "rational or integer number.")
2950 #define FUNC_NAME s_scm_number_p
2952 return SCM_BOOL (SCM_NUMBERP (x
));
2957 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2958 /* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
2959 * "Note that the sets of integer and rational values form a subset\n"
2960 * "of the set of real numbers, i. e. the predicate will also\n"
2961 * "be fulfilled if @var{x} is an integer or a rational number."
2963 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2965 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
2966 "else. Note that the set of integer values forms a subset of\n"
2967 "the set of rational numbers, i. e. the predicate will also be\n"
2968 "fulfilled if @var{x} is an integer number. Real numbers\n"
2969 "will also satisfy this predicate, because of their limited\n"
2971 #define FUNC_NAME s_scm_real_p
2973 if (SCM_INUMP (x
)) {
2975 } else if (SCM_IMP (x
)) {
2977 } else if (SCM_SLOPPY_REALP (x
)) {
2979 } else if (SCM_BIGP (x
)) {
2988 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2990 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2992 #define FUNC_NAME s_scm_integer_p
3001 if (!SCM_SLOPPY_INEXACTP (x
))
3003 if (SCM_SLOPPY_COMPLEXP (x
))
3005 r
= SCM_REAL_VALUE (x
);
3013 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
3015 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
3017 #define FUNC_NAME s_scm_inexact_p
3019 return SCM_BOOL (SCM_INEXACTP (x
));
3024 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
3025 /* "Return @code{#t} if all parameters are numerically equal." */
3027 scm_num_eq_p (SCM x
, SCM y
)
3029 if (SCM_INUMP (x
)) {
3030 long xx
= SCM_INUM (x
);
3031 if (SCM_INUMP (y
)) {
3032 long yy
= SCM_INUM (y
);
3033 return SCM_BOOL (xx
== yy
);
3034 } else if (SCM_BIGP (y
)) {
3036 } else if (SCM_REALP (y
)) {
3037 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
3038 } else if (SCM_COMPLEXP (y
)) {
3039 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
3040 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3042 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3044 } else if (SCM_BIGP (x
)) {
3045 if (SCM_INUMP (y
)) {
3047 } else if (SCM_BIGP (y
)) {
3048 return SCM_BOOL (0 == scm_bigcomp (x
, y
));
3049 } else if (SCM_REALP (y
)) {
3050 return SCM_BOOL (scm_big2dbl (x
) == SCM_REAL_VALUE (y
));
3051 } else if (SCM_COMPLEXP (y
)) {
3052 return SCM_BOOL ((scm_big2dbl (x
) == SCM_COMPLEX_REAL (y
))
3053 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3055 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3057 } else if (SCM_REALP (x
)) {
3058 if (SCM_INUMP (y
)) {
3059 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3060 } else if (SCM_BIGP (y
)) {
3061 return SCM_BOOL (SCM_REAL_VALUE (x
) == scm_big2dbl (y
));
3062 } else if (SCM_REALP (y
)) {
3063 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3064 } else if (SCM_COMPLEXP (y
)) {
3065 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3066 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3068 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3070 } else if (SCM_COMPLEXP (x
)) {
3071 if (SCM_INUMP (y
)) {
3072 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3073 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3074 } else if (SCM_BIGP (y
)) {
3075 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == scm_big2dbl (y
))
3076 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3077 } else if (SCM_REALP (y
)) {
3078 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3079 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3080 } else if (SCM_COMPLEXP (y
)) {
3081 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3082 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3084 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3087 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3092 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3093 /* "Return @code{#t} if the list of parameters is monotonically\n"
3097 scm_less_p (SCM x
, SCM y
)
3099 if (SCM_INUMP (x
)) {
3100 long xx
= SCM_INUM (x
);
3101 if (SCM_INUMP (y
)) {
3102 long yy
= SCM_INUM (y
);
3103 return SCM_BOOL (xx
< yy
);
3104 } else if (SCM_BIGP (y
)) {
3105 return SCM_BOOL (!SCM_BIGSIGN (y
));
3106 } else if (SCM_REALP (y
)) {
3107 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3109 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3111 } else if (SCM_BIGP (x
)) {
3112 if (SCM_INUMP (y
)) {
3113 return SCM_BOOL (SCM_BIGSIGN (x
));
3114 } else if (SCM_BIGP (y
)) {
3115 return SCM_BOOL (1 == scm_bigcomp (x
, y
));
3116 } else if (SCM_REALP (y
)) {
3117 return SCM_BOOL (scm_big2dbl (x
) < SCM_REAL_VALUE (y
));
3119 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3121 } else if (SCM_REALP (x
)) {
3122 if (SCM_INUMP (y
)) {
3123 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3124 } else if (SCM_BIGP (y
)) {
3125 return SCM_BOOL (SCM_REAL_VALUE (x
) < scm_big2dbl (y
));
3126 } else if (SCM_REALP (y
)) {
3127 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3129 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3132 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3137 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3138 /* "Return @code{#t} if the list of parameters is monotonically\n"
3141 #define FUNC_NAME s_scm_gr_p
3143 scm_gr_p (SCM x
, SCM y
)
3145 if (!SCM_NUMBERP (x
))
3146 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3147 else if (!SCM_NUMBERP (y
))
3148 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3150 return scm_less_p (y
, x
);
3155 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3156 /* "Return @code{#t} if the list of parameters is monotonically\n"
3159 #define FUNC_NAME s_scm_leq_p
3161 scm_leq_p (SCM x
, SCM y
)
3163 if (!SCM_NUMBERP (x
))
3164 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3165 else if (!SCM_NUMBERP (y
))
3166 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3168 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3173 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3174 /* "Return @code{#t} if the list of parameters is monotonically\n"
3177 #define FUNC_NAME s_scm_geq_p
3179 scm_geq_p (SCM x
, SCM y
)
3181 if (!SCM_NUMBERP (x
))
3182 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3183 else if (!SCM_NUMBERP (y
))
3184 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3186 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3191 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3192 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3198 if (SCM_INUMP (z
)) {
3199 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3200 } else if (SCM_BIGP (z
)) {
3202 } else if (SCM_REALP (z
)) {
3203 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3204 } else if (SCM_COMPLEXP (z
)) {
3205 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3206 && SCM_COMPLEX_IMAG (z
) == 0.0);
3208 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3213 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3214 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3218 scm_positive_p (SCM x
)
3220 if (SCM_INUMP (x
)) {
3221 return SCM_BOOL (SCM_INUM (x
) > 0);
3222 } else if (SCM_BIGP (x
)) {
3223 return SCM_BOOL (!SCM_BIGSIGN (x
));
3224 } else if (SCM_REALP (x
)) {
3225 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3227 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3232 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3233 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3237 scm_negative_p (SCM x
)
3239 if (SCM_INUMP (x
)) {
3240 return SCM_BOOL (SCM_INUM (x
) < 0);
3241 } else if (SCM_BIGP (x
)) {
3242 return SCM_BOOL (SCM_BIGSIGN (x
));
3243 } else if (SCM_REALP (x
)) {
3244 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3246 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3251 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3252 /* "Return the maximum of all parameter values."
3255 scm_max (SCM x
, SCM y
)
3257 if (SCM_UNBNDP (y
)) {
3258 if (SCM_UNBNDP (x
)) {
3259 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
3260 } else if (SCM_NUMBERP (x
)) {
3263 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3267 if (SCM_INUMP (x
)) {
3268 long xx
= SCM_INUM (x
);
3269 if (SCM_INUMP (y
)) {
3270 long yy
= SCM_INUM (y
);
3271 return (xx
< yy
) ? y
: x
;
3272 } else if (SCM_BIGP (y
)) {
3273 return SCM_BIGSIGN (y
) ? x
: y
;
3274 } else if (SCM_REALP (y
)) {
3276 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3278 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3280 } else if (SCM_BIGP (x
)) {
3281 if (SCM_INUMP (y
)) {
3282 return SCM_BIGSIGN (x
) ? y
: x
;
3283 } else if (SCM_BIGP (y
)) {
3284 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3285 } else if (SCM_REALP (y
)) {
3286 double z
= scm_big2dbl (x
);
3287 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3289 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3291 } else if (SCM_REALP (x
)) {
3292 if (SCM_INUMP (y
)) {
3293 double z
= SCM_INUM (y
);
3294 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3295 } else if (SCM_BIGP (y
)) {
3296 double z
= scm_big2dbl (y
);
3297 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3298 } else if (SCM_REALP (y
)) {
3299 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? y
: x
;
3301 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3304 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3309 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3310 /* "Return the minium of all parameter values."
3313 scm_min (SCM x
, SCM y
)
3315 if (SCM_UNBNDP (y
)) {
3316 if (SCM_UNBNDP (x
)) {
3317 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
3318 } else if (SCM_NUMBERP (x
)) {
3321 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3325 if (SCM_INUMP (x
)) {
3326 long xx
= SCM_INUM (x
);
3327 if (SCM_INUMP (y
)) {
3328 long yy
= SCM_INUM (y
);
3329 return (xx
< yy
) ? x
: y
;
3330 } else if (SCM_BIGP (y
)) {
3331 return SCM_BIGSIGN (y
) ? y
: x
;
3332 } else if (SCM_REALP (y
)) {
3334 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3336 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3338 } else if (SCM_BIGP (x
)) {
3339 if (SCM_INUMP (y
)) {
3340 return SCM_BIGSIGN (x
) ? x
: y
;
3341 } else if (SCM_BIGP (y
)) {
3342 return (-1 == scm_bigcomp (x
, y
)) ? y
: x
;
3343 } else if (SCM_REALP (y
)) {
3344 double z
= scm_big2dbl (x
);
3345 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3347 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3349 } else if (SCM_REALP (x
)) {
3350 if (SCM_INUMP (y
)) {
3351 double z
= SCM_INUM (y
);
3352 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3353 } else if (SCM_BIGP (y
)) {
3354 double z
= scm_big2dbl (y
);
3355 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3356 } else if (SCM_REALP (y
)) {
3357 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? x
: y
;
3359 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3362 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3367 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3368 /* "Return the sum of all parameter values. Return 0 if called without\n"
3372 scm_sum (SCM x
, SCM y
)
3374 if (SCM_UNBNDP (y
)) {
3375 if (SCM_UNBNDP (x
)) {
3377 } else if (SCM_NUMBERP (x
)) {
3380 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3384 if (SCM_INUMP (x
)) {
3385 long int xx
= SCM_INUM (x
);
3386 if (SCM_INUMP (y
)) {
3387 long int yy
= SCM_INUM (y
);
3388 long int z
= xx
+ yy
;
3389 if (SCM_FIXABLE (z
)) {
3390 return SCM_MAKINUM (z
);
3393 return scm_long2big (z
);
3394 #else /* SCM_BIGDIG */
3395 return scm_make_real ((double) z
);
3396 #endif /* SCM_BIGDIG */
3398 } else if (SCM_BIGP (y
)) {
3401 long int xx
= SCM_INUM (x
);
3402 #ifndef SCM_DIGSTOOBIG
3403 long z
= scm_pseudolong (xx
);
3404 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3405 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3406 #else /* SCM_DIGSTOOBIG */
3407 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3408 scm_longdigs (xx
, zdigs
);
3409 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3410 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3411 #endif /* SCM_DIGSTOOBIG */
3413 } else if (SCM_REALP (y
)) {
3414 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3415 } else if (SCM_COMPLEXP (y
)) {
3416 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3417 SCM_COMPLEX_IMAG (y
));
3419 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3421 } else if (SCM_BIGP (x
)) {
3422 if (SCM_INUMP (y
)) {
3425 } else if (SCM_BIGP (y
)) {
3426 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
)) {
3429 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3430 SCM_BIGSIGN (x
), y
, 0);
3431 } else if (SCM_REALP (y
)) {
3432 return scm_make_real (scm_big2dbl (x
) + SCM_REAL_VALUE (y
));
3433 } else if (SCM_COMPLEXP (y
)) {
3434 return scm_make_complex (scm_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3435 SCM_COMPLEX_IMAG (y
));
3437 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3439 } else if (SCM_REALP (x
)) {
3440 if (SCM_INUMP (y
)) {
3441 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3442 } else if (SCM_BIGP (y
)) {
3443 return scm_make_real (SCM_REAL_VALUE (x
) + scm_big2dbl (y
));
3444 } else if (SCM_REALP (y
)) {
3445 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3446 } else if (SCM_COMPLEXP (y
)) {
3447 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3448 SCM_COMPLEX_IMAG (y
));
3450 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3452 } else if (SCM_COMPLEXP (x
)) {
3453 if (SCM_INUMP (y
)) {
3454 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3455 SCM_COMPLEX_IMAG (x
));
3456 } else if (SCM_BIGP (y
)) {
3457 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_big2dbl (y
),
3458 SCM_COMPLEX_IMAG (x
));
3459 } else if (SCM_REALP (y
)) {
3460 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3461 SCM_COMPLEX_IMAG (x
));
3462 } else if (SCM_COMPLEXP (y
)) {
3463 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3464 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3466 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3469 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3474 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3475 /* "If called without arguments, 0 is returned. Otherwise the sum of\n"
3476 * "all but the first argument are subtracted from the first\n"
3479 #define FUNC_NAME s_difference
3481 scm_difference (SCM x
, SCM y
)
3483 if (SCM_UNBNDP (y
)) {
3484 if (SCM_UNBNDP (x
)) {
3485 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3486 } else if (SCM_INUMP (x
)) {
3487 long xx
= -SCM_INUM (x
);
3488 if (SCM_FIXABLE (xx
)) {
3489 return SCM_MAKINUM (xx
);
3492 return scm_long2big (xx
);
3494 return scm_make_real ((double) xx
);
3497 } else if (SCM_BIGP (x
)) {
3498 SCM z
= scm_copybig (x
, !SCM_BIGSIGN (x
));
3499 unsigned int digs
= SCM_NUMDIGS (z
);
3500 unsigned int size
= digs
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
;
3501 return size
<= sizeof (SCM
) ? scm_big2inum (z
, digs
) : z
;
3502 } else if (SCM_REALP (x
)) {
3503 return scm_make_real (-SCM_REAL_VALUE (x
));
3504 } else if (SCM_COMPLEXP (x
)) {
3505 return scm_make_complex (-SCM_COMPLEX_REAL (x
), -SCM_COMPLEX_IMAG (x
));
3507 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3511 if (SCM_INUMP (x
)) {
3512 long int xx
= SCM_INUM (x
);
3513 if (SCM_INUMP (y
)) {
3514 long int yy
= SCM_INUM (y
);
3515 long int z
= xx
- yy
;
3516 if (SCM_FIXABLE (z
)) {
3517 return SCM_MAKINUM (z
);
3520 return scm_long2big (z
);
3522 return scm_make_real ((double) z
);
3525 } else if (SCM_BIGP (y
)) {
3526 #ifndef SCM_DIGSTOOBIG
3527 long z
= scm_pseudolong (xx
);
3528 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3529 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3531 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3532 scm_longdigs (xx
, zdigs
);
3533 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3534 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3536 } else if (SCM_REALP (y
)) {
3537 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
3538 } else if (SCM_COMPLEXP (y
)) {
3539 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
3540 -SCM_COMPLEX_IMAG (y
));
3542 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3544 } else if (SCM_BIGP (x
)) {
3545 if (SCM_INUMP (y
)) {
3546 long int yy
= SCM_INUM (y
);
3547 #ifndef SCM_DIGSTOOBIG
3548 long z
= scm_pseudolong (yy
);
3549 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3550 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3552 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3553 scm_longdigs (yy
, zdigs
);
3554 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3555 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3557 } else if (SCM_BIGP (y
)) {
3558 return (SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3559 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3560 SCM_BIGSIGN (x
), y
, SCM_BIGSIGNFLAG
)
3561 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3562 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
, x
, 0);
3563 } else if (SCM_REALP (y
)) {
3564 return scm_make_real (scm_big2dbl (x
) - SCM_REAL_VALUE (y
));
3565 } else if (SCM_COMPLEXP (y
)) {
3566 return scm_make_complex (scm_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3567 - SCM_COMPLEX_IMAG (y
));
3569 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3571 } else if (SCM_REALP (x
)) {
3572 if (SCM_INUMP (y
)) {
3573 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
3574 } else if (SCM_BIGP (y
)) {
3575 return scm_make_real (SCM_REAL_VALUE (x
) - scm_big2dbl (y
));
3576 } else if (SCM_REALP (y
)) {
3577 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3578 } else if (SCM_COMPLEXP (y
)) {
3579 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3580 -SCM_COMPLEX_IMAG (y
));
3582 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3584 } else if (SCM_COMPLEXP (x
)) {
3585 if (SCM_INUMP (y
)) {
3586 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
3587 SCM_COMPLEX_IMAG (x
));
3588 } else if (SCM_BIGP (y
)) {
3589 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_big2dbl (y
),
3590 SCM_COMPLEX_IMAG (x
));
3591 } else if (SCM_REALP (y
)) {
3592 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3593 SCM_COMPLEX_IMAG (x
));
3594 } else if (SCM_COMPLEXP (y
)) {
3595 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3596 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3598 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3601 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3606 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3607 /* "Return the product of all arguments. If called without arguments,\n"
3611 scm_product (SCM x
, SCM y
)
3613 if (SCM_UNBNDP (y
)) {
3614 if (SCM_UNBNDP (x
)) {
3615 return SCM_MAKINUM (1L);
3616 } else if (SCM_NUMBERP (x
)) {
3619 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3623 if (SCM_INUMP (x
)) {
3631 } else if (xx
== 1) {
3635 if (SCM_INUMP (y
)) {
3636 long yy
= SCM_INUM (y
);
3638 SCM k
= SCM_MAKINUM (kk
);
3639 if (kk
!= SCM_INUM (k
) || kk
/ xx
!= yy
) {
3641 int sgn
= (xx
< 0) ^ (yy
< 0);
3642 #ifndef SCM_DIGSTOOBIG
3643 long i
= scm_pseudolong (xx
);
3644 long j
= scm_pseudolong (yy
);
3645 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3646 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3647 #else /* SCM_DIGSTOOBIG */
3648 SCM_BIGDIG xdigs
[SCM_DIGSPERLONG
];
3649 SCM_BIGDIG ydigs
[SCM_DIGSPERLONG
];
3650 scm_longdigs (xx
, xdigs
);
3651 scm_longdigs (yy
, ydigs
);
3652 return scm_mulbig (xdigs
, SCM_DIGSPERLONG
,
3653 ydigs
, SCM_DIGSPERLONG
,
3657 return scm_make_real (((double) xx
) * ((double) yy
));
3662 } else if (SCM_BIGP (y
)) {
3663 #ifndef SCM_DIGSTOOBIG
3664 long z
= scm_pseudolong (xx
);
3665 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3666 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3667 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3669 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3670 scm_longdigs (xx
, zdigs
);
3671 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3672 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3673 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3675 } else if (SCM_REALP (y
)) {
3676 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3677 } else if (SCM_COMPLEXP (y
)) {
3678 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3679 xx
* SCM_COMPLEX_IMAG (y
));
3681 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3683 } else if (SCM_BIGP (x
)) {
3684 if (SCM_INUMP (y
)) {
3687 } else if (SCM_BIGP (y
)) {
3688 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3689 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3690 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3691 } else if (SCM_REALP (y
)) {
3692 return scm_make_real (scm_big2dbl (x
) * SCM_REAL_VALUE (y
));
3693 } else if (SCM_COMPLEXP (y
)) {
3694 double z
= scm_big2dbl (x
);
3695 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3696 z
* SCM_COMPLEX_IMAG (y
));
3698 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3700 } else if (SCM_REALP (x
)) {
3701 if (SCM_INUMP (y
)) {
3702 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3703 } else if (SCM_BIGP (y
)) {
3704 return scm_make_real (scm_big2dbl (y
) * SCM_REAL_VALUE (x
));
3705 } else if (SCM_REALP (y
)) {
3706 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
3707 } else if (SCM_COMPLEXP (y
)) {
3708 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
3709 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3711 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3713 } else if (SCM_COMPLEXP (x
)) {
3714 if (SCM_INUMP (y
)) {
3715 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3716 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3717 } else if (SCM_BIGP (y
)) {
3718 double z
= scm_big2dbl (y
);
3719 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
3720 z
* SCM_COMPLEX_IMAG (x
));
3721 } else if (SCM_REALP (y
)) {
3722 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3723 SCM_REAL_VALUE (y
) * 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
),
3727 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3728 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3730 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3733 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3739 scm_num2dbl (SCM a
, const char *why
)
3740 #define FUNC_NAME why
3742 if (SCM_INUMP (a
)) {
3743 return (double) SCM_INUM (a
);
3744 } else if (SCM_BIGP (a
)) {
3745 return scm_big2dbl (a
);
3746 } else if (SCM_REALP (a
)) {
3747 return (SCM_REAL_VALUE (a
));
3749 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3755 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3756 /* "Divide the first argument by the product of the remaining arguments."
3758 #define FUNC_NAME s_divide
3760 scm_divide (SCM x
, SCM y
)
3764 if (SCM_UNBNDP (y
)) {
3765 if (SCM_UNBNDP (x
)) {
3766 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
3767 } else if (SCM_INUMP (x
)) {
3768 if (SCM_EQ_P (x
, SCM_MAKINUM (1L)) || SCM_EQ_P (x
, SCM_MAKINUM (-1L))) {
3771 return scm_make_real (1.0 / (double) SCM_INUM (x
));
3773 } else if (SCM_BIGP (x
)) {
3774 return scm_make_real (1.0 / scm_big2dbl (x
));
3775 } else if (SCM_REALP (x
)) {
3776 return scm_make_real (1.0 / SCM_REAL_VALUE (x
));
3777 } else if (SCM_COMPLEXP (x
)) {
3778 double r
= SCM_COMPLEX_REAL (x
);
3779 double i
= SCM_COMPLEX_IMAG (x
);
3780 double d
= r
* r
+ i
* i
;
3781 return scm_make_complex (r
/ d
, -i
/ d
);
3783 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3787 if (SCM_INUMP (x
)) {
3788 long xx
= SCM_INUM (x
);
3789 if (SCM_INUMP (y
)) {
3790 long yy
= SCM_INUM (y
);
3792 scm_num_overflow (s_divide
);
3793 } else if (xx
% yy
!= 0) {
3794 return scm_make_real ((double) xx
/ (double) yy
);
3797 if (SCM_FIXABLE (z
)) {
3798 return SCM_MAKINUM (z
);
3801 return scm_long2big (z
);
3803 return scm_make_real ((double) xx
/ (double) yy
);
3807 } else if (SCM_BIGP (y
)) {
3808 return scm_make_real ((double) xx
/ scm_big2dbl (y
));
3809 } else if (SCM_REALP (y
)) {
3810 return scm_make_real ((double) xx
/ SCM_REAL_VALUE (y
));
3811 } else if (SCM_COMPLEXP (y
)) {
3813 complex_div
: /* y _must_ be a complex number */
3815 double r
= SCM_COMPLEX_REAL (y
);
3816 double i
= SCM_COMPLEX_IMAG (y
);
3817 double d
= r
* r
+ i
* i
;
3818 return scm_make_complex ((a
* r
) / d
, (-a
* i
) / d
);
3821 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3823 } else if (SCM_BIGP (x
)) {
3824 if (SCM_INUMP (y
)) {
3825 long int yy
= SCM_INUM (y
);
3827 scm_num_overflow (s_divide
);
3828 } else if (yy
== 1) {
3831 long z
= yy
< 0 ? -yy
: yy
;
3832 if (z
< SCM_BIGRAD
) {
3833 SCM w
= scm_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
3834 return scm_divbigdig (SCM_BDIGITS (w
), SCM_NUMDIGS (w
),
3836 ? scm_make_real (scm_big2dbl (x
) / (double) yy
)
3840 #ifndef SCM_DIGSTOOBIG
3841 z
= scm_pseudolong (z
);
3842 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3843 (SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3844 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3846 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3847 scm_longdigs (z
, zdigs
);
3848 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3849 zdigs
, SCM_DIGSPERLONG
,
3850 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3852 return (!SCM_UNBNDP (w
))
3854 : scm_make_real (scm_big2dbl (x
) / (double) yy
);
3857 } else if (SCM_BIGP (y
)) {
3858 SCM w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3859 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3860 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 3);
3861 return (!SCM_UNBNDP (w
))
3863 : scm_make_real (scm_big2dbl (x
) / scm_big2dbl (y
));
3864 } else if (SCM_REALP (y
)) {
3865 return scm_make_real (scm_big2dbl (x
) / SCM_REAL_VALUE (y
));
3866 } else if (SCM_COMPLEXP (y
)) {
3867 a
= scm_big2dbl (x
);
3870 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3872 } else if (SCM_REALP (x
)) {
3873 double rx
= SCM_REAL_VALUE (x
);
3874 if (SCM_INUMP (y
)) {
3875 return scm_make_real (rx
/ (double) SCM_INUM (y
));
3876 } else if (SCM_BIGP (y
)) {
3877 return scm_make_real (rx
/ scm_big2dbl (y
));
3878 } else if (SCM_REALP (y
)) {
3879 return scm_make_real (rx
/ SCM_REAL_VALUE (y
));
3880 } else if (SCM_COMPLEXP (y
)) {
3884 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3886 } else if (SCM_COMPLEXP (x
)) {
3887 double rx
= SCM_COMPLEX_REAL (x
);
3888 double ix
= SCM_COMPLEX_IMAG (x
);
3889 if (SCM_INUMP (y
)) {
3890 double d
= SCM_INUM (y
);
3891 return scm_make_complex (rx
/ d
, ix
/ d
);
3892 } else if (SCM_BIGP (y
)) {
3893 double d
= scm_big2dbl (y
);
3894 return scm_make_complex (rx
/ d
, ix
/ d
);
3895 } else if (SCM_REALP (y
)) {
3896 double d
= SCM_REAL_VALUE (y
);
3897 return scm_make_complex (rx
/ d
, ix
/ d
);
3898 } else if (SCM_COMPLEXP (y
)) {
3899 double ry
= SCM_COMPLEX_REAL (y
);
3900 double iy
= SCM_COMPLEX_IMAG (y
);
3901 double d
= ry
* ry
+ iy
* iy
;
3902 return scm_make_complex ((rx
* ry
+ ix
* iy
) / d
,
3903 (ix
* ry
- rx
* iy
) / d
);
3905 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3908 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
3913 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
3914 /* "Return the inverse hyperbolic sine of @var{x}."
3917 scm_asinh (double x
)
3919 return log (x
+ sqrt (x
* x
+ 1));
3925 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
3926 /* "Return the inverse hyperbolic cosine of @var{x}."
3929 scm_acosh (double x
)
3931 return log (x
+ sqrt (x
* x
- 1));
3937 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
3938 /* "Return the inverse hyperbolic tangent of @var{x}."
3941 scm_atanh (double x
)
3943 return 0.5 * log ((1 + x
) / (1 - x
));
3949 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
3950 /* "Round the inexact number @var{x} towards zero."
3953 scm_truncate (double x
)
3962 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
3963 /* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
3964 * "numbers, round towards even."
3967 scm_round (double x
)
3969 double plus_half
= x
+ 0.5;
3970 double result
= floor (plus_half
);
3971 /* Adjust so that the scm_round is towards even. */
3972 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
3973 ? result
- 1 : result
;
3978 SCM_GPROC1 (s_exact_to_inexact
, "exact->inexact", scm_tc7_cxr
, (SCM (*)()) scm_exact_to_inexact
, g_exact_to_inexact
);
3979 /* Convert the number @var{x} to its inexact representation.\n"
3982 scm_exact_to_inexact (double z
)
3988 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
3989 /* "Round the number @var{x} towards minus infinity."
3991 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
3992 /* "Round the number @var{x} towards infinity."
3994 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
3995 /* "Return the square root of the real number @var{x}."
3997 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
3998 /* "Return the absolute value of the real number @var{x}."
4000 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
4001 /* "Return the @var{x}th power of e."
4003 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
4004 /* "Return the natural logarithm of the real number @var{x}."
4006 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
4007 /* "Return the sine of the real number @var{x}."
4009 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
4010 /* "Return the cosine of the real number @var{x}."
4012 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
4013 /* "Return the tangent of the real number @var{x}."
4015 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
4016 /* "Return the arc sine of the real number @var{x}."
4018 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
4019 /* "Return the arc cosine of the real number @var{x}."
4021 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
4022 /* "Return the arc tangent of the real number @var{x}."
4024 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
4025 /* "Return the hyperbolic sine of the real number @var{x}."
4027 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
4028 /* "Return the hyperbolic cosine of the real number @var{x}."
4030 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
4031 /* "Return the hyperbolic tangent of the real number @var{x}."
4039 static void scm_two_doubles (SCM x
,
4041 const char *sstring
,
4045 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
4047 if (SCM_INUMP (x
)) {
4048 xy
->x
= SCM_INUM (x
);
4049 } else if (SCM_BIGP (x
)) {
4050 xy
->x
= scm_big2dbl (x
);
4051 } else if (SCM_REALP (x
)) {
4052 xy
->x
= SCM_REAL_VALUE (x
);
4054 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
4057 if (SCM_INUMP (y
)) {
4058 xy
->y
= SCM_INUM (y
);
4059 } else if (SCM_BIGP (y
)) {
4060 xy
->y
= scm_big2dbl (y
);
4061 } else if (SCM_REALP (y
)) {
4062 xy
->y
= SCM_REAL_VALUE (y
);
4064 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
4069 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
4071 "Return @var{x} raised to the power of @var{y}. This\n"
4072 "procedure does not accept complex arguments.")
4073 #define FUNC_NAME s_scm_sys_expt
4076 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4077 return scm_make_real (pow (xy
.x
, xy
.y
));
4082 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4084 "Return the arc tangent of the two arguments @var{x} and\n"
4085 "@var{y}. This is similar to calculating the arc tangent of\n"
4086 "@var{x} / @var{y}, except that the signs of both arguments\n"
4087 "are used to determine the quadrant of the result. This\n"
4088 "procedure does not accept complex arguments.")
4089 #define FUNC_NAME s_scm_sys_atan2
4092 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4093 return scm_make_real (atan2 (xy
.x
, xy
.y
));
4098 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4099 (SCM real
, SCM imaginary
),
4100 "Return a complex number constructed of the given @var{real} and\n"
4101 "@var{imaginary} parts.")
4102 #define FUNC_NAME s_scm_make_rectangular
4105 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
4106 return scm_make_complex (xy
.x
, xy
.y
);
4112 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4114 "Return the complex number @var{x} * e^(i * @var{y}).")
4115 #define FUNC_NAME s_scm_make_polar
4118 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4119 return scm_make_complex (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
4124 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4125 /* "Return the real part of the number @var{z}."
4128 scm_real_part (SCM z
)
4130 if (SCM_INUMP (z
)) {
4132 } else if (SCM_BIGP (z
)) {
4134 } else if (SCM_REALP (z
)) {
4136 } else if (SCM_COMPLEXP (z
)) {
4137 return scm_make_real (SCM_COMPLEX_REAL (z
));
4139 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4144 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4145 /* "Return the imaginary part of the number @var{z}."
4148 scm_imag_part (SCM z
)
4150 if (SCM_INUMP (z
)) {
4152 } else if (SCM_BIGP (z
)) {
4154 } else if (SCM_REALP (z
)) {
4156 } else if (SCM_COMPLEXP (z
)) {
4157 return scm_make_real (SCM_COMPLEX_IMAG (z
));
4159 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4164 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4165 /* "Return the magnitude of the number @var{z}. This is the same as\n"
4166 * "@code{abs} for real arguments, but also allows complex numbers."
4169 scm_magnitude (SCM z
)
4171 if (SCM_INUMP (z
)) {
4172 long int zz
= SCM_INUM (z
);
4175 } else if (SCM_POSFIXABLE (-zz
)) {
4176 return SCM_MAKINUM (-zz
);
4179 return scm_long2big (-zz
);
4181 scm_num_overflow (s_magnitude
);
4184 } else if (SCM_BIGP (z
)) {
4185 if (!SCM_BIGSIGN (z
)) {
4188 return scm_copybig (z
, 0);
4190 } else if (SCM_REALP (z
)) {
4191 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
4192 } else if (SCM_COMPLEXP (z
)) {
4193 double r
= SCM_COMPLEX_REAL (z
);
4194 double i
= SCM_COMPLEX_IMAG (z
);
4195 return scm_make_real (sqrt (i
* i
+ r
* r
));
4197 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4202 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
4203 /* "Return the angle of the complex number @var{z}."
4208 if (SCM_INUMP (z
)) {
4209 if (SCM_INUM (z
) >= 0) {
4210 return scm_make_real (atan2 (0.0, 1.0));
4212 return scm_make_real (atan2 (0.0, -1.0));
4214 } else if (SCM_BIGP (z
)) {
4215 if (SCM_BIGSIGN (z
)) {
4216 return scm_make_real (atan2 (0.0, -1.0));
4218 return scm_make_real (atan2 (0.0, 1.0));
4220 } else if (SCM_REALP (z
)) {
4221 return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z
)));
4222 } else if (SCM_COMPLEXP (z
)) {
4223 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
4225 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
4230 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4232 "Return an exact number that is numerically closest to @var{z}.")
4233 #define FUNC_NAME s_scm_inexact_to_exact
4235 if (SCM_INUMP (z
)) {
4237 } else if (SCM_BIGP (z
)) {
4239 } else if (SCM_REALP (z
)) {
4240 double u
= floor (SCM_REAL_VALUE (z
) + 0.5);
4242 if (SCM_FIXABLE (lu
)) {
4243 return SCM_MAKINUM (lu
);
4245 } else if (isfinite (u
)) {
4246 return scm_dbl2big (u
);
4249 scm_num_overflow (s_scm_inexact_to_exact
);
4252 SCM_WRONG_TYPE_ARG (1, z
);
4259 /* d must be integer */
4262 scm_dbl2big (double d
)
4268 double u
= (d
< 0) ? -d
: d
;
4269 while (0 != floor (u
))
4274 ans
= scm_mkbig (i
, d
< 0);
4275 digits
= SCM_BDIGITS (ans
);
4283 #ifndef SCM_RECKLESS
4285 scm_num_overflow ("dbl2big");
4296 scm_sizet i
= SCM_NUMDIGS (b
);
4297 SCM_BIGDIG
*digits
= SCM_BDIGITS (b
);
4299 ans
= digits
[i
] + SCM_BIGRAD
* ans
;
4300 if (SCM_BIGSIGN (b
))
4308 scm_long2num (long sl
)
4310 if (!SCM_FIXABLE (sl
))
4313 return scm_long2big (sl
);
4315 return scm_make_real ((double) sl
);
4318 return SCM_MAKINUM (sl
);
4322 #ifdef HAVE_LONG_LONGS
4325 scm_long_long2num (long_long sl
)
4327 if (!SCM_FIXABLE (sl
))
4330 return scm_long_long2big (sl
);
4332 return scm_make_real ((double) sl
);
4337 /* we know that sl fits into an inum */
4338 return SCM_MAKINUM ((scm_bits_t
) sl
);
4342 #endif /* HAVE_LONG_LONGS */
4346 scm_ulong2num (unsigned long sl
)
4348 if (!SCM_POSFIXABLE (sl
))
4351 return scm_ulong2big (sl
);
4353 return scm_make_real ((double) sl
);
4356 return SCM_MAKINUM (sl
);
4361 scm_num2long (SCM num
, unsigned long int pos
, const char *s_caller
)
4363 if (SCM_INUMP (num
)) {
4364 return SCM_INUM (num
);
4365 } else if (SCM_BIGP (num
)) {
4367 /* can't use res directly in case num is -2^31. */
4368 unsigned long int pos_res
= 0;
4369 unsigned long int old_res
= 0;
4372 for (l
= SCM_NUMDIGS (num
); l
--;) {
4373 pos_res
= SCM_BIGUP (pos_res
) + SCM_BDIGITS (num
)[l
];
4374 if (pos_res
>= old_res
) {
4378 scm_out_of_range (s_caller
, num
);
4381 if (SCM_BIGSIGN (num
)) {
4386 scm_out_of_range (s_caller
, num
);
4393 scm_out_of_range (s_caller
, num
);
4396 } else if (SCM_REALP (num
)) {
4397 double u
= SCM_REAL_VALUE (num
);
4399 if ((double) res
== u
) {
4402 scm_out_of_range (s_caller
, num
);
4405 scm_wrong_type_arg (s_caller
, pos
, num
);
4410 #ifdef HAVE_LONG_LONGS
4412 #ifndef ULONG_LONG_MAX
4413 #define ULONG_LONG_MAX (~0ULL)
4417 scm_num2long_long (SCM num
, unsigned long int pos
, const char *s_caller
)
4419 if (SCM_INUMP (num
)) {
4420 return SCM_INUM (num
);
4421 } else if (SCM_BIGP (num
)) {
4423 /* can't use res directly in case num is -2^63. */
4424 unsigned long long int pos_res
= 0;
4427 for (l
= SCM_NUMDIGS (num
); l
--;) {
4428 if (pos_res
> SCM_BIGDN(ULONG_LONG_MAX
))
4429 scm_out_of_range (s_caller
, num
);
4430 pos_res
= SCM_LONGLONGBIGUP (pos_res
) + SCM_BDIGITS (num
)[l
];
4432 if (SCM_BIGSIGN (num
)) {
4437 scm_out_of_range (s_caller
, num
);
4444 scm_out_of_range (s_caller
, num
);
4447 } else if (SCM_REALP (num
)) {
4448 double u
= SCM_REAL_VALUE (num
);
4449 long long int res
= u
;
4450 if ((double) res
== u
) {
4453 scm_out_of_range (s_caller
, num
);
4456 scm_wrong_type_arg (s_caller
, pos
, num
);
4461 scm_num2ulong_long (SCM num
, unsigned long int pos
, const char *s_caller
)
4463 if (SCM_INUMP (num
))
4465 long long nnum
= SCM_INUM (num
);
4469 scm_out_of_range (s_caller
, num
);
4471 else if (SCM_BIGP (num
))
4473 unsigned long long res
= 0;
4476 if (SCM_BIGSIGN (num
))
4477 scm_out_of_range (s_caller
, num
);
4479 for (l
= SCM_NUMDIGS (num
); l
--;) {
4480 if (res
> SCM_BIGDN(ULONG_LONG_MAX
))
4481 scm_out_of_range (s_caller
, num
);
4482 res
= SCM_LONGLONGBIGUP (res
) + SCM_BDIGITS (num
)[l
];
4486 else if (SCM_REALP (num
))
4488 double u
= SCM_REAL_VALUE (num
);
4489 unsigned long long int res
= u
;
4490 if ((double) res
== u
)
4493 scm_out_of_range (s_caller
, num
);
4496 scm_wrong_type_arg (s_caller
, pos
, num
);
4499 #endif /* HAVE_LONG_LONGS */
4503 scm_num2ulong (SCM num
, unsigned long int pos
, const char *s_caller
)
4505 if (SCM_INUMP (num
)) {
4506 long nnum
= SCM_INUM (num
);
4510 scm_out_of_range (s_caller
, num
);
4512 } else if (SCM_BIGP (num
)) {
4513 unsigned long int res
= 0;
4516 if (SCM_BIGSIGN (num
))
4517 scm_out_of_range (s_caller
, num
);
4519 for (l
= SCM_NUMDIGS (num
); l
--;) {
4520 if (res
> SCM_BIGDN(ULONG_MAX
))
4521 scm_out_of_range (s_caller
, num
);
4522 res
= SCM_BIGUP (res
) + SCM_BDIGITS (num
)[l
];
4525 } else if (SCM_REALP (num
)) {
4526 double u
= SCM_REAL_VALUE (num
);
4527 unsigned long int res
= u
;
4528 if ((double) res
== u
) {
4531 scm_out_of_range (s_caller
, num
);
4534 scm_wrong_type_arg (s_caller
, pos
, num
);
4542 abs_most_negative_fixnum
= scm_long2big (- SCM_MOST_NEGATIVE_FIXNUM
);
4543 scm_permanent_object (abs_most_negative_fixnum
);
4545 /* It may be possible to tune the performance of some algorithms by using
4546 * the following constants to avoid the creation of bignums. Please, before
4547 * using these values, remember the two rules of program optimization:
4548 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
4549 scm_c_define ("most-positive-fixnum",
4550 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
4551 scm_c_define ("most-negative-fixnum",
4552 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
4554 scm_add_feature ("complex");
4555 scm_add_feature ("inexact");
4556 scm_flo0
= scm_make_real (0.0);
4558 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4560 { /* determine floating point precision */
4562 double fsum
= 1.0 + f
;
4563 while (fsum
!= 1.0) {
4564 if (++scm_dblprec
> 20) {
4571 scm_dblprec
= scm_dblprec
- 1;
4573 #endif /* DBL_DIG */
4574 #ifndef SCM_MAGIC_SNARFER
4575 #include "libguile/numbers.x"