1 /* Copyright (C) 1995,1996,1997,1998,1999,2000 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 */
49 #include "libguile/_scm.h"
50 #include "libguile/feature.h"
51 #include "libguile/ports.h"
52 #include "libguile/root.h"
53 #include "libguile/smob.h"
54 #include "libguile/strings.h"
56 #include "libguile/validate.h"
57 #include "libguile/numbers.h"
61 static SCM
scm_divbigbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
);
62 static SCM
scm_divbigint (SCM x
, long z
, int sgn
, int mode
);
65 #define DIGITS '0':case '1':case '2':case '3':case '4':\
66 case '5':case '6':case '7':case '8':case '9'
69 #define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0)
72 #if (SCM_DEBUG_DEPRECATED == 1) /* not defined in header yet? */
74 /* SCM_FLOBUFLEN is the maximum number of characters neccessary for the
75 * printed or scm_string representation of an inexact number.
77 #define SCM_FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
79 #endif /* SCM_DEBUG_DEPRECATED == 1 */
82 /* IS_INF tests its floating point number for infiniteness
83 Dirk:FIXME:: This test does not work if x == 0
86 #define IS_INF(x) ((x) == (x) / 2)
90 /* Return true if X is not infinite and is not a NaN
91 Dirk:FIXME:: Since IS_INF is broken, this test does not work if x == 0
94 #define isfinite(x) (!IS_INF (x) && (x) == (x))
99 static SCM abs_most_negative_fixnum
;
104 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
106 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
108 #define FUNC_NAME s_scm_exact_p
112 } else if (SCM_BIGP (x
)) {
121 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
123 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
125 #define FUNC_NAME s_scm_odd_p
128 return SCM_BOOL ((4 & SCM_UNPACK (n
)) != 0);
129 } else if (SCM_BIGP (n
)) {
130 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) != 0);
132 SCM_WRONG_TYPE_ARG (1, n
);
138 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
140 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
142 #define FUNC_NAME s_scm_even_p
145 return SCM_BOOL ((4 & SCM_UNPACK (n
)) == 0);
146 } else if (SCM_BIGP (n
)) {
147 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) == 0);
149 SCM_WRONG_TYPE_ARG (1, n
);
155 SCM_GPROC (s_abs
, "abs", 1, 0, 0, scm_abs
, g_abs
);
156 /* "Return the absolute value of @var{x}."
162 long int xx
= SCM_INUM (x
);
165 } else if (SCM_POSFIXABLE (-xx
)) {
166 return SCM_MAKINUM (-xx
);
169 return scm_long2big (-xx
);
171 scm_num_overflow (s_abs
);
174 } else if (SCM_BIGP (x
)) {
175 if (!SCM_BIGSIGN (x
)) {
178 return scm_copybig (x
, 0);
180 } else if (SCM_REALP (x
)) {
181 return scm_make_real (fabs (SCM_REAL_VALUE (x
)));
183 SCM_WTA_DISPATCH_1 (g_abs
, x
, 1, s_abs
);
188 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
189 /* "Return the quotient of the numbers @var{x} and @var{y}."
192 scm_quotient (SCM x
, SCM y
)
195 long xx
= SCM_INUM (x
);
197 long yy
= SCM_INUM (y
);
199 scm_num_overflow (s_quotient
);
202 if (SCM_FIXABLE (z
)) {
203 return SCM_MAKINUM (z
);
206 return scm_long2big (z
);
208 scm_num_overflow (s_quotient
);
212 } else if (SCM_BIGP (y
)) {
213 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
214 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
216 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
217 return SCM_MAKINUM (-1);
220 return SCM_MAKINUM (0);
222 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
224 } else if (SCM_BIGP (x
)) {
226 long yy
= SCM_INUM (y
);
228 scm_num_overflow (s_quotient
);
229 } else if (yy
== 1) {
232 long z
= yy
< 0 ? -yy
: yy
;
234 if (z
< SCM_BIGRAD
) {
235 SCM sw
= scm_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
236 scm_divbigdig (SCM_BDIGITS (sw
), SCM_NUMDIGS (sw
), (SCM_BIGDIG
) z
);
237 return scm_normbig (sw
);
239 #ifndef SCM_DIGSTOOBIG
240 long w
= scm_pseudolong (z
);
241 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
242 (SCM_BIGDIG
*) & w
, SCM_DIGSPERLONG
,
243 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
245 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
246 scm_longdigs (z
, zdigs
);
247 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
248 zdigs
, SCM_DIGSPERLONG
,
249 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
253 } else if (SCM_BIGP (y
)) {
254 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
255 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
256 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 2);
258 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
261 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
266 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
267 /* "Return the remainder of the numbers @var{x} and @var{y}.\n"
269 * "(remainder 13 4) @result{} 1\n"
270 * "(remainder -13 4) @result{} -1\n"
274 scm_remainder (SCM x
, SCM y
)
278 long yy
= SCM_INUM (y
);
280 scm_num_overflow (s_remainder
);
282 long z
= SCM_INUM (x
) % yy
;
283 return SCM_MAKINUM (z
);
285 } else if (SCM_BIGP (y
)) {
286 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
287 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
289 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
290 return SCM_MAKINUM (0);
295 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
297 } else if (SCM_BIGP (x
)) {
299 long yy
= SCM_INUM (y
);
301 scm_num_overflow (s_remainder
);
303 return scm_divbigint (x
, yy
, SCM_BIGSIGN (x
), 0);
305 } else if (SCM_BIGP (y
)) {
306 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
307 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
310 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
313 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
318 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
319 /* "Return the modulo of the numbers @var{x} and @var{y}.\n"
321 * "(modulo 13 4) @result{} 1\n"
322 * "(modulo -13 4) @result{} 3\n"
326 scm_modulo (SCM x
, SCM y
)
329 long xx
= SCM_INUM (x
);
331 long yy
= SCM_INUM (y
);
333 scm_num_overflow (s_modulo
);
336 return SCM_MAKINUM (((yy
< 0) ? (z
> 0) : (z
< 0)) ? z
+ yy
: z
);
338 } else if (SCM_BIGP (y
)) {
339 return (SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0)) ? scm_sum (x
, y
) : x
;
341 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
343 } else if (SCM_BIGP (x
)) {
345 long yy
= SCM_INUM (y
);
347 scm_num_overflow (s_modulo
);
349 return scm_divbigint (x
, yy
, yy
< 0,
350 (SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0)) ? 1 : 0);
352 } else if (SCM_BIGP (y
)) {
353 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
354 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
356 (SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
)) ? 1 : 0);
358 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
361 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
366 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
367 /* "Return the greatest common divisor of all arguments.\n"
368 * "If called without arguments, 0 is returned."
371 scm_gcd (SCM x
, SCM y
)
373 if (SCM_UNBNDP (y
)) {
374 if (SCM_UNBNDP (x
)) {
384 long xx
= SCM_INUM (x
);
385 long yy
= SCM_INUM (y
);
386 long u
= xx
< 0 ? -xx
: xx
;
387 long v
= yy
< 0 ? -yy
: yy
;
392 } else if (yy
== 0) {
398 /* Determine a common factor 2^k */
399 while (!(1 & (u
| v
))) {
405 /* Now, any factor 2^n can be eliminated */
425 if (SCM_POSFIXABLE (result
)) {
426 return SCM_MAKINUM (result
);
429 return scm_long2big (result
);
431 scm_num_overflow (s_gcd
);
434 } else if (SCM_BIGP (y
)) {
438 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
440 } else if (SCM_BIGP (x
)) {
443 x
= scm_copybig (x
, 0);
446 if (SCM_EQ_P (y
, SCM_INUM0
)) {
451 } else if (SCM_BIGP (y
)) {
453 y
= scm_copybig (y
, 0);
454 switch (scm_bigcomp (x
, y
))
459 SCM t
= scm_remainder (x
, y
);
465 y
= scm_remainder (y
, x
);
467 default: /* x == y */
470 /* instead of the switch, we could just
471 return scm_gcd (y, scm_modulo (x, y)); */
473 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
476 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
481 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
482 /* "Return the least common multiple of the arguments.\n"
483 * "If called without arguments, 1 is returned."
486 scm_lcm (SCM n1
, SCM n2
)
488 if (SCM_UNBNDP (n2
)) {
489 if (SCM_UNBNDP (n1
)) {
490 return SCM_MAKINUM (1L);
492 n2
= SCM_MAKINUM (1L);
497 SCM_GASSERT2 (SCM_INUMP (n1
), g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
498 SCM_GASSERT2 (SCM_INUMP (n2
), g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
500 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
501 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
502 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
503 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
507 SCM d
= scm_gcd (n1
, n2
);
508 if (SCM_EQ_P (d
, SCM_INUM0
)) {
511 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
518 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
520 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
524 /* Emulating 2's complement bignums with sign magnitude arithmetic:
529 + + + x (map digit:logand X Y)
530 + - + x (map digit:logand X (lognot (+ -1 Y)))
531 - + + y (map digit:logand (lognot (+ -1 X)) Y)
532 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
537 + + + (map digit:logior X Y)
538 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
539 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
540 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
545 + + + (map digit:logxor X Y)
546 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
547 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
548 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
553 + + (any digit:logand X Y)
554 + - (any digit:logand X (lognot (+ -1 Y)))
555 - + (any digit:logand (lognot (+ -1 X)) Y)
562 SCM
scm_copy_big_dec(SCM b
, int sign
);
563 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
);
564 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
565 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
566 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
);
567 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
569 SCM
scm_copy_big_dec(SCM b
, int sign
)
572 scm_sizet nx
= SCM_NUMDIGS(b
);
574 SCM ans
= scm_mkbig(nx
, sign
);
575 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
576 if SCM_BIGSIGN(b
) do {
578 if (num
< 0) {dst
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
579 else {dst
[i
] = SCM_BIGLO(num
); num
= 0;}
582 while (nx
--) dst
[nx
] = src
[nx
];
586 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
)
590 SCM z
= scm_mkbig(nx
, zsgn
);
591 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
594 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
595 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
597 else do zds
[i
] = x
[i
]; while (++i
< nx
);
601 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
602 /* Assumes nx <= SCM_NUMDIGS(bigy) */
603 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
606 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
607 SCM z
= scm_copy_big_dec (bigy
, xsgn
& SCM_BIGSIGN (bigy
));
608 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
612 if (num
< 0) {zds
[i
] |= num
+ SCM_BIGRAD
; num
= -1;}
613 else {zds
[i
] |= SCM_BIGLO(num
); num
= 0;}
615 /* ========= Need to increment zds now =========== */
619 zds
[i
++] = SCM_BIGLO(num
);
620 num
= SCM_BIGDN(num
);
623 scm_adjbig(z
, 1 + ny
); /* OOPS, overflowed into next digit. */
624 SCM_BDIGITS(z
)[ny
] = 1;
627 else do zds
[i
] = zds
[i
] | x
[i
]; while (++i
< nx
);
631 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
632 /* Assumes nx <= SCM_NUMDIGS(bigy) */
633 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
636 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
637 SCM z
= scm_copy_big_dec(bigy
, xsgn
^ SCM_BIGSIGN(bigy
));
638 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
641 if (num
< 0) {zds
[i
] ^= num
+ SCM_BIGRAD
; num
= -1;}
642 else {zds
[i
] ^= SCM_BIGLO(num
); num
= 0;}
645 zds
[i
] = zds
[i
] ^ x
[i
];
648 if (xsgn
^ SCM_BIGSIGN(bigy
)) {
649 /* ========= Need to increment zds now =========== */
653 zds
[i
++] = SCM_BIGLO(num
);
654 num
= SCM_BIGDN(num
);
655 if (!num
) return scm_normbig(z
);
658 return scm_normbig(z
);
661 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
)
662 /* Assumes nx <= SCM_NUMDIGS(bigy) */
663 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
664 /* return sign equals either 0 or SCM_BIGSIGNFLAG */
671 z
= scm_copy_smaller(x
, nx
, zsgn
);
672 x
= SCM_BDIGITS(bigy
);
673 xsgn
= SCM_BIGSIGN(bigy
);
675 else z
= scm_copy_big_dec(bigy
, zsgn
);
676 zds
= SCM_BDIGITS(z
);
681 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
682 else {zds
[i
] &= SCM_BIGLO(num
); num
= 0;}
684 else do zds
[i
] = zds
[i
] & ~x
[i
]; while (++i
< nx
);
685 /* ========= need to increment zds now =========== */
689 zds
[i
++] = SCM_BIGLO(num
);
690 num
= SCM_BIGDN(num
);
691 if (!num
) return scm_normbig(z
);
695 unsigned long int carry
= 1;
697 unsigned long int mask
= (SCM_BIGDIG
) ~x
[i
] + carry
;
698 zds
[i
] = zds
[i
] & (SCM_BIGDIG
) mask
;
699 carry
= (mask
>= SCM_BIGRAD
) ? 1 : 0;
701 } else do zds
[i
] = zds
[i
] & x
[i
]; while (++i
< nx
);
702 return scm_normbig(z
);
705 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
706 /* Assumes nx <= SCM_NUMDIGS(bigy) */
707 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
712 if (SCM_BIGSIGN(bigy
) & xsgn
) return SCM_BOOL_T
;
713 if (SCM_NUMDIGS(bigy
) != nx
&& xsgn
) return SCM_BOOL_T
;
714 y
= SCM_BDIGITS(bigy
);
719 if (y
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
723 if (y
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
727 else if SCM_BIGSIGN(bigy
)
731 if (x
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
735 if (x
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
740 do if (x
[i
] & y
[i
]) return SCM_BOOL_T
;
748 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
750 "Returns the integer which is the bit-wise AND of the two integer\n"
754 "(number->string (logand #b1100 #b1010) 2)\n"
755 " @result{} \"1000\"\n"
757 #define FUNC_NAME s_scm_logand
761 if (SCM_UNBNDP (n2
)) {
762 if (SCM_UNBNDP (n1
)) {
763 return SCM_MAKINUM (-1);
764 } else if (!SCM_NUMBERP (n1
)) {
765 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
767 } else if (SCM_NUMBERP (n1
)) {
770 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
778 if (SCM_INUMP (n1
)) {
780 if (SCM_INUMP (n2
)) {
781 long nn2
= SCM_INUM (n2
);
782 return SCM_MAKINUM (nn1
& nn2
);
783 } else if SCM_BIGP (n2
) {
786 # ifndef SCM_DIGSTOOBIG
787 long z
= scm_pseudolong (nn1
);
788 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
789 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
790 SCM_BIGSIGNFLAG
, n2
);
792 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
793 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
796 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
797 scm_longdigs (nn1
, zdigs
);
798 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
799 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
801 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
802 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
807 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
809 } else if (SCM_BIGP (n1
)) {
810 if (SCM_INUMP (n2
)) {
814 } else if (SCM_BIGP (n2
)) {
815 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
818 if ((SCM_BIGSIGN (n1
)) && SCM_BIGSIGN (n2
)) {
819 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
820 SCM_BIGSIGNFLAG
, n2
);
822 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
823 SCM_BIGSIGN (n1
), n2
, 0);
826 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
829 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
835 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
837 "Returns the integer which is the bit-wise OR of the two integer\n"
841 "(number->string (logior #b1100 #b1010) 2)\n"
842 " @result{} \"1110\"\n"
844 #define FUNC_NAME s_scm_logior
848 if (SCM_UNBNDP (n2
)) {
849 if (SCM_UNBNDP (n1
)) {
852 } else if (SCM_NUMBERP (n1
)) {
855 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
863 if (SCM_INUMP (n1
)) {
865 if (SCM_INUMP (n2
)) {
866 long nn2
= SCM_INUM (n2
);
867 return SCM_MAKINUM (nn1
| nn2
);
868 } else if (SCM_BIGP (n2
)) {
871 # ifndef SCM_DIGSTOOBIG
872 long z
= scm_pseudolong (nn1
);
873 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
874 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
875 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
877 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
878 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
881 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
882 scm_longdigs (nn1
, zdigs
);
883 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
884 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
,
885 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
887 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
888 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
893 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
895 } else if (SCM_BIGP (n1
)) {
896 if (SCM_INUMP (n2
)) {
900 } else if (SCM_BIGP (n2
)) {
901 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
904 if ((!SCM_BIGSIGN (n1
)) && !SCM_BIGSIGN (n2
)) {
905 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
906 SCM_BIGSIGN (n1
), n2
);
908 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
909 SCM_BIGSIGN (n1
), n2
, SCM_BIGSIGNFLAG
);
912 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
915 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
921 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
923 "Returns the integer which is the bit-wise XOR of the two integer\n"
927 "(number->string (logxor #b1100 #b1010) 2)\n"
928 " @result{} \"110\"\n"
930 #define FUNC_NAME s_scm_logxor
934 if (SCM_UNBNDP (n2
)) {
935 if (SCM_UNBNDP (n1
)) {
938 } else if (SCM_NUMBERP (n1
)) {
941 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
949 if (SCM_INUMP (n1
)) {
951 if (SCM_INUMP (n2
)) {
952 long nn2
= SCM_INUM (n2
);
953 return SCM_MAKINUM (nn1
^ nn2
);
954 } else if (SCM_BIGP (n2
)) {
957 # ifndef SCM_DIGSTOOBIG
958 long z
= scm_pseudolong (nn1
);
959 return scm_big_xor ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
960 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
962 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
963 scm_longdigs (nn1
, zdigs
);
964 return scm_big_xor (zdigs
, SCM_DIGSPERLONG
,
965 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
969 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
971 } else if (SCM_BIGP (n1
)) {
972 if (SCM_INUMP (n2
)) {
976 } else if (SCM_BIGP (n2
)) {
977 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {
980 return scm_big_xor (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
981 SCM_BIGSIGN (n1
), n2
);
983 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
986 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
992 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
995 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
996 "(logtest #b0100 #b1011) @result{} #f\n"
997 "(logtest #b0100 #b0111) @result{} #t\n"
999 #define FUNC_NAME s_scm_logtest
1003 if (SCM_INUMP (n1
)) {
1004 nn1
= SCM_INUM (n1
);
1005 if (SCM_INUMP (n2
)) {
1006 long nn2
= SCM_INUM (n2
);
1007 return SCM_BOOL (nn1
& nn2
);
1008 } else if (SCM_BIGP (n2
)) {
1011 # ifndef SCM_DIGSTOOBIG
1012 long z
= scm_pseudolong (nn1
);
1013 return scm_big_test ((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
1014 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
1016 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
1017 scm_longdigs (nn1
, zdigs
);
1018 return scm_big_test (zdigs
, SCM_DIGSPERLONG
,
1019 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
1023 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1025 } else if (SCM_BIGP (n1
)) {
1026 if (SCM_INUMP (n2
)) {
1028 nn1
= SCM_INUM (n1
);
1030 } else if (SCM_BIGP (n2
)) {
1031 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
1034 return scm_big_test (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
1035 SCM_BIGSIGN (n1
), n2
);
1037 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1040 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1046 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
1049 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1050 "(logbit? 0 #b1101) @result{} #t\n"
1051 "(logbit? 1 #b1101) @result{} #f\n"
1052 "(logbit? 2 #b1101) @result{} #t\n"
1053 "(logbit? 3 #b1101) @result{} #t\n"
1054 "(logbit? 4 #b1101) @result{} #f\n"
1056 #define FUNC_NAME s_scm_logbit_p
1058 unsigned long int iindex
;
1060 SCM_VALIDATE_INUM_MIN (SCM_ARG1
, index
, 0);
1061 iindex
= (unsigned long int) SCM_INUM (index
);
1063 if (SCM_INUMP (j
)) {
1064 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1065 } else if (SCM_BIGP (j
)) {
1066 if (SCM_NUMDIGS (j
) * SCM_BITSPERDIG
< iindex
) {
1068 } else if (SCM_BIGSIGN (j
)) {
1071 SCM_BIGDIG
* x
= SCM_BDIGITS (j
);
1072 scm_sizet nx
= iindex
/ SCM_BITSPERDIG
;
1076 return SCM_BOOL (((1L << (iindex
% SCM_BITSPERDIG
)) & num
) == 0);
1077 } else if (num
< 0) {
1084 return SCM_BOOL (SCM_BDIGITS (j
) [iindex
/ SCM_BITSPERDIG
]
1085 & (1L << (iindex
% SCM_BITSPERDIG
)));
1088 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1094 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1096 "Returns the integer which is the 2s-complement of the integer argument.\n\n"
1099 "(number->string (lognot #b10000000) 2)\n"
1100 " @result{} \"-10000001\"\n"
1101 "(number->string (lognot #b0) 2)\n"
1102 " @result{} \"-1\"\n"
1104 #define FUNC_NAME s_scm_lognot
1106 return scm_difference (SCM_MAKINUM (-1L), n
);
1110 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1112 "Returns @var{n} raised to the non-negative integer exponent @var{k}.\n\n"
1115 "(integer-expt 2 5)\n"
1117 "(integer-expt -3 3)\n"
1120 #define FUNC_NAME s_scm_integer_expt
1122 SCM acc
= SCM_MAKINUM (1L);
1125 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1127 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1128 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1130 SCM_VALIDATE_ULONG_COPY (2,k
,i2
);
1134 n
= scm_divide (n
, SCM_UNDEFINED
);
1141 return scm_product (acc
, n
);
1143 acc
= scm_product (acc
, n
);
1144 n
= scm_product (n
, n
);
1150 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1152 "The function ash performs an arithmetic shift left by @var{CNT}\n"
1153 "bits (or shift right, if @var{cnt} is negative).\n"
1154 "'Arithmetic' means, that the function does not guarantee to\n"
1155 "keep the bit structure of @var{n}, but rather guarantees that\n"
1156 "the result will always be rounded towards minus infinity.\n"
1157 "Therefore, the results of ash and a corresponding bitwise\n"
1158 "shift will differ if N is negative.\n\n"
1159 "Formally, the function returns an integer equivalent to\n"
1160 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n\n"
1163 "(number->string (ash #b1 3) 2)\n"
1164 " @result{} \"1000\"\n"
1165 "(number->string (ash #b1010 -1) 2)\n"
1166 " @result{} \"101\"\n"
1168 #define FUNC_NAME s_scm_ash
1173 SCM_VALIDATE_INUM (1, n
)
1175 SCM_VALIDATE_INUM (2, cnt
);
1177 bits_to_shift
= SCM_INUM (cnt
);
1179 if (bits_to_shift
< 0) {
1180 /* Shift right by abs(cnt) bits. This is realized as a division by
1181 div:=2^abs(cnt). However, to guarantee the floor rounding, negative
1182 values require some special treatment.
1184 SCM div
= scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift
));
1185 if (SCM_FALSEP (scm_negative_p (n
)))
1186 return scm_quotient (n
, div
);
1188 return scm_sum (SCM_MAKINUM (-1L),
1189 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1191 /* Shift left is done by multiplication with 2^CNT */
1192 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1194 if (bits_to_shift
< 0)
1195 /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */
1196 return SCM_MAKINUM (SCM_SRS (SCM_INUM (n
), -bits_to_shift
));
1198 /* Shift left, but make sure not to leave the range of inums */
1199 SCM res
= SCM_MAKINUM (SCM_INUM (n
) << cnt
);
1200 if (SCM_INUM (res
) >> cnt
!= SCM_INUM (n
))
1201 scm_num_overflow (FUNC_NAME
);
1209 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1210 (SCM n
, SCM start
, SCM end
),
1211 "Returns the integer composed of the @var{start} (inclusive) through\n"
1212 "@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes\n"
1213 "the 0-th bit in the result.@refill\n\n"
1216 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1217 " @result{} \"1010\"\n"
1218 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1219 " @result{} \"10110\"\n"
1221 #define FUNC_NAME s_scm_bit_extract
1223 unsigned long int istart
, iend
;
1224 SCM_VALIDATE_INUM_MIN_COPY (2,start
,0,istart
);
1225 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1226 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1228 if (SCM_INUMP (n
)) {
1229 long int in
= SCM_INUM (n
);
1230 unsigned long int bits
= iend
- istart
;
1232 if (in
< 0 && bits
>= SCM_FIXNUM_BIT
)
1234 /* Since we emulate two's complement encoded numbers, this special
1235 * case requires us to produce a result that has more bits than can be
1236 * stored in a fixnum. Thus, we fall back to the more general
1237 * algorithm that is used for bignums.
1242 if (istart
< SCM_FIXNUM_BIT
)
1245 if (bits
< SCM_FIXNUM_BIT
)
1246 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1247 else /* we know: in >= 0 */
1248 return SCM_MAKINUM (in
);
1252 return SCM_MAKINUM (-1L & ((1L << bits
) - 1));
1256 return SCM_MAKINUM (0);
1258 } else if (SCM_BIGP (n
)) {
1261 SCM num1
= SCM_MAKINUM (1L);
1262 SCM num2
= SCM_MAKINUM (2L);
1263 SCM bits
= SCM_MAKINUM (iend
- istart
);
1264 SCM mask
= scm_difference (scm_integer_expt (num2
, bits
), num1
);
1265 return scm_logand (mask
, scm_ash (n
, SCM_MAKINUM (-istart
)));
1268 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1274 static const char scm_logtab
[] = {
1275 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1278 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1280 "Returns the number of bits in integer @var{n}. If integer is positive,\n"
1281 "the 1-bits in its binary representation are counted. If negative, the\n"
1282 "0-bits in its two's-complement binary representation are counted. If 0,\n"
1283 "0 is returned.\n\n"
1286 "(logcount #b10101010)\n"
1293 #define FUNC_NAME s_scm_logcount
1295 if (SCM_INUMP (n
)) {
1296 unsigned long int c
= 0;
1297 long int nn
= SCM_INUM (n
);
1302 c
+= scm_logtab
[15 & nn
];
1305 return SCM_MAKINUM (c
);
1306 } else if (SCM_BIGP (n
)) {
1307 if (SCM_BIGSIGN (n
)) {
1308 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n
));
1310 unsigned long int c
= 0;
1311 scm_sizet i
= SCM_NUMDIGS (n
);
1312 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1315 for (d
= ds
[i
]; d
; d
>>= 4) {
1316 c
+= scm_logtab
[15 & d
];
1319 return SCM_MAKINUM (c
);
1322 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1328 static const char scm_ilentab
[] = {
1329 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1332 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1334 "Returns the number of bits neccessary to represent @var{n}.\n\n"
1337 "(integer-length #b10101010)\n"
1339 "(integer-length 0)\n"
1341 "(integer-length #b1111)\n"
1344 #define FUNC_NAME s_scm_integer_length
1346 if (SCM_INUMP (n
)) {
1347 unsigned long int c
= 0;
1349 long int nn
= SCM_INUM (n
);
1355 l
= scm_ilentab
[15 & nn
];
1358 return SCM_MAKINUM (c
- 4 + l
);
1359 } else if (SCM_BIGP (n
)) {
1360 if (SCM_BIGSIGN (n
)) {
1361 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n
));
1363 unsigned long int digs
= SCM_NUMDIGS (n
) - 1;
1364 unsigned long int c
= digs
* SCM_BITSPERDIG
;
1366 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1367 SCM_BIGDIG d
= ds
[digs
];
1370 l
= scm_ilentab
[15 & d
];
1373 return SCM_MAKINUM (c
- 4 + l
);
1376 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1383 static const char s_bignum
[] = "bignum";
1386 scm_mkbig (scm_sizet nlen
, int sign
)
1389 /* Cast to long int to avoid signed/unsigned comparison warnings. */
1390 if ((( ((long int) nlen
) << SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
)
1392 scm_memory_error (s_bignum
);
1396 SCM_SET_BIGNUM_BASE (v
, scm_must_malloc (nlen
* sizeof (SCM_BIGDIG
), s_bignum
));
1397 SCM_SETNUMDIGS (v
, nlen
, sign
);
1404 scm_big2inum (SCM b
, scm_sizet l
)
1406 unsigned long num
= 0;
1407 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1409 num
= SCM_BIGUP (num
) + tmp
[l
];
1410 if (!SCM_BIGSIGN (b
))
1412 if (SCM_POSFIXABLE (num
))
1413 return SCM_MAKINUM (num
);
1415 else if (num
<= -SCM_MOST_NEGATIVE_FIXNUM
)
1416 return SCM_MAKINUM (-num
);
1421 static const char s_adjbig
[] = "scm_adjbig";
1424 scm_adjbig (SCM b
, scm_sizet nlen
)
1426 scm_sizet nsiz
= nlen
;
1427 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1428 scm_memory_error (s_adjbig
);
1434 scm_must_realloc ((char *) SCM_BDIGITS (b
),
1435 (long) (SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
)),
1436 (long) (nsiz
* sizeof (SCM_BIGDIG
)), s_bignum
));
1438 SCM_SET_BIGNUM_BASE (b
, digits
);
1439 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1451 scm_sizet nlen
= SCM_NUMDIGS (b
);
1453 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1455 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1456 while (nlen
-- && !zds
[nlen
]);
1458 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1459 if (SCM_INUMP (b
= scm_big2inum (b
, (scm_sizet
) nlen
)))
1461 if (SCM_NUMDIGS (b
) == nlen
)
1463 return scm_adjbig (b
, (scm_sizet
) nlen
);
1469 scm_copybig (SCM b
, int sign
)
1471 scm_sizet i
= SCM_NUMDIGS (b
);
1472 SCM ans
= scm_mkbig (i
, sign
);
1473 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1482 scm_long2big (long n
)
1486 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, n
< 0);
1487 digits
= SCM_BDIGITS (ans
);
1490 while (i
< SCM_DIGSPERLONG
)
1492 digits
[i
++] = SCM_BIGLO (n
);
1493 n
= SCM_BIGDN ((unsigned long) n
);
1498 #ifdef HAVE_LONG_LONGS
1501 scm_long_long2big (long_long n
)
1511 if ((long long) tn
== n
)
1512 return scm_long2big (tn
);
1518 for (tn
= n
, n_digits
= 0;
1520 ++n_digits
, tn
= SCM_BIGDN ((ulong_long
) tn
))
1525 ans
= scm_mkbig (n_digits
, n
< 0);
1526 digits
= SCM_BDIGITS (ans
);
1529 while (i
< n_digits
)
1531 digits
[i
++] = SCM_BIGLO (n
);
1532 n
= SCM_BIGDN ((ulong_long
) n
);
1536 #endif /* HAVE_LONG_LONGS */
1540 scm_2ulong2big (unsigned long *np
)
1547 ans
= scm_mkbig (2 * SCM_DIGSPERLONG
, 0);
1548 digits
= SCM_BDIGITS (ans
);
1551 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1553 digits
[i
] = SCM_BIGLO (n
);
1554 n
= SCM_BIGDN ((unsigned long) n
);
1557 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1559 digits
[i
+ SCM_DIGSPERLONG
] = SCM_BIGLO (n
);
1560 n
= SCM_BIGDN ((unsigned long) n
);
1568 scm_ulong2big (unsigned long n
)
1572 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, 0);
1573 digits
= SCM_BDIGITS (ans
);
1574 while (i
< SCM_DIGSPERLONG
)
1576 digits
[i
++] = SCM_BIGLO (n
);
1585 scm_bigcomp (SCM x
, SCM y
)
1587 int xsign
= SCM_BIGSIGN (x
);
1588 int ysign
= SCM_BIGSIGN (y
);
1589 scm_sizet xlen
, ylen
;
1591 /* Look at the signs, first. */
1597 /* They're the same sign, so see which one has more digits. Note
1598 that, if they are negative, the longer number is the lesser. */
1599 ylen
= SCM_NUMDIGS (y
);
1600 xlen
= SCM_NUMDIGS (x
);
1602 return (xsign
) ? -1 : 1;
1604 return (xsign
) ? 1 : -1;
1606 /* They have the same number of digits, so find the most significant
1607 digit where they differ. */
1611 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1612 /* Make the discrimination based on the digit that differs. */
1613 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1615 : (xsign
? 1 : -1));
1618 /* The numbers are identical. */
1622 #ifndef SCM_DIGSTOOBIG
1626 scm_pseudolong (long x
)
1631 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1637 while (i
< SCM_DIGSPERLONG
)
1639 p
.bd
[i
++] = SCM_BIGLO (x
);
1642 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1650 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1655 while (i
< SCM_DIGSPERLONG
)
1657 digs
[i
++] = SCM_BIGLO (x
);
1666 scm_addbig (SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int sgny
)
1668 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1669 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1671 scm_sizet i
= 0, ny
= SCM_NUMDIGS (bigy
);
1672 SCM z
= scm_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1673 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1674 if (xsgn
^ SCM_BIGSIGN (z
))
1678 num
+= (long) zds
[i
] - x
[i
];
1681 zds
[i
] = num
+ SCM_BIGRAD
;
1686 zds
[i
] = SCM_BIGLO (num
);
1691 if (num
&& nx
== ny
)
1695 SCM_SET_CELL_WORD_0 (z
, SCM_CELL_WORD_0 (z
) ^ SCM_BIGSIGNFLAG
);
1698 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1699 zds
[i
++] = SCM_BIGLO (num
);
1700 num
= SCM_BIGDN (num
);
1710 zds
[i
++] = num
+ SCM_BIGRAD
;
1715 zds
[i
++] = SCM_BIGLO (num
);
1724 num
+= (long) zds
[i
] + x
[i
];
1725 zds
[i
++] = SCM_BIGLO (num
);
1726 num
= SCM_BIGDN (num
);
1734 zds
[i
++] = SCM_BIGLO (num
);
1735 num
= SCM_BIGDN (num
);
1741 z
= scm_adjbig (z
, ny
+ 1);
1742 SCM_BDIGITS (z
)[ny
] = num
;
1746 return scm_normbig (z
);
1751 scm_mulbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
)
1753 scm_sizet i
= 0, j
= nx
+ ny
;
1754 unsigned long n
= 0;
1755 SCM z
= scm_mkbig (j
, sgn
);
1756 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1766 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1767 zds
[i
+ j
++] = SCM_BIGLO (n
);
1779 return scm_normbig (z
);
1784 scm_divbigdig (SCM_BIGDIG
* ds
, scm_sizet h
, SCM_BIGDIG div
)
1786 register unsigned long t2
= 0;
1789 t2
= SCM_BIGUP (t2
) + ds
[h
];
1799 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1805 register unsigned long t2
= 0;
1806 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1807 scm_sizet nd
= SCM_NUMDIGS (x
);
1809 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1812 return SCM_MAKINUM (sgn
? -t2
: t2
);
1815 #ifndef SCM_DIGSTOOBIG
1816 unsigned long t2
= scm_pseudolong (z
);
1817 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1818 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1821 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1822 scm_longdigs (z
, t2
);
1823 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1824 t2
, SCM_DIGSPERLONG
,
1832 scm_divbigbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
)
1834 /* modes description
1838 3 quotient but returns SCM_UNDEFINED if division is not exact. */
1839 scm_sizet i
= 0, j
= 0;
1841 unsigned long t2
= 0;
1843 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1844 /* algorithm requires nx >= ny */
1848 case 0: /* remainder -- just return x */
1849 z
= scm_mkbig (nx
, sgn
);
1850 zds
= SCM_BDIGITS (z
);
1857 case 1: /* scm_modulo -- return y-x */
1858 z
= scm_mkbig (ny
, sgn
);
1859 zds
= SCM_BDIGITS (z
);
1862 num
+= (long) y
[i
] - x
[i
];
1865 zds
[i
] = num
+ SCM_BIGRAD
;
1880 zds
[i
++] = num
+ SCM_BIGRAD
;
1891 return SCM_INUM0
; /* quotient is zero */
1893 return SCM_UNDEFINED
; /* the division is not exact */
1896 z
= scm_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1897 zds
= SCM_BDIGITS (z
);
1901 ny
--; /* in case y came in as a psuedolong */
1902 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1903 { /* normalize operands */
1904 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1905 newy
= scm_mkbig (ny
, 0);
1906 yds
= SCM_BDIGITS (newy
);
1909 t2
+= (unsigned long) y
[j
] * d
;
1910 yds
[j
++] = SCM_BIGLO (t2
);
1911 t2
= SCM_BIGDN (t2
);
1918 t2
+= (unsigned long) x
[j
] * d
;
1919 zds
[j
++] = SCM_BIGLO (t2
);
1920 t2
= SCM_BIGDN (t2
);
1930 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1932 { /* loop over digits of quotient */
1933 if (zds
[j
] == y
[ny
- 1])
1934 qhat
= SCM_BIGRAD
- 1;
1936 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1943 { /* multiply and subtract */
1944 t2
+= (unsigned long) y
[i
] * qhat
;
1945 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1948 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1953 zds
[j
- ny
+ i
] = num
;
1956 t2
= SCM_BIGDN (t2
);
1959 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1961 { /* "add back" required */
1967 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1968 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1969 num
= SCM_BIGDN (num
);
1980 case 3: /* check that remainder==0 */
1981 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1983 return SCM_UNDEFINED
;
1984 case 2: /* move quotient down in z */
1985 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
1986 for (i
= 0; i
< j
; i
++)
1987 zds
[i
] = zds
[i
+ ny
];
1990 case 1: /* subtract for scm_modulo */
1996 num
+= y
[i
] - zds
[i
];
2000 zds
[i
] = num
+ SCM_BIGRAD
;
2012 case 0: /* just normalize remainder */
2014 scm_divbigdig (zds
, ny
, d
);
2017 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
2018 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
2019 if (SCM_INUMP (z
= scm_big2inum (z
, j
)))
2021 return scm_adjbig (z
, j
);
2029 /*** NUMBERS -> STRINGS ***/
2031 static const double fx
[] =
2032 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
2033 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
2034 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
2035 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
2041 idbl2str (double f
, char *a
)
2043 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
2048 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
2067 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
2068 make-uniform-vector, from causing infinite loops. */
2072 if (exp
-- < DBL_MIN_10_EXP
)
2078 if (exp
++ > DBL_MAX_10_EXP
)
2093 if (f
+ fx
[wp
] >= 10.0)
2100 dpt
= (exp
+ 9999) % 3;
2104 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2129 if (f
+ fx
[wp
] >= 1.0)
2143 if ((dpt
> 4) && (exp
> 6))
2145 d
= (a
[0] == '-' ? 2 : 1);
2146 for (i
= ch
++; i
> d
; i
--)
2159 if (a
[ch
- 1] == '.')
2160 a
[ch
++] = '0'; /* trailing zero */
2169 for (i
= 10; i
<= exp
; i
*= 10);
2170 for (i
/= 10; i
; i
/= 10)
2172 a
[ch
++] = exp
/ i
+ '0';
2181 iflo2str (SCM flt
, char *str
)
2184 if (SCM_SLOPPY_REALP (flt
))
2185 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2188 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2189 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2191 if (0 <= SCM_COMPLEX_IMAG (flt
))
2193 i
+= idbl2str (SCM_COMPLEX_IMAG (flt
), &str
[i
]);
2200 /* convert a long to a string (unterminated). returns the number of
2201 characters in the result.
2203 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2205 scm_iint2str (long num
, int rad
, char *p
)
2209 unsigned long n
= (num
< 0) ? -num
: num
;
2211 for (n
/= rad
; n
> 0; n
/= rad
)
2228 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2237 big2str (SCM b
, unsigned int radix
)
2239 SCM t
= scm_copybig (b
, 0); /* sign of temp doesn't matter */
2240 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2241 scm_sizet i
= SCM_NUMDIGS (t
);
2242 scm_sizet j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2243 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2244 : (SCM_BITSPERDIG
* i
) + 2;
2246 scm_sizet radct
= 0;
2247 SCM_BIGDIG radpow
= 1, radmod
= 0;
2248 SCM ss
= scm_makstr ((long) j
, 0);
2249 char *s
= SCM_STRING_CHARS (ss
), c
;
2250 while ((long) radpow
* radix
< SCM_BIGRAD
)
2255 while ((i
|| radmod
) && j
)
2259 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2267 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2270 if (SCM_BIGSIGN (b
))
2275 /* The pre-reserved string length was too large. */
2276 unsigned long int length
= SCM_STRING_LENGTH (ss
);
2277 ss
= scm_substring (ss
, SCM_MAKINUM (j
), SCM_MAKINUM (length
));
2280 return scm_return_first (ss
, t
);
2285 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2287 "Return a string holding the external representation of the\n"
2288 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2289 "inexact, a radix of 10 will be used.")
2290 #define FUNC_NAME s_scm_number_to_string
2294 if (SCM_UNBNDP (radix
)) {
2297 SCM_VALIDATE_INUM (2, radix
);
2298 base
= SCM_INUM (radix
);
2299 SCM_ASSERT_RANGE (2, radix
, base
>= 2);
2302 if (SCM_INUMP (n
)) {
2303 char num_buf
[SCM_INTBUFLEN
];
2304 scm_sizet length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2305 return scm_makfromstr (num_buf
, length
, 0);
2306 } else if (SCM_BIGP (n
)) {
2307 return big2str (n
, (unsigned int) base
);
2308 } else if (SCM_INEXACTP (n
)) {
2309 char num_buf
[SCM_FLOBUFLEN
];
2310 return scm_makfromstr (num_buf
, iflo2str (n
, num_buf
), 0);
2312 SCM_WRONG_TYPE_ARG (1, n
);
2318 /* These print routines are stubbed here so that scm_repl.c doesn't need
2319 SCM_BIGDIG conditionals */
2322 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2324 char num_buf
[SCM_FLOBUFLEN
];
2325 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2330 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2332 char num_buf
[SCM_FLOBUFLEN
];
2333 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2338 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate
)
2341 exp
= big2str (exp
, (unsigned int) 10);
2342 scm_lfwrite (SCM_STRING_CHARS (exp
), (scm_sizet
) SCM_STRING_LENGTH (exp
), port
);
2344 scm_ipruk ("bignum", exp
, port
);
2348 /*** END nums->strs ***/
2350 /*** STRINGS -> NUMBERS ***/
2353 scm_small_istr2int (char *str
, long len
, long radix
)
2355 register long n
= 0, ln
;
2360 return SCM_BOOL_F
; /* zero scm_length */
2362 { /* leading sign */
2367 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2372 switch (c
= str
[i
++])
2394 return SCM_BOOL_F
; /* bad digit for radix */
2397 /* Negation is a workaround for HP700 cc bug */
2398 if (n
> ln
|| (-n
> -SCM_MOST_NEGATIVE_FIXNUM
))
2402 return SCM_BOOL_F
; /* not a digit */
2407 if ((n
= -n
) > SCM_MOST_POSITIVE_FIXNUM
)
2409 return SCM_MAKINUM (n
);
2410 ovfl
: /* overflow scheme integer */
2417 scm_istr2int (char *str
, long len
, long radix
)
2420 register scm_sizet k
, blen
= 1;
2424 register SCM_BIGDIG
*ds
;
2425 register unsigned long t2
;
2428 return SCM_BOOL_F
; /* zero scm_length */
2430 /* Short numbers we parse directly into an int, to avoid the overhead
2431 of creating a bignum. */
2433 return scm_small_istr2int (str
, len
, radix
);
2436 j
= 1 + (4 * len
* sizeof (char)) / (SCM_BITSPERDIG
);
2437 else if (10 <= radix
)
2438 j
= 1 + (84 * len
* sizeof (char)) / (SCM_BITSPERDIG
* 25);
2440 j
= 1 + (len
* sizeof (char)) / (SCM_BITSPERDIG
);
2442 { /* leading sign */
2445 if (++i
== (unsigned) len
)
2446 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2448 res
= scm_mkbig (j
, '-' == str
[0]);
2449 ds
= SCM_BDIGITS (res
);
2454 switch (c
= str
[i
++])
2476 return SCM_BOOL_F
; /* bad digit for radix */
2482 /* printf ("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]); */
2483 t2
+= ds
[k
] * radix
;
2484 ds
[k
++] = SCM_BIGLO (t2
);
2485 t2
= SCM_BIGDN (t2
);
2488 scm_num_overflow ("bignum");
2496 return SCM_BOOL_F
; /* not a digit */
2499 while (i
< (unsigned) len
);
2500 if (blen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
2501 if (SCM_INUMP (res
= scm_big2inum (res
, blen
)))
2505 return scm_adjbig (res
, blen
);
2509 scm_istr2flo (char *str
, long len
, long radix
)
2511 register int c
, i
= 0;
2513 double res
= 0.0, tmp
= 0.0;
2519 return SCM_BOOL_F
; /* zero scm_length */
2522 { /* leading sign */
2535 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2537 if (str
[i
] == 'i' || str
[i
] == 'I')
2538 { /* handle `+i' and `-i' */
2539 if (lead_sgn
== 0.0)
2540 return SCM_BOOL_F
; /* must have leading sign */
2542 return SCM_BOOL_F
; /* `i' not last character */
2543 return scm_make_complex (0.0, lead_sgn
);
2546 { /* check initial digits */
2556 goto out1
; /* must be exponent */
2573 return SCM_BOOL_F
; /* bad digit for radix */
2574 res
= res
* radix
+ c
;
2575 flg
= 1; /* res is valid */
2584 /* if true, then we did see a digit above, and res is valid */
2588 /* By here, must have seen a digit,
2589 or must have next char be a `.' with radix==10 */
2591 if (!(str
[i
] == '.' && radix
== 10))
2594 while (str
[i
] == '#')
2595 { /* optional sharps */
2628 tmp
= tmp
* radix
+ c
;
2636 return SCM_BOOL_F
; /* `slash zero' not allowed */
2638 while (str
[i
] == '#')
2639 { /* optional sharps */
2649 { /* decimal point notation */
2651 return SCM_BOOL_F
; /* must be radix 10 */
2658 res
= res
* 10.0 + c
- '0';
2667 return SCM_BOOL_F
; /* no digits before or after decimal point */
2670 while (str
[i
] == '#')
2671 { /* ignore remaining sharps */
2690 int expsgn
= 1, expon
= 0;
2692 return SCM_BOOL_F
; /* only in radix 10 */
2694 return SCM_BOOL_F
; /* bad exponent */
2701 return SCM_BOOL_F
; /* bad exponent */
2703 if (str
[i
] < '0' || str
[i
] > '9')
2704 return SCM_BOOL_F
; /* bad exponent */
2710 expon
= expon
* 10 + c
- '0';
2711 if (expon
> SCM_MAXEXP
)
2712 scm_out_of_range ("string->number", SCM_MAKINUM (expon
));
2720 point
+= expsgn
* expon
;
2738 /* at this point, we have a legitimate floating point result */
2739 if (lead_sgn
== -1.0)
2742 return scm_make_real (res
);
2744 if (str
[i
] == 'i' || str
[i
] == 'I')
2745 { /* pure imaginary number */
2746 if (lead_sgn
== 0.0)
2747 return SCM_BOOL_F
; /* must have leading sign */
2749 return SCM_BOOL_F
; /* `i' not last character */
2750 return scm_make_complex (0.0, res
);
2762 { /* polar input for complex number */
2763 /* get a `real' for scm_angle */
2764 second
= scm_istr2flo (&str
[i
], (long) (len
- i
), radix
);
2765 if (!SCM_SLOPPY_INEXACTP (second
))
2766 return SCM_BOOL_F
; /* not `real' */
2767 if (SCM_SLOPPY_COMPLEXP (second
))
2768 return SCM_BOOL_F
; /* not `real' */
2769 tmp
= SCM_REAL_VALUE (second
);
2770 return scm_make_complex (res
* cos (tmp
), res
* sin (tmp
));
2776 /* at this point, last char must be `i' */
2777 if (str
[len
- 1] != 'i' && str
[len
- 1] != 'I')
2779 /* handles `x+i' and `x-i' */
2781 return scm_make_complex (res
, lead_sgn
);
2782 /* get a `ureal' for complex part */
2783 second
= scm_istr2flo (&str
[i
], (long) ((len
- i
) - 1), radix
);
2784 if (!SCM_INEXACTP (second
))
2785 return SCM_BOOL_F
; /* not `ureal' */
2786 if (SCM_SLOPPY_COMPLEXP (second
))
2787 return SCM_BOOL_F
; /* not `ureal' */
2788 tmp
= SCM_REAL_VALUE (second
);
2790 return SCM_BOOL_F
; /* not `ureal' */
2791 return scm_make_complex (res
, (lead_sgn
* tmp
));
2797 scm_istring2number (char *str
, long len
, long radix
)
2801 char ex_p
= 0, rx_p
= 0; /* Only allow 1 exactness and 1 radix prefix */
2804 if (*str
== '+' || *str
== '-') /* Catches lone `+' and `-' for speed */
2807 while ((len
- i
) >= 2 && str
[i
] == '#' && ++i
)
2853 return scm_istr2int (&str
[i
], len
- i
, radix
);
2855 res
= scm_istr2int (&str
[i
], len
- i
, radix
);
2856 if (SCM_NFALSEP (res
))
2859 return scm_istr2flo (&str
[i
], len
- i
, radix
);
2865 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2866 (SCM string
, SCM radix
),
2867 "Returns a number of the maximally precise representation\n"
2868 "expressed by the given @var{string}. @var{radix} must be an\n"
2869 "exact integer, either 2, 8, 10, or 16. If supplied, @var{RADIX}\n"
2870 "is a default radix that may be overridden by an explicit\n"
2871 "radix prefix in @var{string} (e.g. \"#o177\"). If @var{radix}\n"
2872 "is not supplied, then the default radix is 10. If string is\n"
2873 "not a syntactically valid notation for a number, then\n"
2874 "@code{string->number} returns @code{#f}. (r5rs)")
2875 #define FUNC_NAME s_scm_string_to_number
2879 SCM_VALIDATE_STRING (1, string
);
2880 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2881 answer
= scm_istring2number (SCM_STRING_CHARS (string
),
2882 SCM_STRING_LENGTH (string
),
2884 return scm_return_first (answer
, string
);
2887 /*** END strs->nums ***/
2891 scm_make_real (double x
)
2895 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
2896 SCM_REAL_VALUE (z
) = x
;
2902 scm_make_complex (double x
, double y
)
2905 return scm_make_real (x
);
2908 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_must_malloc (2L * sizeof (double), "complex"));
2909 SCM_COMPLEX_REAL (z
) = x
;
2910 SCM_COMPLEX_IMAG (z
) = y
;
2917 scm_bigequal (SCM x
, SCM y
)
2920 if (0 == scm_bigcomp (x
, y
))
2927 scm_real_equalp (SCM x
, SCM y
)
2929 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2933 scm_complex_equalp (SCM x
, SCM y
)
2935 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2936 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2941 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2942 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2943 * "else. Note that the sets of complex, real, rational and\n"
2944 * "integer values form subsets of the set of numbers, i. e. the\n"
2945 * "predicate will be fulfilled for any number."
2947 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2949 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2950 "else. Note that the sets of real, rational and integer\n"
2951 "values form subsets of the set of complex numbers, i. e. the\n"
2952 "predicate will also be fulfilled if @var{x} is a real,\n"
2953 "rational or integer number.")
2954 #define FUNC_NAME s_scm_number_p
2956 return SCM_BOOL (SCM_NUMBERP (x
));
2961 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2962 /* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
2963 * "Note that the sets of integer and rational values form a subset\n"
2964 * "of the set of real numbers, i. e. the predicate will also\n"
2965 * "be fulfilled if @var{x} is an integer or a rational number."
2967 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2969 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
2970 "else. Note that the set of integer values forms a subset of\n"
2971 "the set of rational numbers, i. e. the predicate will also be\n"
2972 "fulfilled if @var{x} is an integer number. Real numbers\n"
2973 "will also satisfy this predicate, because of their limited\n"
2975 #define FUNC_NAME s_scm_real_p
2977 if (SCM_INUMP (x
)) {
2979 } else if (SCM_IMP (x
)) {
2981 } else if (SCM_SLOPPY_REALP (x
)) {
2983 } else if (SCM_BIGP (x
)) {
2992 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2994 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2996 #define FUNC_NAME s_scm_integer_p
3005 if (!SCM_SLOPPY_INEXACTP (x
))
3007 if (SCM_SLOPPY_COMPLEXP (x
))
3009 r
= SCM_REAL_VALUE (x
);
3017 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
3019 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
3021 #define FUNC_NAME s_scm_inexact_p
3023 return SCM_BOOL (SCM_INEXACTP (x
));
3028 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
3029 /* "Return @code{#t} if all parameters are numerically equal." */
3031 scm_num_eq_p (SCM x
, SCM y
)
3033 if (SCM_INUMP (x
)) {
3034 long xx
= SCM_INUM (x
);
3035 if (SCM_INUMP (y
)) {
3036 long yy
= SCM_INUM (y
);
3037 return SCM_BOOL (xx
== yy
);
3038 } else if (SCM_BIGP (y
)) {
3040 } else if (SCM_REALP (y
)) {
3041 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
3042 } else if (SCM_COMPLEXP (y
)) {
3043 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
3044 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3046 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3048 } else if (SCM_BIGP (x
)) {
3049 if (SCM_INUMP (y
)) {
3051 } else if (SCM_BIGP (y
)) {
3052 return SCM_BOOL (0 == scm_bigcomp (x
, y
));
3053 } else if (SCM_REALP (y
)) {
3054 return SCM_BOOL (scm_big2dbl (x
) == SCM_REAL_VALUE (y
));
3055 } else if (SCM_COMPLEXP (y
)) {
3056 return SCM_BOOL ((scm_big2dbl (x
) == SCM_COMPLEX_REAL (y
))
3057 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3059 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3061 } else if (SCM_REALP (x
)) {
3062 if (SCM_INUMP (y
)) {
3063 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3064 } else if (SCM_BIGP (y
)) {
3065 return SCM_BOOL (SCM_REAL_VALUE (x
) == scm_big2dbl (y
));
3066 } else if (SCM_REALP (y
)) {
3067 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3068 } else if (SCM_COMPLEXP (y
)) {
3069 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3070 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3072 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3074 } else if (SCM_COMPLEXP (x
)) {
3075 if (SCM_INUMP (y
)) {
3076 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3077 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3078 } else if (SCM_BIGP (y
)) {
3079 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == scm_big2dbl (y
))
3080 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3081 } else if (SCM_REALP (y
)) {
3082 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3083 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3084 } else if (SCM_COMPLEXP (y
)) {
3085 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3086 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3088 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3091 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3096 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3097 /* "Return @code{#t} if the list of parameters is monotonically\n"
3101 scm_less_p (SCM x
, SCM y
)
3103 if (SCM_INUMP (x
)) {
3104 long xx
= SCM_INUM (x
);
3105 if (SCM_INUMP (y
)) {
3106 long yy
= SCM_INUM (y
);
3107 return SCM_BOOL (xx
< yy
);
3108 } else if (SCM_BIGP (y
)) {
3109 return SCM_BOOL (!SCM_BIGSIGN (y
));
3110 } else if (SCM_REALP (y
)) {
3111 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3113 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3115 } else if (SCM_BIGP (x
)) {
3116 if (SCM_INUMP (y
)) {
3117 return SCM_BOOL (SCM_BIGSIGN (x
));
3118 } else if (SCM_BIGP (y
)) {
3119 return SCM_BOOL (1 == scm_bigcomp (x
, y
));
3120 } else if (SCM_REALP (y
)) {
3121 return SCM_BOOL (scm_big2dbl (x
) < SCM_REAL_VALUE (y
));
3123 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3125 } else if (SCM_REALP (x
)) {
3126 if (SCM_INUMP (y
)) {
3127 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3128 } else if (SCM_BIGP (y
)) {
3129 return SCM_BOOL (SCM_REAL_VALUE (x
) < scm_big2dbl (y
));
3130 } else if (SCM_REALP (y
)) {
3131 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3133 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3136 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3141 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3142 /* "Return @code{#t} if the list of parameters is monotonically\n"
3145 #define FUNC_NAME s_scm_gr_p
3147 scm_gr_p (SCM x
, SCM y
)
3149 if (!SCM_NUMBERP (x
))
3150 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3151 else if (!SCM_NUMBERP (y
))
3152 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3154 return scm_less_p (y
, x
);
3159 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3160 /* "Return @code{#t} if the list of parameters is monotonically\n"
3163 #define FUNC_NAME s_scm_leq_p
3165 scm_leq_p (SCM x
, SCM y
)
3167 if (!SCM_NUMBERP (x
))
3168 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3169 else if (!SCM_NUMBERP (y
))
3170 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3172 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3177 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3178 /* "Return @code{#t} if the list of parameters is monotonically\n"
3181 #define FUNC_NAME s_scm_geq_p
3183 scm_geq_p (SCM x
, SCM y
)
3185 if (!SCM_NUMBERP (x
))
3186 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3187 else if (!SCM_NUMBERP (y
))
3188 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3190 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3195 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3196 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3202 if (SCM_INUMP (z
)) {
3203 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3204 } else if (SCM_BIGP (z
)) {
3206 } else if (SCM_REALP (z
)) {
3207 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3208 } else if (SCM_COMPLEXP (z
)) {
3209 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3210 && SCM_COMPLEX_IMAG (z
) == 0.0);
3212 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3217 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3218 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3222 scm_positive_p (SCM x
)
3224 if (SCM_INUMP (x
)) {
3225 return SCM_BOOL (SCM_INUM (x
) > 0);
3226 } else if (SCM_BIGP (x
)) {
3227 return SCM_BOOL (!SCM_BIGSIGN (x
));
3228 } else if (SCM_REALP (x
)) {
3229 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3231 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3236 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3237 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3241 scm_negative_p (SCM x
)
3243 if (SCM_INUMP (x
)) {
3244 return SCM_BOOL (SCM_INUM (x
) < 0);
3245 } else if (SCM_BIGP (x
)) {
3246 return SCM_BOOL (SCM_BIGSIGN (x
));
3247 } else if (SCM_REALP (x
)) {
3248 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3250 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3255 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3256 /* "Return the maximum of all parameter values."
3259 scm_max (SCM x
, SCM y
)
3261 if (SCM_UNBNDP (y
)) {
3262 if (SCM_UNBNDP (x
)) {
3263 SCM_WTA_DISPATCH_0 (g_max
, x
, SCM_ARG1
, s_max
);
3264 } else if (SCM_NUMBERP (x
)) {
3267 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3271 if (SCM_INUMP (x
)) {
3272 long xx
= SCM_INUM (x
);
3273 if (SCM_INUMP (y
)) {
3274 long yy
= SCM_INUM (y
);
3275 return (xx
< yy
) ? y
: x
;
3276 } else if (SCM_BIGP (y
)) {
3277 return SCM_BIGSIGN (y
) ? x
: y
;
3278 } else if (SCM_REALP (y
)) {
3280 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3282 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3284 } else if (SCM_BIGP (x
)) {
3285 if (SCM_INUMP (y
)) {
3286 return SCM_BIGSIGN (x
) ? y
: x
;
3287 } else if (SCM_BIGP (y
)) {
3288 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3289 } else if (SCM_REALP (y
)) {
3290 double z
= scm_big2dbl (x
);
3291 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3293 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3295 } else if (SCM_REALP (x
)) {
3296 if (SCM_INUMP (y
)) {
3297 double z
= SCM_INUM (y
);
3298 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3299 } else if (SCM_BIGP (y
)) {
3300 double z
= scm_big2dbl (y
);
3301 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3302 } else if (SCM_REALP (y
)) {
3303 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? y
: x
;
3305 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3308 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3313 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3314 /* "Return the minium of all parameter values."
3317 scm_min (SCM x
, SCM y
)
3319 if (SCM_UNBNDP (y
)) {
3320 if (SCM_UNBNDP (x
)) {
3321 SCM_WTA_DISPATCH_0 (g_min
, x
, SCM_ARG1
, s_min
);
3322 } else if (SCM_NUMBERP (x
)) {
3325 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3329 if (SCM_INUMP (x
)) {
3330 long xx
= SCM_INUM (x
);
3331 if (SCM_INUMP (y
)) {
3332 long yy
= SCM_INUM (y
);
3333 return (xx
< yy
) ? x
: y
;
3334 } else if (SCM_BIGP (y
)) {
3335 return SCM_BIGSIGN (y
) ? y
: x
;
3336 } else if (SCM_REALP (y
)) {
3338 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3340 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3342 } else if (SCM_BIGP (x
)) {
3343 if (SCM_INUMP (y
)) {
3344 return SCM_BIGSIGN (x
) ? x
: y
;
3345 } else if (SCM_BIGP (y
)) {
3346 return (-1 == scm_bigcomp (x
, y
)) ? y
: x
;
3347 } else if (SCM_REALP (y
)) {
3348 double z
= scm_big2dbl (x
);
3349 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3351 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3353 } else if (SCM_REALP (x
)) {
3354 if (SCM_INUMP (y
)) {
3355 double z
= SCM_INUM (y
);
3356 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3357 } else if (SCM_BIGP (y
)) {
3358 double z
= scm_big2dbl (y
);
3359 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3360 } else if (SCM_REALP (y
)) {
3361 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? x
: y
;
3363 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3366 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3371 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3372 /* "Return the sum of all parameter values. Return 0 if called without\n"
3376 scm_sum (SCM x
, SCM y
)
3378 if (SCM_UNBNDP (y
)) {
3379 if (SCM_UNBNDP (x
)) {
3381 } else if (SCM_NUMBERP (x
)) {
3384 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3388 if (SCM_INUMP (x
)) {
3389 long int xx
= SCM_INUM (x
);
3390 if (SCM_INUMP (y
)) {
3391 long int yy
= SCM_INUM (y
);
3392 long int z
= xx
+ yy
;
3393 if (SCM_FIXABLE (z
)) {
3394 return SCM_MAKINUM (z
);
3397 return scm_long2big (z
);
3398 #else /* SCM_BIGDIG */
3399 return scm_make_real ((double) z
);
3400 #endif /* SCM_BIGDIG */
3402 } else if (SCM_BIGP (y
)) {
3405 long int xx
= SCM_INUM (x
);
3406 #ifndef SCM_DIGSTOOBIG
3407 long z
= scm_pseudolong (xx
);
3408 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3409 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3410 #else /* SCM_DIGSTOOBIG */
3411 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3412 scm_longdigs (xx
, zdigs
);
3413 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3414 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3415 #endif /* SCM_DIGSTOOBIG */
3417 } else if (SCM_REALP (y
)) {
3418 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3419 } else if (SCM_COMPLEXP (y
)) {
3420 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3421 SCM_COMPLEX_IMAG (y
));
3423 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3425 } else if (SCM_BIGP (x
)) {
3426 if (SCM_INUMP (y
)) {
3429 } else if (SCM_BIGP (y
)) {
3430 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
)) {
3433 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3434 SCM_BIGSIGN (x
), y
, 0);
3435 } else if (SCM_REALP (y
)) {
3436 return scm_make_real (scm_big2dbl (x
) + SCM_REAL_VALUE (y
));
3437 } else if (SCM_COMPLEXP (y
)) {
3438 return scm_make_complex (scm_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3439 SCM_COMPLEX_IMAG (y
));
3441 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3443 } else if (SCM_REALP (x
)) {
3444 if (SCM_INUMP (y
)) {
3445 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3446 } else if (SCM_BIGP (y
)) {
3447 return scm_make_real (SCM_REAL_VALUE (x
) + scm_big2dbl (y
));
3448 } else if (SCM_REALP (y
)) {
3449 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3450 } else if (SCM_COMPLEXP (y
)) {
3451 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3452 SCM_COMPLEX_IMAG (y
));
3454 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3456 } else if (SCM_COMPLEXP (x
)) {
3457 if (SCM_INUMP (y
)) {
3458 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3459 SCM_COMPLEX_IMAG (x
));
3460 } else if (SCM_BIGP (y
)) {
3461 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_big2dbl (y
),
3462 SCM_COMPLEX_IMAG (x
));
3463 } else if (SCM_REALP (y
)) {
3464 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3465 SCM_COMPLEX_IMAG (x
));
3466 } else if (SCM_COMPLEXP (y
)) {
3467 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3468 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3470 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3473 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3478 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3479 /* "If called without arguments, 0 is returned. Otherwise the sum of\n"
3480 * "all but the first argument are subtracted from the first\n"
3484 scm_difference (SCM x
, SCM y
)
3486 if (SCM_UNBNDP (y
)) {
3487 if (SCM_INUMP (x
)) {
3488 long xx
= -SCM_INUM (x
);
3489 if (SCM_FIXABLE (xx
)) {
3490 return SCM_MAKINUM (xx
);
3493 return scm_long2big (xx
);
3495 return scm_make_real ((double) xx
);
3498 } else if (SCM_BIGP (x
)) {
3499 SCM z
= scm_copybig (x
, !SCM_BIGSIGN (x
));
3500 unsigned int digs
= SCM_NUMDIGS (z
);
3501 unsigned int size
= digs
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
;
3502 return size
<= sizeof (SCM
) ? scm_big2inum (z
, digs
) : z
;
3503 } else if (SCM_REALP (x
)) {
3504 return scm_make_real (-SCM_REAL_VALUE (x
));
3505 } else if (SCM_COMPLEXP (x
)) {
3506 return scm_make_complex (-SCM_COMPLEX_REAL (x
), -SCM_COMPLEX_IMAG (x
));
3508 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3512 if (SCM_INUMP (x
)) {
3513 long int xx
= SCM_INUM (x
);
3514 if (SCM_INUMP (y
)) {
3515 long int yy
= SCM_INUM (y
);
3516 long int z
= xx
- yy
;
3517 if (SCM_FIXABLE (z
)) {
3518 return SCM_MAKINUM (z
);
3521 return scm_long2big (z
);
3523 return scm_make_real ((double) z
);
3526 } else if (SCM_BIGP (y
)) {
3527 #ifndef SCM_DIGSTOOBIG
3528 long z
= scm_pseudolong (xx
);
3529 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3530 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3532 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3533 scm_longdigs (xx
, zdigs
);
3534 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3535 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3537 } else if (SCM_REALP (y
)) {
3538 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
3539 } else if (SCM_COMPLEXP (y
)) {
3540 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
3541 -SCM_COMPLEX_IMAG (y
));
3543 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3545 } else if (SCM_BIGP (x
)) {
3546 if (SCM_INUMP (y
)) {
3547 long int yy
= SCM_INUM (y
);
3548 #ifndef SCM_DIGSTOOBIG
3549 long z
= scm_pseudolong (yy
);
3550 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3551 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3553 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3554 scm_longdigs (yy
, zdigs
);
3555 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3556 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3558 } else if (SCM_BIGP (y
)) {
3559 return (SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3560 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3561 SCM_BIGSIGN (x
), y
, SCM_BIGSIGNFLAG
)
3562 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3563 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
, x
, 0);
3564 } else if (SCM_REALP (y
)) {
3565 return scm_make_real (scm_big2dbl (x
) - SCM_REAL_VALUE (y
));
3566 } else if (SCM_COMPLEXP (y
)) {
3567 return scm_make_complex (scm_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3568 - SCM_COMPLEX_IMAG (y
));
3570 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3572 } else if (SCM_REALP (x
)) {
3573 if (SCM_INUMP (y
)) {
3574 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
3575 } else if (SCM_BIGP (y
)) {
3576 return scm_make_real (SCM_REAL_VALUE (x
) - scm_big2dbl (y
));
3577 } else if (SCM_REALP (y
)) {
3578 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3579 } else if (SCM_COMPLEXP (y
)) {
3580 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3581 -SCM_COMPLEX_IMAG (y
));
3583 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3585 } else if (SCM_COMPLEXP (x
)) {
3586 if (SCM_INUMP (y
)) {
3587 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
3588 SCM_COMPLEX_IMAG (x
));
3589 } else if (SCM_BIGP (y
)) {
3590 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_big2dbl (y
),
3591 SCM_COMPLEX_IMAG (x
));
3592 } else if (SCM_REALP (y
)) {
3593 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3594 SCM_COMPLEX_IMAG (x
));
3595 } else if (SCM_COMPLEXP (y
)) {
3596 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3597 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3599 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3602 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3607 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3608 /* "Return the product of all arguments. If called without arguments,\n"
3612 scm_product (SCM x
, SCM y
)
3614 if (SCM_UNBNDP (y
)) {
3615 if (SCM_UNBNDP (x
)) {
3616 return SCM_MAKINUM (1L);
3617 } else if (SCM_NUMBERP (x
)) {
3620 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3624 if (SCM_INUMP (x
)) {
3632 } else if (xx
== 1) {
3636 if (SCM_INUMP (y
)) {
3637 long yy
= SCM_INUM (y
);
3639 SCM k
= SCM_MAKINUM (kk
);
3640 if (kk
!= SCM_INUM (k
) || kk
/ xx
!= yy
) {
3642 int sgn
= (xx
< 0) ^ (yy
< 0);
3643 #ifndef SCM_DIGSTOOBIG
3644 long i
= scm_pseudolong (xx
);
3645 long j
= scm_pseudolong (yy
);
3646 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3647 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3648 #else /* SCM_DIGSTOOBIG */
3649 SCM_BIGDIG xdigs
[SCM_DIGSPERLONG
];
3650 SCM_BIGDIG ydigs
[SCM_DIGSPERLONG
];
3651 scm_longdigs (xx
, xdigs
);
3652 scm_longdigs (yy
, ydigs
);
3653 return scm_mulbig (xdigs
, SCM_DIGSPERLONG
,
3654 ydigs
, SCM_DIGSPERLONG
,
3658 return scm_make_real (((double) xx
) * ((double) yy
));
3663 } else if (SCM_BIGP (y
)) {
3664 #ifndef SCM_DIGSTOOBIG
3665 long z
= scm_pseudolong (xx
);
3666 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3667 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3668 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3670 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3671 scm_longdigs (xx
, zdigs
);
3672 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3673 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3674 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3676 } else if (SCM_REALP (y
)) {
3677 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3678 } else if (SCM_COMPLEXP (y
)) {
3679 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3680 xx
* SCM_COMPLEX_IMAG (y
));
3682 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3684 } else if (SCM_BIGP (x
)) {
3685 if (SCM_INUMP (y
)) {
3688 } else if (SCM_BIGP (y
)) {
3689 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3690 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3691 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3692 } else if (SCM_REALP (y
)) {
3693 return scm_make_real (scm_big2dbl (x
) * SCM_REAL_VALUE (y
));
3694 } else if (SCM_COMPLEXP (y
)) {
3695 double z
= scm_big2dbl (x
);
3696 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3697 z
* SCM_COMPLEX_IMAG (y
));
3699 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3701 } else if (SCM_REALP (x
)) {
3702 if (SCM_INUMP (y
)) {
3703 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3704 } else if (SCM_BIGP (y
)) {
3705 return scm_make_real (scm_big2dbl (y
) * SCM_REAL_VALUE (x
));
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_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3712 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3714 } else if (SCM_COMPLEXP (x
)) {
3715 if (SCM_INUMP (y
)) {
3716 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3717 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3718 } else if (SCM_BIGP (y
)) {
3719 double z
= scm_big2dbl (y
);
3720 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
3721 z
* SCM_COMPLEX_IMAG (x
));
3722 } else if (SCM_REALP (y
)) {
3723 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3724 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
3725 } else if (SCM_COMPLEXP (y
)) {
3726 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
3727 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
3728 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3729 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3731 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3734 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3740 scm_num2dbl (SCM a
, const char *why
)
3741 #define FUNC_NAME why
3743 if (SCM_INUMP (a
)) {
3744 return (double) SCM_INUM (a
);
3745 } else if (SCM_BIGP (a
)) {
3746 return scm_big2dbl (a
);
3747 } else if (SCM_REALP (a
)) {
3748 return (SCM_REAL_VALUE (a
));
3750 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3756 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3757 /* "Divide the first argument by the product of the remaining arguments."
3760 scm_divide (SCM x
, SCM y
)
3764 if (SCM_UNBNDP (y
)) {
3765 if (SCM_UNBNDP (x
)) {
3766 SCM_WTA_DISPATCH_0 (g_divide
, x
, SCM_ARG1
, 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 "Returns 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
, char *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
, (int) pos
, num
);
4410 #ifdef HAVE_LONG_LONGS
4413 scm_num2long_long (SCM num
, char *pos
, const char *s_caller
)
4415 if (SCM_INUMP (num
)) {
4416 return SCM_INUM (num
);
4417 } else if (SCM_BIGP (num
)) {
4419 /* can't use res directly in case num is -2^63. */
4420 unsigned long long int pos_res
= 0;
4421 unsigned long long int old_res
= 0;
4424 for (l
= SCM_NUMDIGS (num
); l
--;) {
4425 pos_res
= SCM_LONGLONGBIGUP (pos_res
) + SCM_BDIGITS (num
)[l
];
4426 if (pos_res
>= old_res
) {
4430 scm_out_of_range (s_caller
, num
);
4433 if (SCM_BIGSIGN (num
)) {
4438 scm_out_of_range (s_caller
, num
);
4445 scm_out_of_range (s_caller
, num
);
4448 } else if (SCM_REALP (num
)) {
4449 double u
= SCM_REAL_VALUE (num
);
4450 long long int res
= u
;
4451 if ((double) res
== u
) {
4454 scm_out_of_range (s_caller
, num
);
4457 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4461 #endif /* HAVE_LONG_LONGS */
4465 scm_num2ulong (SCM num
, char *pos
, const char *s_caller
)
4467 if (SCM_INUMP (num
)) {
4468 long nnum
= SCM_INUM (num
);
4472 scm_out_of_range (s_caller
, num
);
4474 } else if (SCM_BIGP (num
)) {
4475 unsigned long int res
= 0;
4476 unsigned long int old_res
= 0;
4479 for (l
= SCM_NUMDIGS (num
); l
--;) {
4480 res
= SCM_BIGUP (res
) + SCM_BDIGITS (num
)[l
];
4481 if (res
>= old_res
) {
4484 scm_out_of_range (s_caller
, num
);
4488 } else if (SCM_REALP (num
)) {
4489 double u
= SCM_REAL_VALUE (num
);
4490 unsigned long int res
= u
;
4491 if ((double) res
== u
) {
4494 scm_out_of_range (s_caller
, num
);
4497 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4505 abs_most_negative_fixnum
= scm_long2big (- SCM_MOST_NEGATIVE_FIXNUM
);
4506 scm_permanent_object (abs_most_negative_fixnum
);
4508 /* It may be possible to tune the performance of some algorithms by using
4509 * the following constants to avoid the creation of bignums. Please, before
4510 * using these values, remember the two rules of program optimization:
4511 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
4512 scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
4513 scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
4515 scm_add_feature ("complex");
4516 scm_add_feature ("inexact");
4517 scm_flo0
= scm_make_real (0.0);
4519 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4521 { /* determine floating point precision */
4523 double fsum
= 1.0 + f
;
4524 while (fsum
!= 1.0) {
4525 if (++scm_dblprec
> 20) {
4532 scm_dblprec
= scm_dblprec
- 1;
4534 #endif /* DBL_DIG */
4535 #ifndef SCM_MAGIC_SNARFER
4536 #include "libguile/numbers.x"