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. */
47 #include "libguile/_scm.h"
48 #include "libguile/feature.h"
49 #include "libguile/ports.h"
50 #include "libguile/root.h"
51 #include "libguile/smob.h"
52 #include "libguile/strings.h"
54 #include "libguile/validate.h"
55 #include "libguile/numbers.h"
56 #include "libguile/deprecation.h"
60 static SCM
scm_divbigbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
, int modes
);
61 static SCM
scm_divbigint (SCM x
, long z
, int sgn
, int mode
);
64 #define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0)
67 /* FLOBUFLEN is the maximum number of characters neccessary for the
68 * printed or scm_string representation of an inexact number.
70 #define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
73 /* IS_INF tests its floating point number for infiniteness
74 Dirk:FIXME:: This test does not work if x == 0
77 #define IS_INF(x) ((x) == (x) / 2)
81 /* Return true if X is not infinite and is not a NaN
82 Dirk:FIXME:: Since IS_INF is broken, this test does not work if x == 0
85 #define isfinite(x) (!IS_INF (x) && (x) == (x))
90 static SCM abs_most_negative_fixnum
;
95 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
97 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
99 #define FUNC_NAME s_scm_exact_p
103 } else if (SCM_BIGP (x
)) {
112 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
114 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
116 #define FUNC_NAME s_scm_odd_p
119 return SCM_BOOL ((4 & SCM_UNPACK (n
)) != 0);
120 } else if (SCM_BIGP (n
)) {
121 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) != 0);
123 SCM_WRONG_TYPE_ARG (1, n
);
129 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
131 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
133 #define FUNC_NAME s_scm_even_p
136 return SCM_BOOL ((4 & SCM_UNPACK (n
)) == 0);
137 } else if (SCM_BIGP (n
)) {
138 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) == 0);
140 SCM_WRONG_TYPE_ARG (1, n
);
146 SCM_GPROC (s_abs
, "abs", 1, 0, 0, scm_abs
, g_abs
);
147 /* "Return the absolute value of @var{x}."
153 long int xx
= SCM_INUM (x
);
156 } else if (SCM_POSFIXABLE (-xx
)) {
157 return SCM_MAKINUM (-xx
);
160 return scm_i_long2big (-xx
);
162 scm_num_overflow (s_abs
);
165 } else if (SCM_BIGP (x
)) {
166 if (!SCM_BIGSIGN (x
)) {
169 return scm_i_copybig (x
, 0);
171 } else if (SCM_REALP (x
)) {
172 return scm_make_real (fabs (SCM_REAL_VALUE (x
)));
174 SCM_WTA_DISPATCH_1 (g_abs
, x
, 1, s_abs
);
179 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
180 /* "Return the quotient of the numbers @var{x} and @var{y}."
183 scm_quotient (SCM x
, SCM y
)
186 long xx
= SCM_INUM (x
);
188 long yy
= SCM_INUM (y
);
190 scm_num_overflow (s_quotient
);
193 if (SCM_FIXABLE (z
)) {
194 return SCM_MAKINUM (z
);
197 return scm_i_long2big (z
);
199 scm_num_overflow (s_quotient
);
203 } else if (SCM_BIGP (y
)) {
204 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
205 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
207 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
208 return SCM_MAKINUM (-1);
211 return SCM_MAKINUM (0);
213 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
215 } else if (SCM_BIGP (x
)) {
217 long yy
= SCM_INUM (y
);
219 scm_num_overflow (s_quotient
);
220 } else if (yy
== 1) {
223 long z
= yy
< 0 ? -yy
: yy
;
225 if (z
< SCM_BIGRAD
) {
226 SCM sw
= scm_i_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
227 scm_divbigdig (SCM_BDIGITS (sw
), SCM_NUMDIGS (sw
), (SCM_BIGDIG
) z
);
228 return scm_i_normbig (sw
);
230 #ifndef SCM_DIGSTOOBIG
231 long w
= scm_pseudolong (z
);
232 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
233 (SCM_BIGDIG
*) & w
, SCM_DIGSPERLONG
,
234 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
236 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
237 scm_longdigs (z
, zdigs
);
238 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
239 zdigs
, SCM_DIGSPERLONG
,
240 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
244 } else if (SCM_BIGP (y
)) {
245 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
246 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
247 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 2);
249 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
252 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
257 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
258 /* "Return the remainder of the numbers @var{x} and @var{y}.\n"
260 * "(remainder 13 4) @result{} 1\n"
261 * "(remainder -13 4) @result{} -1\n"
265 scm_remainder (SCM x
, SCM y
)
269 long yy
= SCM_INUM (y
);
271 scm_num_overflow (s_remainder
);
273 long z
= SCM_INUM (x
) % yy
;
274 return SCM_MAKINUM (z
);
276 } else if (SCM_BIGP (y
)) {
277 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
278 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
280 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
281 return SCM_MAKINUM (0);
286 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
288 } else if (SCM_BIGP (x
)) {
290 long yy
= SCM_INUM (y
);
292 scm_num_overflow (s_remainder
);
294 return scm_divbigint (x
, yy
, SCM_BIGSIGN (x
), 0);
296 } else if (SCM_BIGP (y
)) {
297 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
298 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
301 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
304 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
309 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
310 /* "Return the modulo of the numbers @var{x} and @var{y}.\n"
312 * "(modulo 13 4) @result{} 1\n"
313 * "(modulo -13 4) @result{} 3\n"
317 scm_modulo (SCM x
, SCM y
)
320 long xx
= SCM_INUM (x
);
322 long yy
= SCM_INUM (y
);
324 scm_num_overflow (s_modulo
);
327 return SCM_MAKINUM (((yy
< 0) ? (z
> 0) : (z
< 0)) ? z
+ yy
: z
);
329 } else if (SCM_BIGP (y
)) {
330 return (SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0)) ? scm_sum (x
, y
) : x
;
332 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
334 } else if (SCM_BIGP (x
)) {
336 long yy
= SCM_INUM (y
);
338 scm_num_overflow (s_modulo
);
340 return scm_divbigint (x
, yy
, yy
< 0,
341 (SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0)) ? 1 : 0);
343 } else if (SCM_BIGP (y
)) {
344 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
345 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
347 (SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
)) ? 1 : 0);
349 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
352 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
357 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
358 /* "Return the greatest common divisor of all arguments.\n"
359 * "If called without arguments, 0 is returned."
362 scm_gcd (SCM x
, SCM y
)
364 if (SCM_UNBNDP (y
)) {
365 if (SCM_UNBNDP (x
)) {
375 long xx
= SCM_INUM (x
);
376 long yy
= SCM_INUM (y
);
377 long u
= xx
< 0 ? -xx
: xx
;
378 long v
= yy
< 0 ? -yy
: yy
;
383 } else if (yy
== 0) {
389 /* Determine a common factor 2^k */
390 while (!(1 & (u
| v
))) {
396 /* Now, any factor 2^n can be eliminated */
416 if (SCM_POSFIXABLE (result
)) {
417 return SCM_MAKINUM (result
);
420 return scm_i_long2big (result
);
422 scm_num_overflow (s_gcd
);
425 } else if (SCM_BIGP (y
)) {
429 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
431 } else if (SCM_BIGP (x
)) {
434 x
= scm_i_copybig (x
, 0);
437 if (SCM_EQ_P (y
, SCM_INUM0
)) {
442 } else if (SCM_BIGP (y
)) {
444 y
= scm_i_copybig (y
, 0);
445 switch (scm_bigcomp (x
, y
))
450 SCM t
= scm_remainder (x
, y
);
456 y
= scm_remainder (y
, x
);
458 default: /* x == y */
461 /* instead of the switch, we could just
462 return scm_gcd (y, scm_modulo (x, y)); */
464 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
467 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
472 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
473 /* "Return the least common multiple of the arguments.\n"
474 * "If called without arguments, 1 is returned."
477 scm_lcm (SCM n1
, SCM n2
)
479 if (SCM_UNBNDP (n2
)) {
480 if (SCM_UNBNDP (n1
)) {
481 return SCM_MAKINUM (1L);
483 n2
= SCM_MAKINUM (1L);
488 SCM_GASSERT2 (SCM_INUMP (n1
), g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
489 SCM_GASSERT2 (SCM_INUMP (n2
), g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
491 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
492 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
493 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
494 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
498 SCM d
= scm_gcd (n1
, n2
);
499 if (SCM_EQ_P (d
, SCM_INUM0
)) {
502 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
509 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
511 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
515 /* Emulating 2's complement bignums with sign magnitude arithmetic:
520 + + + x (map digit:logand X Y)
521 + - + x (map digit:logand X (lognot (+ -1 Y)))
522 - + + y (map digit:logand (lognot (+ -1 X)) Y)
523 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
528 + + + (map digit:logior X Y)
529 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
530 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
531 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
536 + + + (map digit:logxor X Y)
537 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
538 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
539 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
544 + + (any digit:logand X Y)
545 + - (any digit:logand X (lognot (+ -1 Y)))
546 - + (any digit:logand (lognot (+ -1 X)) Y)
553 SCM
scm_copy_big_dec(SCM b
, int sign
);
554 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, size_t nx
, int zsgn
);
555 SCM
scm_big_ior(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
556 SCM
scm_big_xor(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
557 SCM
scm_big_and(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int zsgn
);
558 SCM
scm_big_test(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
560 SCM
scm_copy_big_dec(SCM b
, int sign
)
563 size_t nx
= SCM_NUMDIGS(b
);
565 SCM ans
= scm_i_mkbig(nx
, sign
);
566 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
567 if SCM_BIGSIGN(b
) do {
569 if (num
< 0) {dst
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
570 else {dst
[i
] = SCM_BIGLO(num
); num
= 0;}
573 while (nx
--) dst
[nx
] = src
[nx
];
577 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, size_t nx
, int zsgn
)
581 SCM z
= scm_i_mkbig(nx
, zsgn
);
582 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
585 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
586 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
588 else do zds
[i
] = x
[i
]; while (++i
< nx
);
592 SCM
scm_big_ior(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
593 /* Assumes nx <= SCM_NUMDIGS(bigy) */
594 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
597 size_t i
= 0, ny
= SCM_NUMDIGS(bigy
);
598 SCM z
= scm_copy_big_dec (bigy
, xsgn
& SCM_BIGSIGN (bigy
));
599 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
603 if (num
< 0) {zds
[i
] |= num
+ SCM_BIGRAD
; num
= -1;}
604 else {zds
[i
] |= SCM_BIGLO(num
); num
= 0;}
606 /* ========= Need to increment zds now =========== */
610 zds
[i
++] = SCM_BIGLO(num
);
611 num
= SCM_BIGDN(num
);
614 scm_i_adjbig(z
, 1 + ny
); /* OOPS, overflowed into next digit. */
615 SCM_BDIGITS(z
)[ny
] = 1;
618 else do zds
[i
] = zds
[i
] | x
[i
]; while (++i
< nx
);
622 SCM
scm_big_xor(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
623 /* Assumes nx <= SCM_NUMDIGS(bigy) */
624 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
627 size_t i
= 0, ny
= SCM_NUMDIGS(bigy
);
628 SCM z
= scm_copy_big_dec(bigy
, xsgn
^ SCM_BIGSIGN(bigy
));
629 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
632 if (num
< 0) {zds
[i
] ^= num
+ SCM_BIGRAD
; num
= -1;}
633 else {zds
[i
] ^= SCM_BIGLO(num
); num
= 0;}
636 zds
[i
] = zds
[i
] ^ x
[i
];
639 if (xsgn
^ SCM_BIGSIGN(bigy
)) {
640 /* ========= Need to increment zds now =========== */
644 zds
[i
++] = SCM_BIGLO(num
);
645 num
= SCM_BIGDN(num
);
646 if (!num
) return scm_i_normbig(z
);
649 return scm_i_normbig(z
);
652 SCM
scm_big_and(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int zsgn
)
653 /* Assumes nx <= SCM_NUMDIGS(bigy) */
654 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
655 /* return sign equals either 0 or SCM_BIGSIGNFLAG */
662 z
= scm_copy_smaller(x
, nx
, zsgn
);
663 x
= SCM_BDIGITS(bigy
);
664 xsgn
= SCM_BIGSIGN(bigy
);
666 else z
= scm_copy_big_dec(bigy
, zsgn
);
667 zds
= SCM_BDIGITS(z
);
672 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
673 else {zds
[i
] &= SCM_BIGLO(num
); num
= 0;}
675 else do zds
[i
] = zds
[i
] & ~x
[i
]; while (++i
< nx
);
676 /* ========= need to increment zds now =========== */
680 zds
[i
++] = SCM_BIGLO(num
);
681 num
= SCM_BIGDN(num
);
682 if (!num
) return scm_i_normbig(z
);
686 unsigned long int carry
= 1;
688 unsigned long int mask
= (SCM_BIGDIG
) ~x
[i
] + carry
;
689 zds
[i
] = zds
[i
] & (SCM_BIGDIG
) mask
;
690 carry
= (mask
>= SCM_BIGRAD
) ? 1 : 0;
692 } else do zds
[i
] = zds
[i
] & x
[i
]; while (++i
< nx
);
693 return scm_i_normbig(z
);
696 SCM
scm_big_test(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
697 /* Assumes nx <= SCM_NUMDIGS(bigy) */
698 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
703 if (SCM_BIGSIGN(bigy
) & xsgn
) return SCM_BOOL_T
;
704 if (SCM_NUMDIGS(bigy
) != nx
&& xsgn
) return SCM_BOOL_T
;
705 y
= SCM_BDIGITS(bigy
);
710 if (y
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
714 if (y
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
718 else if SCM_BIGSIGN(bigy
)
722 if (x
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
726 if (x
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
731 do if (x
[i
] & y
[i
]) return SCM_BOOL_T
;
738 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
740 "Return the bitwise AND of the integer arguments.\n\n"
742 "(logand) @result{} -1\n"
743 "(logand 7) @result{} 7\n"
744 "(logand #b111 #b011 #\b001) @result{} 1\n"
746 #define FUNC_NAME s_scm_logand
750 if (SCM_UNBNDP (n2
)) {
751 if (SCM_UNBNDP (n1
)) {
752 return SCM_MAKINUM (-1);
753 } else if (!SCM_NUMBERP (n1
)) {
754 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
756 } else if (SCM_NUMBERP (n1
)) {
759 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
767 if (SCM_INUMP (n1
)) {
769 if (SCM_INUMP (n2
)) {
770 long nn2
= SCM_INUM (n2
);
771 return SCM_MAKINUM (nn1
& nn2
);
772 } else if SCM_BIGP (n2
) {
775 # ifndef SCM_DIGSTOOBIG
776 long z
= scm_pseudolong (nn1
);
777 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
778 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
779 SCM_BIGSIGNFLAG
, n2
);
781 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
782 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
785 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
786 scm_longdigs (nn1
, zdigs
);
787 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
788 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
790 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
791 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
796 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
798 } else if (SCM_BIGP (n1
)) {
799 if (SCM_INUMP (n2
)) {
803 } else if (SCM_BIGP (n2
)) {
804 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
807 if ((SCM_BIGSIGN (n1
)) && SCM_BIGSIGN (n2
)) {
808 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
809 SCM_BIGSIGNFLAG
, n2
);
811 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
812 SCM_BIGSIGN (n1
), n2
, 0);
815 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
818 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
824 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
826 "Return the bitwise OR of the integer arguments.\n\n"
828 "(logior) @result{} 0\n"
829 "(logior 7) @result{} 7\n"
830 "(logior #b000 #b001 #b011) @result{} 3\n"
832 #define FUNC_NAME s_scm_logior
836 if (SCM_UNBNDP (n2
)) {
837 if (SCM_UNBNDP (n1
)) {
840 } else if (SCM_NUMBERP (n1
)) {
843 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
851 if (SCM_INUMP (n1
)) {
853 if (SCM_INUMP (n2
)) {
854 long nn2
= SCM_INUM (n2
);
855 return SCM_MAKINUM (nn1
| nn2
);
856 } else if (SCM_BIGP (n2
)) {
859 # ifndef SCM_DIGSTOOBIG
860 long z
= scm_pseudolong (nn1
);
861 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
862 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
863 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
865 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
866 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
869 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
870 scm_longdigs (nn1
, zdigs
);
871 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
872 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
,
873 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
875 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
876 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
881 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
883 } else if (SCM_BIGP (n1
)) {
884 if (SCM_INUMP (n2
)) {
888 } else if (SCM_BIGP (n2
)) {
889 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
892 if ((!SCM_BIGSIGN (n1
)) && !SCM_BIGSIGN (n2
)) {
893 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
894 SCM_BIGSIGN (n1
), n2
);
896 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
897 SCM_BIGSIGN (n1
), n2
, SCM_BIGSIGNFLAG
);
900 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
903 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
909 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
911 "Return the bitwise XOR of the integer arguments. A bit is\n"
912 "set in the result if it is set in an odd number of arguments.\n"
914 "(logxor) @result{} 0\n"
915 "(logxor 7) @result{} 7\n"
916 "(logxor #b000 #b001 #b011) @result{} 2\n"
917 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
919 #define FUNC_NAME s_scm_logxor
923 if (SCM_UNBNDP (n2
)) {
924 if (SCM_UNBNDP (n1
)) {
927 } else if (SCM_NUMBERP (n1
)) {
930 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
938 if (SCM_INUMP (n1
)) {
940 if (SCM_INUMP (n2
)) {
941 long nn2
= SCM_INUM (n2
);
942 return SCM_MAKINUM (nn1
^ nn2
);
943 } else if (SCM_BIGP (n2
)) {
946 # ifndef SCM_DIGSTOOBIG
947 long z
= scm_pseudolong (nn1
);
948 return scm_big_xor ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
949 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
951 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
952 scm_longdigs (nn1
, zdigs
);
953 return scm_big_xor (zdigs
, SCM_DIGSPERLONG
,
954 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
958 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
960 } else if (SCM_BIGP (n1
)) {
961 if (SCM_INUMP (n2
)) {
965 } else if (SCM_BIGP (n2
)) {
966 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {
969 return scm_big_xor (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
970 SCM_BIGSIGN (n1
), n2
);
972 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
975 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
981 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
984 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
985 "(logtest #b0100 #b1011) @result{} #f\n"
986 "(logtest #b0100 #b0111) @result{} #t\n"
988 #define FUNC_NAME s_scm_logtest
995 long nk
= SCM_INUM (k
);
996 return SCM_BOOL (nj
& nk
);
997 } else if (SCM_BIGP (k
)) {
1000 # ifndef SCM_DIGSTOOBIG
1001 long z
= scm_pseudolong (nj
);
1002 return scm_big_test ((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
1003 (nj
< 0) ? SCM_BIGSIGNFLAG
: 0, k
);
1005 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
1006 scm_longdigs (nj
, zdigs
);
1007 return scm_big_test (zdigs
, SCM_DIGSPERLONG
,
1008 (nj
< 0) ? SCM_BIGSIGNFLAG
: 0, k
);
1012 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1014 } else if (SCM_BIGP (j
)) {
1015 if (SCM_INUMP (k
)) {
1019 } else if (SCM_BIGP (k
)) {
1020 if (SCM_NUMDIGS (j
) > SCM_NUMDIGS (k
)) {
1023 return scm_big_test (SCM_BDIGITS (j
), SCM_NUMDIGS (j
),
1024 SCM_BIGSIGN (j
), k
);
1026 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1029 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
1035 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
1038 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1039 "(logbit? 0 #b1101) @result{} #t\n"
1040 "(logbit? 1 #b1101) @result{} #f\n"
1041 "(logbit? 2 #b1101) @result{} #t\n"
1042 "(logbit? 3 #b1101) @result{} #t\n"
1043 "(logbit? 4 #b1101) @result{} #f\n"
1045 #define FUNC_NAME s_scm_logbit_p
1047 unsigned long int iindex
;
1049 SCM_VALIDATE_INUM_MIN (SCM_ARG1
, index
, 0);
1050 iindex
= (unsigned long int) SCM_INUM (index
);
1052 if (SCM_INUMP (j
)) {
1053 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1054 } else if (SCM_BIGP (j
)) {
1055 if (SCM_NUMDIGS (j
) * SCM_BITSPERDIG
< iindex
) {
1057 } else if (SCM_BIGSIGN (j
)) {
1060 SCM_BIGDIG
* x
= SCM_BDIGITS (j
);
1061 size_t nx
= iindex
/ SCM_BITSPERDIG
;
1065 return SCM_BOOL (((1L << (iindex
% SCM_BITSPERDIG
)) & num
) == 0);
1066 } else if (num
< 0) {
1073 return SCM_BOOL (SCM_BDIGITS (j
) [iindex
/ SCM_BITSPERDIG
]
1074 & (1L << (iindex
% SCM_BITSPERDIG
)));
1077 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1083 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1085 "Return the integer which is the 2s-complement of the integer\n"
1089 "(number->string (lognot #b10000000) 2)\n"
1090 " @result{} \"-10000001\"\n"
1091 "(number->string (lognot #b0) 2)\n"
1092 " @result{} \"-1\"\n"
1094 #define FUNC_NAME s_scm_lognot
1096 return scm_difference (SCM_MAKINUM (-1L), n
);
1100 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1102 "Return @var{n} raised to the non-negative integer exponent\n"
1106 "(integer-expt 2 5)\n"
1108 "(integer-expt -3 3)\n"
1111 #define FUNC_NAME s_scm_integer_expt
1113 SCM acc
= SCM_MAKINUM (1L);
1116 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1118 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1119 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1121 SCM_VALIDATE_ULONG_COPY (2,k
,i2
);
1125 n
= scm_divide (n
, SCM_UNDEFINED
);
1132 return scm_product (acc
, n
);
1134 acc
= scm_product (acc
, n
);
1135 n
= scm_product (n
, n
);
1141 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1143 "The function ash performs an arithmetic shift left by @var{cnt}\n"
1144 "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n"
1145 "means, that the function does not guarantee to keep the bit\n"
1146 "structure of @var{n}, but rather guarantees that the result\n"
1147 "will always be rounded towards minus infinity. Therefore, the\n"
1148 "results of ash and a corresponding bitwise shift will differ if\n"
1149 "@var{n} is negative.\n"
1151 "Formally, the function returns an integer equivalent to\n"
1152 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n"
1155 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1156 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
1158 #define FUNC_NAME s_scm_ash
1163 SCM_VALIDATE_INUM (1, n
)
1165 SCM_VALIDATE_INUM (2, cnt
);
1167 bits_to_shift
= SCM_INUM (cnt
);
1169 if (bits_to_shift
< 0) {
1170 /* Shift right by abs(cnt) bits. This is realized as a division by
1171 div:=2^abs(cnt). However, to guarantee the floor rounding, negative
1172 values require some special treatment.
1174 SCM div
= scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift
));
1175 if (SCM_FALSEP (scm_negative_p (n
)))
1176 return scm_quotient (n
, div
);
1178 return scm_sum (SCM_MAKINUM (-1L),
1179 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1181 /* Shift left is done by multiplication with 2^CNT */
1182 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1184 if (bits_to_shift
< 0)
1185 /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */
1186 return SCM_MAKINUM (SCM_SRS (SCM_INUM (n
), -bits_to_shift
));
1188 /* Shift left, but make sure not to leave the range of inums */
1189 SCM res
= SCM_MAKINUM (SCM_INUM (n
) << cnt
);
1190 if (SCM_INUM (res
) >> cnt
!= SCM_INUM (n
))
1191 scm_num_overflow (FUNC_NAME
);
1199 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1200 (SCM n
, SCM start
, SCM end
),
1201 "Return the integer composed of the @var{start} (inclusive)\n"
1202 "through @var{end} (exclusive) bits of @var{n}. The\n"
1203 "@var{start}th bit becomes the 0-th bit in the result.\n"
1206 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1207 " @result{} \"1010\"\n"
1208 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1209 " @result{} \"10110\"\n"
1211 #define FUNC_NAME s_scm_bit_extract
1213 unsigned long int istart
, iend
;
1214 SCM_VALIDATE_INUM_MIN_COPY (2,start
,0,istart
);
1215 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1216 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1218 if (SCM_INUMP (n
)) {
1219 long int in
= SCM_INUM (n
);
1220 unsigned long int bits
= iend
- istart
;
1222 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
1224 /* Since we emulate two's complement encoded numbers, this special
1225 * case requires us to produce a result that has more bits than can be
1226 * stored in a fixnum. Thus, we fall back to the more general
1227 * algorithm that is used for bignums.
1232 if (istart
< SCM_I_FIXNUM_BIT
)
1235 if (bits
< SCM_I_FIXNUM_BIT
)
1236 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1237 else /* we know: in >= 0 */
1238 return SCM_MAKINUM (in
);
1242 return SCM_MAKINUM (-1L & ((1L << bits
) - 1));
1246 return SCM_MAKINUM (0);
1248 } else if (SCM_BIGP (n
)) {
1251 SCM num1
= SCM_MAKINUM (1L);
1252 SCM num2
= SCM_MAKINUM (2L);
1253 SCM bits
= SCM_MAKINUM (iend
- istart
);
1254 SCM mask
= scm_difference (scm_integer_expt (num2
, bits
), num1
);
1255 return scm_logand (mask
, scm_ash (n
, SCM_MAKINUM (-istart
)));
1258 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1264 static const char scm_logtab
[] = {
1265 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1268 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1270 "Return the number of bits in integer @var{n}. If integer is\n"
1271 "positive, the 1-bits in its binary representation are counted.\n"
1272 "If negative, the 0-bits in its two's-complement binary\n"
1273 "representation are counted. If 0, 0 is returned.\n"
1276 "(logcount #b10101010)\n"
1283 #define FUNC_NAME s_scm_logcount
1285 if (SCM_INUMP (n
)) {
1286 unsigned long int c
= 0;
1287 long int nn
= SCM_INUM (n
);
1292 c
+= scm_logtab
[15 & nn
];
1295 return SCM_MAKINUM (c
);
1296 } else if (SCM_BIGP (n
)) {
1297 if (SCM_BIGSIGN (n
)) {
1298 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n
));
1300 unsigned long int c
= 0;
1301 size_t i
= SCM_NUMDIGS (n
);
1302 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1305 for (d
= ds
[i
]; d
; d
>>= 4) {
1306 c
+= scm_logtab
[15 & d
];
1309 return SCM_MAKINUM (c
);
1312 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1318 static const char scm_ilentab
[] = {
1319 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1322 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1324 "Return the number of bits neccessary to represent @var{n}.\n"
1327 "(integer-length #b10101010)\n"
1329 "(integer-length 0)\n"
1331 "(integer-length #b1111)\n"
1334 #define FUNC_NAME s_scm_integer_length
1336 if (SCM_INUMP (n
)) {
1337 unsigned long int c
= 0;
1339 long int nn
= SCM_INUM (n
);
1345 l
= scm_ilentab
[15 & nn
];
1348 return SCM_MAKINUM (c
- 4 + l
);
1349 } else if (SCM_BIGP (n
)) {
1350 if (SCM_BIGSIGN (n
)) {
1351 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n
));
1353 unsigned long int digs
= SCM_NUMDIGS (n
) - 1;
1354 unsigned long int c
= digs
* SCM_BITSPERDIG
;
1356 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1357 SCM_BIGDIG d
= ds
[digs
];
1360 l
= scm_ilentab
[15 & d
];
1363 return SCM_MAKINUM (c
- 4 + l
);
1366 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1373 static const char s_bignum
[] = "bignum";
1376 scm_i_mkbig (size_t nlen
, int sign
)
1381 if (((nlen
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1382 scm_memory_error (s_bignum
);
1384 base
= scm_must_malloc (nlen
* sizeof (SCM_BIGDIG
), s_bignum
);
1387 SCM_SET_BIGNUM_BASE (v
, base
);
1388 SCM_SETNUMDIGS (v
, nlen
, sign
);
1393 scm_i_big2inum (SCM b
, size_t l
)
1395 unsigned long num
= 0;
1396 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1398 num
= SCM_BIGUP (num
) + tmp
[l
];
1399 if (!SCM_BIGSIGN (b
))
1401 if (SCM_POSFIXABLE (num
))
1402 return SCM_MAKINUM (num
);
1404 else if (num
<= -SCM_MOST_NEGATIVE_FIXNUM
)
1405 return SCM_MAKINUM (-num
);
1409 static const char s_adjbig
[] = "scm_i_adjbig";
1412 scm_i_adjbig (SCM b
, size_t nlen
)
1415 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1416 scm_memory_error (s_adjbig
);
1422 scm_must_realloc ((char *) SCM_BDIGITS (b
),
1423 (long) (SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
)),
1424 (long) (nsiz
* sizeof (SCM_BIGDIG
)), s_bignum
));
1426 SCM_SET_BIGNUM_BASE (b
, digits
);
1427 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1434 scm_i_normbig (SCM b
)
1437 size_t nlen
= SCM_NUMDIGS (b
);
1439 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1441 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1442 while (nlen
-- && !zds
[nlen
]);
1444 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1445 if (SCM_INUMP (b
= scm_i_big2inum (b
, (size_t) nlen
)))
1447 if (SCM_NUMDIGS (b
) == nlen
)
1449 return scm_i_adjbig (b
, (size_t) nlen
);
1453 scm_i_copybig (SCM b
, int sign
)
1455 size_t i
= SCM_NUMDIGS (b
);
1456 SCM ans
= scm_i_mkbig (i
, sign
);
1457 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1464 scm_bigcomp (SCM x
, SCM y
)
1466 int xsign
= SCM_BIGSIGN (x
);
1467 int ysign
= SCM_BIGSIGN (y
);
1470 /* Look at the signs, first. */
1476 /* They're the same sign, so see which one has more digits. Note
1477 that, if they are negative, the longer number is the lesser. */
1478 ylen
= SCM_NUMDIGS (y
);
1479 xlen
= SCM_NUMDIGS (x
);
1481 return (xsign
) ? -1 : 1;
1483 return (xsign
) ? 1 : -1;
1485 /* They have the same number of digits, so find the most significant
1486 digit where they differ. */
1490 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1491 /* Make the discrimination based on the digit that differs. */
1492 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1494 : (xsign
? 1 : -1));
1497 /* The numbers are identical. */
1501 #ifndef SCM_DIGSTOOBIG
1505 scm_pseudolong (long x
)
1510 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1516 while (i
< SCM_DIGSPERLONG
)
1518 p
.bd
[i
++] = SCM_BIGLO (x
);
1521 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1529 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1534 while (i
< SCM_DIGSPERLONG
)
1536 digs
[i
++] = SCM_BIGLO (x
);
1545 scm_addbig (SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int sgny
)
1547 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1548 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1550 size_t i
= 0, ny
= SCM_NUMDIGS (bigy
);
1551 SCM z
= scm_i_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1552 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1553 if (xsgn
^ SCM_BIGSIGN (z
))
1557 num
+= (long) zds
[i
] - x
[i
];
1560 zds
[i
] = num
+ SCM_BIGRAD
;
1565 zds
[i
] = SCM_BIGLO (num
);
1570 if (num
&& nx
== ny
)
1574 SCM_SET_CELL_WORD_0 (z
, SCM_CELL_WORD_0 (z
) ^ SCM_BIGSIGNFLAG
);
1577 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1578 zds
[i
++] = SCM_BIGLO (num
);
1579 num
= SCM_BIGDN (num
);
1589 zds
[i
++] = num
+ SCM_BIGRAD
;
1594 zds
[i
++] = SCM_BIGLO (num
);
1603 num
+= (long) zds
[i
] + x
[i
];
1604 zds
[i
++] = SCM_BIGLO (num
);
1605 num
= SCM_BIGDN (num
);
1613 zds
[i
++] = SCM_BIGLO (num
);
1614 num
= SCM_BIGDN (num
);
1620 z
= scm_i_adjbig (z
, ny
+ 1);
1621 SCM_BDIGITS (z
)[ny
] = num
;
1625 return scm_i_normbig (z
);
1630 scm_mulbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
)
1632 size_t i
= 0, j
= nx
+ ny
;
1633 unsigned long n
= 0;
1634 SCM z
= scm_i_mkbig (j
, sgn
);
1635 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1645 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1646 zds
[i
+ j
++] = SCM_BIGLO (n
);
1658 return scm_i_normbig (z
);
1663 scm_divbigdig (SCM_BIGDIG
* ds
, size_t h
, SCM_BIGDIG div
)
1665 register unsigned long t2
= 0;
1668 t2
= SCM_BIGUP (t2
) + ds
[h
];
1678 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1684 register unsigned long t2
= 0;
1685 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1686 size_t nd
= SCM_NUMDIGS (x
);
1688 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1691 return SCM_MAKINUM (sgn
? -t2
: t2
);
1694 #ifndef SCM_DIGSTOOBIG
1695 unsigned long t2
= scm_pseudolong (z
);
1696 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1697 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1700 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1701 scm_longdigs (z
, t2
);
1702 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1703 t2
, SCM_DIGSPERLONG
,
1711 scm_divbigbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
, int modes
)
1713 /* modes description
1717 3 quotient but returns SCM_UNDEFINED if division is not exact. */
1718 size_t i
= 0, j
= 0;
1720 unsigned long t2
= 0;
1722 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1723 /* algorithm requires nx >= ny */
1727 case 0: /* remainder -- just return x */
1728 z
= scm_i_mkbig (nx
, sgn
);
1729 zds
= SCM_BDIGITS (z
);
1736 case 1: /* scm_modulo -- return y-x */
1737 z
= scm_i_mkbig (ny
, sgn
);
1738 zds
= SCM_BDIGITS (z
);
1741 num
+= (long) y
[i
] - x
[i
];
1744 zds
[i
] = num
+ SCM_BIGRAD
;
1759 zds
[i
++] = num
+ SCM_BIGRAD
;
1770 return SCM_INUM0
; /* quotient is zero */
1772 return SCM_UNDEFINED
; /* the division is not exact */
1775 z
= scm_i_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1776 zds
= SCM_BDIGITS (z
);
1780 ny
--; /* in case y came in as a psuedolong */
1781 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1782 { /* normalize operands */
1783 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1784 newy
= scm_i_mkbig (ny
, 0);
1785 yds
= SCM_BDIGITS (newy
);
1788 t2
+= (unsigned long) y
[j
] * d
;
1789 yds
[j
++] = SCM_BIGLO (t2
);
1790 t2
= SCM_BIGDN (t2
);
1797 t2
+= (unsigned long) x
[j
] * d
;
1798 zds
[j
++] = SCM_BIGLO (t2
);
1799 t2
= SCM_BIGDN (t2
);
1809 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1811 { /* loop over digits of quotient */
1812 if (zds
[j
] == y
[ny
- 1])
1813 qhat
= SCM_BIGRAD
- 1;
1815 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1822 { /* multiply and subtract */
1823 t2
+= (unsigned long) y
[i
] * qhat
;
1824 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1827 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1832 zds
[j
- ny
+ i
] = num
;
1835 t2
= SCM_BIGDN (t2
);
1838 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1840 { /* "add back" required */
1846 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1847 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1848 num
= SCM_BIGDN (num
);
1859 case 3: /* check that remainder==0 */
1860 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1862 return SCM_UNDEFINED
;
1863 case 2: /* move quotient down in z */
1864 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
1865 for (i
= 0; i
< j
; i
++)
1866 zds
[i
] = zds
[i
+ ny
];
1869 case 1: /* subtract for scm_modulo */
1875 num
+= y
[i
] - zds
[i
];
1879 zds
[i
] = num
+ SCM_BIGRAD
;
1891 case 0: /* just normalize remainder */
1893 scm_divbigdig (zds
, ny
, d
);
1896 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1897 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
1898 if (SCM_INUMP (z
= scm_i_big2inum (z
, j
)))
1900 return scm_i_adjbig (z
, j
);
1908 /*** NUMBERS -> STRINGS ***/
1910 static const double fx
[] =
1911 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1912 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1913 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1914 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1920 idbl2str (double f
, char *a
)
1922 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1927 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1946 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1947 make-uniform-vector, from causing infinite loops. */
1951 if (exp
-- < DBL_MIN_10_EXP
)
1957 if (exp
++ > DBL_MAX_10_EXP
)
1972 if (f
+ fx
[wp
] >= 10.0)
1979 dpt
= (exp
+ 9999) % 3;
1983 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2008 if (f
+ fx
[wp
] >= 1.0)
2022 if ((dpt
> 4) && (exp
> 6))
2024 d
= (a
[0] == '-' ? 2 : 1);
2025 for (i
= ch
++; i
> d
; i
--)
2038 if (a
[ch
- 1] == '.')
2039 a
[ch
++] = '0'; /* trailing zero */
2048 for (i
= 10; i
<= exp
; i
*= 10);
2049 for (i
/= 10; i
; i
/= 10)
2051 a
[ch
++] = exp
/ i
+ '0';
2060 iflo2str (SCM flt
, char *str
)
2063 if (SCM_REALP (flt
))
2064 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2067 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2068 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2070 if (0 <= SCM_COMPLEX_IMAG (flt
))
2072 i
+= idbl2str (SCM_COMPLEX_IMAG (flt
), &str
[i
]);
2079 /* convert a long to a string (unterminated). returns the number of
2080 characters in the result.
2082 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2084 scm_iint2str (long num
, int rad
, char *p
)
2088 unsigned long n
= (num
< 0) ? -num
: num
;
2090 for (n
/= rad
; n
> 0; n
/= rad
)
2107 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2116 big2str (SCM b
, unsigned int radix
)
2118 SCM t
= scm_i_copybig (b
, 0); /* sign of temp doesn't matter */
2119 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2120 size_t i
= SCM_NUMDIGS (t
);
2121 size_t j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2122 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2123 : (SCM_BITSPERDIG
* i
) + 2;
2126 SCM_BIGDIG radpow
= 1, radmod
= 0;
2127 SCM ss
= scm_allocate_string (j
);
2128 char *s
= SCM_STRING_CHARS (ss
), c
;
2129 while ((long) radpow
* radix
< SCM_BIGRAD
)
2134 while ((i
|| radmod
) && j
)
2138 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2146 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2149 if (SCM_BIGSIGN (b
))
2154 /* The pre-reserved string length was too large. */
2155 unsigned long int length
= SCM_STRING_LENGTH (ss
);
2156 ss
= scm_substring (ss
, SCM_MAKINUM (j
), SCM_MAKINUM (length
));
2159 return scm_return_first (ss
, t
);
2164 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2166 "Return a string holding the external representation of the\n"
2167 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2168 "inexact, a radix of 10 will be used.")
2169 #define FUNC_NAME s_scm_number_to_string
2173 if (SCM_UNBNDP (radix
)) {
2176 SCM_VALIDATE_INUM (2, radix
);
2177 base
= SCM_INUM (radix
);
2178 SCM_ASSERT_RANGE (2, radix
, base
>= 2);
2181 if (SCM_INUMP (n
)) {
2182 char num_buf
[SCM_INTBUFLEN
];
2183 size_t length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2184 return scm_mem2string (num_buf
, length
);
2185 } else if (SCM_BIGP (n
)) {
2186 return big2str (n
, (unsigned int) base
);
2187 } else if (SCM_INEXACTP (n
)) {
2188 char num_buf
[FLOBUFLEN
];
2189 return scm_mem2string (num_buf
, iflo2str (n
, num_buf
));
2191 SCM_WRONG_TYPE_ARG (1, n
);
2197 /* These print routines are stubbed here so that scm_repl.c doesn't need
2198 SCM_BIGDIG conditionals */
2201 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2203 char num_buf
[FLOBUFLEN
];
2204 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2209 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2211 char num_buf
[FLOBUFLEN
];
2212 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2217 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2220 exp
= big2str (exp
, (unsigned int) 10);
2221 scm_lfwrite (SCM_STRING_CHARS (exp
), (size_t) SCM_STRING_LENGTH (exp
), port
);
2223 scm_ipruk ("bignum", exp
, port
);
2227 /*** END nums->strs ***/
2230 /*** STRINGS -> NUMBERS ***/
2232 /* The following functions implement the conversion from strings to numbers.
2233 * The implementation somehow follows the grammar for numbers as it is given
2234 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
2235 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
2236 * points should be noted about the implementation:
2237 * * Each function keeps a local index variable 'idx' that points at the
2238 * current position within the parsed string. The global index is only
2239 * updated if the function could parse the corresponding syntactic unit
2241 * * Similarly, the functions keep track of indicators of inexactness ('#',
2242 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
2243 * global exactness information is only updated after each part has been
2244 * successfully parsed.
2245 * * Sequences of digits are parsed into temporary variables holding fixnums.
2246 * Only if these fixnums would overflow, the result variables are updated
2247 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
2248 * the temporary variables holding the fixnums are cleared, and the process
2249 * starts over again. If for example fixnums were able to store five decimal
2250 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
2251 * and the result was computed as 12345 * 100000 + 67890. In other words,
2252 * only every five digits two bignum operations were performed.
2255 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
2257 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
2259 /* In non ASCII-style encodings the following macro might not work. */
2260 #define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
2263 mem2uinteger (const char* mem
, size_t len
, unsigned int *p_idx
,
2264 unsigned int radix
, enum t_exactness
*p_exactness
)
2266 unsigned int idx
= *p_idx
;
2267 unsigned int hash_seen
= 0;
2268 scm_t_bits shift
= 1;
2270 unsigned int digit_value
;
2280 digit_value
= XDIGIT2UINT (c
);
2281 if (digit_value
>= radix
)
2285 result
= SCM_MAKINUM (digit_value
);
2293 digit_value
= XDIGIT2UINT (c
);
2294 if (digit_value
>= radix
)
2306 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
2308 result
= scm_product (result
, SCM_MAKINUM (shift
));
2310 result
= scm_sum (result
, SCM_MAKINUM (add
));
2317 shift
= shift
* radix
;
2318 add
= add
* radix
+ digit_value
;
2323 result
= scm_product (result
, SCM_MAKINUM (shift
));
2325 result
= scm_sum (result
, SCM_MAKINUM (add
));
2329 *p_exactness
= INEXACT
;
2335 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2336 * covers the parts of the rules that start at a potential point. The value
2337 * of the digits up to the point have been parsed by the caller and are given
2338 * in variable prepoint. The content of *p_exactness indicates, whether a
2339 * hash has already been seen in the digits before the point.
2342 /* In non ASCII-style encodings the following macro might not work. */
2343 #define DIGIT2UINT(d) ((d) - '0')
2346 mem2decimal_from_point (SCM prepoint
, const char* mem
, size_t len
,
2347 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
2349 unsigned int idx
= *p_idx
;
2350 enum t_exactness x
= *p_exactness
;
2351 SCM big_shift
= SCM_MAKINUM (1);
2352 SCM big_add
= SCM_MAKINUM (0);
2358 if (mem
[idx
] == '.')
2360 scm_t_bits shift
= 1;
2362 unsigned int digit_value
;
2373 digit_value
= DIGIT2UINT (c
);
2384 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
2386 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2387 big_add
= scm_product (big_add
, SCM_MAKINUM (shift
));
2389 big_add
= scm_sum (big_add
, SCM_MAKINUM (add
));
2397 add
= add
* 10 + digit_value
;
2403 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2404 big_add
= scm_product (big_add
, SCM_MAKINUM (shift
));
2405 big_add
= scm_sum (big_add
, SCM_MAKINUM (add
));
2408 /* We've seen a decimal point, thus the value is implicitly inexact. */
2412 big_add
= scm_divide (big_add
, big_shift
);
2413 result
= scm_sum (prepoint
, big_add
);
2423 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2454 exponent
= DIGIT2UINT (c
);
2461 if (exponent
<= SCM_MAXEXP
)
2462 exponent
= exponent
* 10 + DIGIT2UINT (c
);
2468 if (exponent
> SCM_MAXEXP
)
2470 size_t exp_len
= idx
- start
;
2471 SCM exp_string
= scm_mem2string (&mem
[start
], exp_len
);
2472 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
2473 scm_out_of_range ("string->number", exp_num
);
2476 e
= scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent
));
2478 result
= scm_product (result
, e
);
2480 result
= scm_divide (result
, e
);
2482 /* We've seen an exponent, thus the value is implicitly inexact. */
2500 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2503 mem2ureal (const char* mem
, size_t len
, unsigned int *p_idx
,
2504 unsigned int radix
, enum t_exactness
*p_exactness
)
2506 unsigned int idx
= *p_idx
;
2511 if (mem
[idx
] == '.')
2515 else if (idx
+ 1 == len
)
2517 else if (!isdigit (mem
[idx
+ 1]))
2520 return mem2decimal_from_point (SCM_MAKINUM (0), mem
, len
,
2521 p_idx
, p_exactness
);
2525 enum t_exactness x
= EXACT
;
2529 uinteger
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2530 if (SCM_FALSEP (uinteger
))
2535 else if (mem
[idx
] == '/')
2541 divisor
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2542 if (SCM_FALSEP (divisor
))
2545 result
= scm_divide (uinteger
, divisor
);
2547 else if (radix
== 10)
2549 result
= mem2decimal_from_point (uinteger
, mem
, len
, &idx
, &x
);
2550 if (SCM_FALSEP (result
))
2565 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2568 mem2complex (const char* mem
, size_t len
, unsigned int idx
,
2569 unsigned int radix
, enum t_exactness
*p_exactness
)
2593 ureal
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2594 if (SCM_FALSEP (ureal
))
2596 /* input must be either +i or -i */
2601 if (mem
[idx
] == 'i' || mem
[idx
] == 'I')
2607 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign
));
2615 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
2624 /* either +<ureal>i or -<ureal>i */
2631 return scm_make_rectangular (SCM_MAKINUM (0), ureal
);
2634 /* polar input: <real>@<real>. */
2659 angle
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2660 if (SCM_FALSEP (angle
))
2666 angle
= scm_difference (angle
, SCM_UNDEFINED
);
2668 result
= scm_make_polar (ureal
, angle
);
2673 /* expecting input matching <real>[+-]<ureal>?i */
2680 int sign
= (c
== '+') ? 1 : -1;
2681 SCM imag
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2684 if (SCM_FALSEP (imag
))
2685 imag
= SCM_MAKINUM (sign
);
2689 if (mem
[idx
] != 'i' && mem
[idx
] != 'I')
2697 imag
= scm_difference (imag
, SCM_UNDEFINED
);
2698 result
= scm_make_rectangular (ureal
, imag
);
2708 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2710 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
2713 scm_i_mem2number (const char* mem
, size_t len
, unsigned int default_radix
)
2715 unsigned int idx
= 0;
2716 unsigned int radix
= NO_RADIX
;
2717 enum t_exactness forced_x
= NO_EXACTNESS
;
2718 enum t_exactness implicit_x
= EXACT
;
2721 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2722 while (idx
+ 2 < len
&& mem
[idx
] == '#')
2724 switch (mem
[idx
+ 1])
2727 if (radix
!= NO_RADIX
)
2732 if (radix
!= NO_RADIX
)
2737 if (forced_x
!= NO_EXACTNESS
)
2742 if (forced_x
!= NO_EXACTNESS
)
2747 if (radix
!= NO_RADIX
)
2752 if (radix
!= NO_RADIX
)
2762 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2763 if (radix
== NO_RADIX
)
2764 result
= mem2complex (mem
, len
, idx
, default_radix
, &implicit_x
);
2766 result
= mem2complex (mem
, len
, idx
, (unsigned int) radix
, &implicit_x
);
2768 if (SCM_FALSEP (result
))
2774 if (SCM_INEXACTP (result
))
2775 /* FIXME: This may change the value. */
2776 return scm_inexact_to_exact (result
);
2780 if (SCM_INEXACTP (result
))
2783 return scm_exact_to_inexact (result
);
2786 if (implicit_x
== INEXACT
)
2788 if (SCM_INEXACTP (result
))
2791 return scm_exact_to_inexact (result
);
2799 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2800 (SCM string
, SCM radix
),
2801 "Return a number of the maximally precise representation\n"
2802 "expressed by the given @var{string}. @var{radix} must be an\n"
2803 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2804 "is a default radix that may be overridden by an explicit radix\n"
2805 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2806 "supplied, then the default radix is 10. If string is not a\n"
2807 "syntactically valid notation for a number, then\n"
2808 "@code{string->number} returns @code{#f}.")
2809 #define FUNC_NAME s_scm_string_to_number
2813 SCM_VALIDATE_STRING (1, string
);
2814 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2815 answer
= scm_i_mem2number (SCM_STRING_CHARS (string
),
2816 SCM_STRING_LENGTH (string
),
2818 return scm_return_first (answer
, string
);
2823 /*** END strs->nums ***/
2827 scm_make_real (double x
)
2831 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
2832 SCM_REAL_VALUE (z
) = x
;
2838 scm_make_complex (double x
, double y
)
2841 return scm_make_real (x
);
2844 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_must_malloc (2L * sizeof (double), "complex"));
2845 SCM_COMPLEX_REAL (z
) = x
;
2846 SCM_COMPLEX_IMAG (z
) = y
;
2853 scm_bigequal (SCM x
, SCM y
)
2856 if (0 == scm_bigcomp (x
, y
))
2863 scm_real_equalp (SCM x
, SCM y
)
2865 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2869 scm_complex_equalp (SCM x
, SCM y
)
2871 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2872 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2877 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2878 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2879 * "else. Note that the sets of complex, real, rational and\n"
2880 * "integer values form subsets of the set of numbers, i. e. the\n"
2881 * "predicate will be fulfilled for any number."
2883 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2885 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2886 "else. Note that the sets of real, rational and integer\n"
2887 "values form subsets of the set of complex numbers, i. e. the\n"
2888 "predicate will also be fulfilled if @var{x} is a real,\n"
2889 "rational or integer number.")
2890 #define FUNC_NAME s_scm_number_p
2892 return SCM_BOOL (SCM_NUMBERP (x
));
2897 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2898 /* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
2899 * "Note that the sets of integer and rational values form a subset\n"
2900 * "of the set of real numbers, i. e. the predicate will also\n"
2901 * "be fulfilled if @var{x} is an integer or a rational number."
2903 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2905 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
2906 "else. Note that the set of integer values forms a subset of\n"
2907 "the set of rational numbers, i. e. the predicate will also be\n"
2908 "fulfilled if @var{x} is an integer number. Real numbers\n"
2909 "will also satisfy this predicate, because of their limited\n"
2911 #define FUNC_NAME s_scm_real_p
2913 if (SCM_INUMP (x
)) {
2915 } else if (SCM_IMP (x
)) {
2917 } else if (SCM_REALP (x
)) {
2919 } else if (SCM_BIGP (x
)) {
2928 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2930 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2932 #define FUNC_NAME s_scm_integer_p
2941 if (!SCM_INEXACTP (x
))
2943 if (SCM_COMPLEXP (x
))
2945 r
= SCM_REAL_VALUE (x
);
2953 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
2955 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
2957 #define FUNC_NAME s_scm_inexact_p
2959 return SCM_BOOL (SCM_INEXACTP (x
));
2964 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
2965 /* "Return @code{#t} if all parameters are numerically equal." */
2967 scm_num_eq_p (SCM x
, SCM y
)
2969 if (SCM_INUMP (x
)) {
2970 long xx
= SCM_INUM (x
);
2971 if (SCM_INUMP (y
)) {
2972 long yy
= SCM_INUM (y
);
2973 return SCM_BOOL (xx
== yy
);
2974 } else if (SCM_BIGP (y
)) {
2976 } else if (SCM_REALP (y
)) {
2977 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
2978 } else if (SCM_COMPLEXP (y
)) {
2979 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
2980 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2982 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2984 } else if (SCM_BIGP (x
)) {
2985 if (SCM_INUMP (y
)) {
2987 } else if (SCM_BIGP (y
)) {
2988 return SCM_BOOL (0 == scm_bigcomp (x
, y
));
2989 } else if (SCM_REALP (y
)) {
2990 return SCM_BOOL (scm_i_big2dbl (x
) == SCM_REAL_VALUE (y
));
2991 } else if (SCM_COMPLEXP (y
)) {
2992 return SCM_BOOL ((scm_i_big2dbl (x
) == SCM_COMPLEX_REAL (y
))
2993 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2995 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2997 } else if (SCM_REALP (x
)) {
2998 if (SCM_INUMP (y
)) {
2999 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3000 } else if (SCM_BIGP (y
)) {
3001 return SCM_BOOL (SCM_REAL_VALUE (x
) == scm_i_big2dbl (y
));
3002 } else if (SCM_REALP (y
)) {
3003 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3004 } else if (SCM_COMPLEXP (y
)) {
3005 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3006 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3008 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3010 } else if (SCM_COMPLEXP (x
)) {
3011 if (SCM_INUMP (y
)) {
3012 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3013 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3014 } else if (SCM_BIGP (y
)) {
3015 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == scm_i_big2dbl (y
))
3016 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3017 } else if (SCM_REALP (y
)) {
3018 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3019 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3020 } else if (SCM_COMPLEXP (y
)) {
3021 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3022 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3024 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3027 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3032 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3033 /* "Return @code{#t} if the list of parameters is monotonically\n"
3037 scm_less_p (SCM x
, SCM y
)
3039 if (SCM_INUMP (x
)) {
3040 long xx
= SCM_INUM (x
);
3041 if (SCM_INUMP (y
)) {
3042 long yy
= SCM_INUM (y
);
3043 return SCM_BOOL (xx
< yy
);
3044 } else if (SCM_BIGP (y
)) {
3045 return SCM_BOOL (!SCM_BIGSIGN (y
));
3046 } else if (SCM_REALP (y
)) {
3047 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3049 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3051 } else if (SCM_BIGP (x
)) {
3052 if (SCM_INUMP (y
)) {
3053 return SCM_BOOL (SCM_BIGSIGN (x
));
3054 } else if (SCM_BIGP (y
)) {
3055 return SCM_BOOL (1 == scm_bigcomp (x
, y
));
3056 } else if (SCM_REALP (y
)) {
3057 return SCM_BOOL (scm_i_big2dbl (x
) < SCM_REAL_VALUE (y
));
3059 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_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_i_big2dbl (y
));
3066 } else if (SCM_REALP (y
)) {
3067 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3069 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3072 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3077 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3078 /* "Return @code{#t} if the list of parameters is monotonically\n"
3081 #define FUNC_NAME s_scm_gr_p
3083 scm_gr_p (SCM x
, SCM y
)
3085 if (!SCM_NUMBERP (x
))
3086 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3087 else if (!SCM_NUMBERP (y
))
3088 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3090 return scm_less_p (y
, x
);
3095 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3096 /* "Return @code{#t} if the list of parameters is monotonically\n"
3099 #define FUNC_NAME s_scm_leq_p
3101 scm_leq_p (SCM x
, SCM y
)
3103 if (!SCM_NUMBERP (x
))
3104 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3105 else if (!SCM_NUMBERP (y
))
3106 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3108 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3113 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3114 /* "Return @code{#t} if the list of parameters is monotonically\n"
3117 #define FUNC_NAME s_scm_geq_p
3119 scm_geq_p (SCM x
, SCM y
)
3121 if (!SCM_NUMBERP (x
))
3122 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3123 else if (!SCM_NUMBERP (y
))
3124 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3126 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3131 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3132 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3138 if (SCM_INUMP (z
)) {
3139 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3140 } else if (SCM_BIGP (z
)) {
3142 } else if (SCM_REALP (z
)) {
3143 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3144 } else if (SCM_COMPLEXP (z
)) {
3145 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3146 && SCM_COMPLEX_IMAG (z
) == 0.0);
3148 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3153 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3154 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3158 scm_positive_p (SCM x
)
3160 if (SCM_INUMP (x
)) {
3161 return SCM_BOOL (SCM_INUM (x
) > 0);
3162 } else if (SCM_BIGP (x
)) {
3163 return SCM_BOOL (!SCM_BIGSIGN (x
));
3164 } else if (SCM_REALP (x
)) {
3165 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3167 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3172 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3173 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3177 scm_negative_p (SCM x
)
3179 if (SCM_INUMP (x
)) {
3180 return SCM_BOOL (SCM_INUM (x
) < 0);
3181 } else if (SCM_BIGP (x
)) {
3182 return SCM_BOOL (SCM_BIGSIGN (x
));
3183 } else if (SCM_REALP (x
)) {
3184 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3186 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3191 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3192 /* "Return the maximum of all parameter values."
3195 scm_max (SCM x
, SCM y
)
3197 if (SCM_UNBNDP (y
)) {
3198 if (SCM_UNBNDP (x
)) {
3199 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
3200 } else if (SCM_NUMBERP (x
)) {
3203 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3207 if (SCM_INUMP (x
)) {
3208 long xx
= SCM_INUM (x
);
3209 if (SCM_INUMP (y
)) {
3210 long yy
= SCM_INUM (y
);
3211 return (xx
< yy
) ? y
: x
;
3212 } else if (SCM_BIGP (y
)) {
3213 return SCM_BIGSIGN (y
) ? x
: y
;
3214 } else if (SCM_REALP (y
)) {
3216 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3218 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3220 } else if (SCM_BIGP (x
)) {
3221 if (SCM_INUMP (y
)) {
3222 return SCM_BIGSIGN (x
) ? y
: x
;
3223 } else if (SCM_BIGP (y
)) {
3224 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3225 } else if (SCM_REALP (y
)) {
3226 double z
= scm_i_big2dbl (x
);
3227 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3229 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3231 } else if (SCM_REALP (x
)) {
3232 if (SCM_INUMP (y
)) {
3233 double z
= SCM_INUM (y
);
3234 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3235 } else if (SCM_BIGP (y
)) {
3236 double z
= scm_i_big2dbl (y
);
3237 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3238 } else if (SCM_REALP (y
)) {
3239 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? y
: x
;
3241 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3244 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3249 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3250 /* "Return the minium of all parameter values."
3253 scm_min (SCM x
, SCM y
)
3255 if (SCM_UNBNDP (y
)) {
3256 if (SCM_UNBNDP (x
)) {
3257 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
3258 } else if (SCM_NUMBERP (x
)) {
3261 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3265 if (SCM_INUMP (x
)) {
3266 long xx
= SCM_INUM (x
);
3267 if (SCM_INUMP (y
)) {
3268 long yy
= SCM_INUM (y
);
3269 return (xx
< yy
) ? x
: y
;
3270 } else if (SCM_BIGP (y
)) {
3271 return SCM_BIGSIGN (y
) ? y
: x
;
3272 } else if (SCM_REALP (y
)) {
3274 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3276 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3278 } else if (SCM_BIGP (x
)) {
3279 if (SCM_INUMP (y
)) {
3280 return SCM_BIGSIGN (x
) ? x
: y
;
3281 } else if (SCM_BIGP (y
)) {
3282 return (-1 == scm_bigcomp (x
, y
)) ? y
: x
;
3283 } else if (SCM_REALP (y
)) {
3284 double z
= scm_i_big2dbl (x
);
3285 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3287 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3289 } else if (SCM_REALP (x
)) {
3290 if (SCM_INUMP (y
)) {
3291 double z
= SCM_INUM (y
);
3292 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3293 } else if (SCM_BIGP (y
)) {
3294 double z
= scm_i_big2dbl (y
);
3295 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3296 } else if (SCM_REALP (y
)) {
3297 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? x
: y
;
3299 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3302 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3307 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3308 /* "Return the sum of all parameter values. Return 0 if called without\n"
3312 scm_sum (SCM x
, SCM y
)
3314 if (SCM_UNBNDP (y
)) {
3315 if (SCM_UNBNDP (x
)) {
3317 } else if (SCM_NUMBERP (x
)) {
3320 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3324 if (SCM_INUMP (x
)) {
3325 long int xx
= SCM_INUM (x
);
3326 if (SCM_INUMP (y
)) {
3327 long int yy
= SCM_INUM (y
);
3328 long int z
= xx
+ yy
;
3329 if (SCM_FIXABLE (z
)) {
3330 return SCM_MAKINUM (z
);
3333 return scm_i_long2big (z
);
3334 #else /* SCM_BIGDIG */
3335 return scm_make_real ((double) z
);
3336 #endif /* SCM_BIGDIG */
3338 } else if (SCM_BIGP (y
)) {
3341 long int xx
= SCM_INUM (x
);
3342 #ifndef SCM_DIGSTOOBIG
3343 long z
= scm_pseudolong (xx
);
3344 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3345 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3346 #else /* SCM_DIGSTOOBIG */
3347 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3348 scm_longdigs (xx
, zdigs
);
3349 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3350 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3351 #endif /* SCM_DIGSTOOBIG */
3353 } else if (SCM_REALP (y
)) {
3354 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3355 } else if (SCM_COMPLEXP (y
)) {
3356 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3357 SCM_COMPLEX_IMAG (y
));
3359 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3361 } else if (SCM_BIGP (x
)) {
3362 if (SCM_INUMP (y
)) {
3365 } else if (SCM_BIGP (y
)) {
3366 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
)) {
3369 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3370 SCM_BIGSIGN (x
), y
, 0);
3371 } else if (SCM_REALP (y
)) {
3372 return scm_make_real (scm_i_big2dbl (x
) + SCM_REAL_VALUE (y
));
3373 } else if (SCM_COMPLEXP (y
)) {
3374 return scm_make_complex (scm_i_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3375 SCM_COMPLEX_IMAG (y
));
3377 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3379 } else if (SCM_REALP (x
)) {
3380 if (SCM_INUMP (y
)) {
3381 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3382 } else if (SCM_BIGP (y
)) {
3383 return scm_make_real (SCM_REAL_VALUE (x
) + scm_i_big2dbl (y
));
3384 } else if (SCM_REALP (y
)) {
3385 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3386 } else if (SCM_COMPLEXP (y
)) {
3387 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3388 SCM_COMPLEX_IMAG (y
));
3390 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3392 } else if (SCM_COMPLEXP (x
)) {
3393 if (SCM_INUMP (y
)) {
3394 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3395 SCM_COMPLEX_IMAG (x
));
3396 } else if (SCM_BIGP (y
)) {
3397 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_i_big2dbl (y
),
3398 SCM_COMPLEX_IMAG (x
));
3399 } else if (SCM_REALP (y
)) {
3400 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3401 SCM_COMPLEX_IMAG (x
));
3402 } else if (SCM_COMPLEXP (y
)) {
3403 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3404 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3406 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3409 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3414 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3415 /* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3416 * the sum of all but the first argument are subtracted from the first
3418 #define FUNC_NAME s_difference
3420 scm_difference (SCM x
, SCM y
)
3422 if (SCM_UNBNDP (y
)) {
3423 if (SCM_UNBNDP (x
)) {
3424 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3425 } else if (SCM_INUMP (x
)) {
3426 long xx
= -SCM_INUM (x
);
3427 if (SCM_FIXABLE (xx
)) {
3428 return SCM_MAKINUM (xx
);
3431 return scm_i_long2big (xx
);
3433 return scm_make_real ((double) xx
);
3436 } else if (SCM_BIGP (x
)) {
3437 SCM z
= scm_i_copybig (x
, !SCM_BIGSIGN (x
));
3438 unsigned int digs
= SCM_NUMDIGS (z
);
3439 unsigned int size
= digs
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
;
3440 return size
<= sizeof (SCM
) ? scm_i_big2inum (z
, digs
) : z
;
3441 } else if (SCM_REALP (x
)) {
3442 return scm_make_real (-SCM_REAL_VALUE (x
));
3443 } else if (SCM_COMPLEXP (x
)) {
3444 return scm_make_complex (-SCM_COMPLEX_REAL (x
), -SCM_COMPLEX_IMAG (x
));
3446 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3450 if (SCM_INUMP (x
)) {
3451 long int xx
= SCM_INUM (x
);
3452 if (SCM_INUMP (y
)) {
3453 long int yy
= SCM_INUM (y
);
3454 long int z
= xx
- yy
;
3455 if (SCM_FIXABLE (z
)) {
3456 return SCM_MAKINUM (z
);
3459 return scm_i_long2big (z
);
3461 return scm_make_real ((double) z
);
3464 } else if (SCM_BIGP (y
)) {
3465 #ifndef SCM_DIGSTOOBIG
3466 long z
= scm_pseudolong (xx
);
3467 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3468 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3470 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3471 scm_longdigs (xx
, zdigs
);
3472 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3473 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3475 } else if (SCM_REALP (y
)) {
3476 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
3477 } else if (SCM_COMPLEXP (y
)) {
3478 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
3479 -SCM_COMPLEX_IMAG (y
));
3481 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3483 } else if (SCM_BIGP (x
)) {
3484 if (SCM_INUMP (y
)) {
3485 long int yy
= SCM_INUM (y
);
3486 #ifndef SCM_DIGSTOOBIG
3487 long z
= scm_pseudolong (yy
);
3488 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3489 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3491 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3492 scm_longdigs (yy
, zdigs
);
3493 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3494 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3496 } else if (SCM_BIGP (y
)) {
3497 return (SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3498 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3499 SCM_BIGSIGN (x
), y
, SCM_BIGSIGNFLAG
)
3500 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3501 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
, x
, 0);
3502 } else if (SCM_REALP (y
)) {
3503 return scm_make_real (scm_i_big2dbl (x
) - SCM_REAL_VALUE (y
));
3504 } else if (SCM_COMPLEXP (y
)) {
3505 return scm_make_complex (scm_i_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3506 - SCM_COMPLEX_IMAG (y
));
3508 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3510 } else if (SCM_REALP (x
)) {
3511 if (SCM_INUMP (y
)) {
3512 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
3513 } else if (SCM_BIGP (y
)) {
3514 return scm_make_real (SCM_REAL_VALUE (x
) - scm_i_big2dbl (y
));
3515 } else if (SCM_REALP (y
)) {
3516 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3517 } else if (SCM_COMPLEXP (y
)) {
3518 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3519 -SCM_COMPLEX_IMAG (y
));
3521 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3523 } else if (SCM_COMPLEXP (x
)) {
3524 if (SCM_INUMP (y
)) {
3525 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
3526 SCM_COMPLEX_IMAG (x
));
3527 } else if (SCM_BIGP (y
)) {
3528 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_i_big2dbl (y
),
3529 SCM_COMPLEX_IMAG (x
));
3530 } else if (SCM_REALP (y
)) {
3531 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3532 SCM_COMPLEX_IMAG (x
));
3533 } else if (SCM_COMPLEXP (y
)) {
3534 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3535 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3537 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3540 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3545 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3546 /* "Return the product of all arguments. If called without arguments,\n"
3550 scm_product (SCM x
, SCM y
)
3552 if (SCM_UNBNDP (y
)) {
3553 if (SCM_UNBNDP (x
)) {
3554 return SCM_MAKINUM (1L);
3555 } else if (SCM_NUMBERP (x
)) {
3558 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3562 if (SCM_INUMP (x
)) {
3570 } else if (xx
== 1) {
3574 if (SCM_INUMP (y
)) {
3575 long yy
= SCM_INUM (y
);
3577 SCM k
= SCM_MAKINUM (kk
);
3578 if (kk
!= SCM_INUM (k
) || kk
/ xx
!= yy
) {
3580 int sgn
= (xx
< 0) ^ (yy
< 0);
3581 #ifndef SCM_DIGSTOOBIG
3582 long i
= scm_pseudolong (xx
);
3583 long j
= scm_pseudolong (yy
);
3584 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3585 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3586 #else /* SCM_DIGSTOOBIG */
3587 SCM_BIGDIG xdigs
[SCM_DIGSPERLONG
];
3588 SCM_BIGDIG ydigs
[SCM_DIGSPERLONG
];
3589 scm_longdigs (xx
, xdigs
);
3590 scm_longdigs (yy
, ydigs
);
3591 return scm_mulbig (xdigs
, SCM_DIGSPERLONG
,
3592 ydigs
, SCM_DIGSPERLONG
,
3596 return scm_make_real (((double) xx
) * ((double) yy
));
3601 } else if (SCM_BIGP (y
)) {
3602 #ifndef SCM_DIGSTOOBIG
3603 long z
= scm_pseudolong (xx
);
3604 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3605 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3606 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3608 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3609 scm_longdigs (xx
, zdigs
);
3610 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3611 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3612 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3614 } else if (SCM_REALP (y
)) {
3615 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3616 } else if (SCM_COMPLEXP (y
)) {
3617 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3618 xx
* SCM_COMPLEX_IMAG (y
));
3620 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3622 } else if (SCM_BIGP (x
)) {
3623 if (SCM_INUMP (y
)) {
3626 } else if (SCM_BIGP (y
)) {
3627 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3628 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3629 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3630 } else if (SCM_REALP (y
)) {
3631 return scm_make_real (scm_i_big2dbl (x
) * SCM_REAL_VALUE (y
));
3632 } else if (SCM_COMPLEXP (y
)) {
3633 double z
= scm_i_big2dbl (x
);
3634 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3635 z
* SCM_COMPLEX_IMAG (y
));
3637 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3639 } else if (SCM_REALP (x
)) {
3640 if (SCM_INUMP (y
)) {
3641 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3642 } else if (SCM_BIGP (y
)) {
3643 return scm_make_real (scm_i_big2dbl (y
) * SCM_REAL_VALUE (x
));
3644 } else if (SCM_REALP (y
)) {
3645 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
3646 } else if (SCM_COMPLEXP (y
)) {
3647 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
3648 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3650 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3652 } else if (SCM_COMPLEXP (x
)) {
3653 if (SCM_INUMP (y
)) {
3654 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3655 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3656 } else if (SCM_BIGP (y
)) {
3657 double z
= scm_i_big2dbl (y
);
3658 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
3659 z
* SCM_COMPLEX_IMAG (x
));
3660 } else if (SCM_REALP (y
)) {
3661 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3662 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
3663 } else if (SCM_COMPLEXP (y
)) {
3664 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
3665 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
3666 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3667 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3669 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3672 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3678 scm_num2dbl (SCM a
, const char *why
)
3679 #define FUNC_NAME why
3681 if (SCM_INUMP (a
)) {
3682 return (double) SCM_INUM (a
);
3683 } else if (SCM_BIGP (a
)) {
3684 return scm_i_big2dbl (a
);
3685 } else if (SCM_REALP (a
)) {
3686 return (SCM_REAL_VALUE (a
));
3688 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3694 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3695 /* Divide the first argument by the product of the remaining
3696 arguments. If called with one argument @var{z1}, 1/@var{z1} is
3698 #define FUNC_NAME s_divide
3700 scm_divide (SCM x
, SCM y
)
3704 if (SCM_UNBNDP (y
)) {
3705 if (SCM_UNBNDP (x
)) {
3706 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
3707 } else if (SCM_INUMP (x
)) {
3708 if (SCM_EQ_P (x
, SCM_MAKINUM (1L)) || SCM_EQ_P (x
, SCM_MAKINUM (-1L))) {
3711 return scm_make_real (1.0 / (double) SCM_INUM (x
));
3713 } else if (SCM_BIGP (x
)) {
3714 return scm_make_real (1.0 / scm_i_big2dbl (x
));
3715 } else if (SCM_REALP (x
)) {
3716 return scm_make_real (1.0 / SCM_REAL_VALUE (x
));
3717 } else if (SCM_COMPLEXP (x
)) {
3718 double r
= SCM_COMPLEX_REAL (x
);
3719 double i
= SCM_COMPLEX_IMAG (x
);
3720 double d
= r
* r
+ i
* i
;
3721 return scm_make_complex (r
/ d
, -i
/ d
);
3723 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3727 if (SCM_INUMP (x
)) {
3728 long xx
= SCM_INUM (x
);
3729 if (SCM_INUMP (y
)) {
3730 long yy
= SCM_INUM (y
);
3732 scm_num_overflow (s_divide
);
3733 } else if (xx
% yy
!= 0) {
3734 return scm_make_real ((double) xx
/ (double) yy
);
3737 if (SCM_FIXABLE (z
)) {
3738 return SCM_MAKINUM (z
);
3741 return scm_i_long2big (z
);
3743 return scm_make_real ((double) xx
/ (double) yy
);
3747 } else if (SCM_BIGP (y
)) {
3748 return scm_make_real ((double) xx
/ scm_i_big2dbl (y
));
3749 } else if (SCM_REALP (y
)) {
3750 return scm_make_real ((double) xx
/ SCM_REAL_VALUE (y
));
3751 } else if (SCM_COMPLEXP (y
)) {
3753 complex_div
: /* y _must_ be a complex number */
3755 double r
= SCM_COMPLEX_REAL (y
);
3756 double i
= SCM_COMPLEX_IMAG (y
);
3757 double d
= r
* r
+ i
* i
;
3758 return scm_make_complex ((a
* r
) / d
, (-a
* i
) / d
);
3761 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3763 } else if (SCM_BIGP (x
)) {
3764 if (SCM_INUMP (y
)) {
3765 long int yy
= SCM_INUM (y
);
3767 scm_num_overflow (s_divide
);
3768 } else if (yy
== 1) {
3771 long z
= yy
< 0 ? -yy
: yy
;
3772 if (z
< SCM_BIGRAD
) {
3773 SCM w
= scm_i_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
3774 return scm_divbigdig (SCM_BDIGITS (w
), SCM_NUMDIGS (w
),
3776 ? scm_make_real (scm_i_big2dbl (x
) / (double) yy
)
3777 : scm_i_normbig (w
);
3780 #ifndef SCM_DIGSTOOBIG
3781 z
= scm_pseudolong (z
);
3782 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3783 (SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3784 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3786 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3787 scm_longdigs (z
, zdigs
);
3788 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3789 zdigs
, SCM_DIGSPERLONG
,
3790 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3792 return (!SCM_UNBNDP (w
))
3794 : scm_make_real (scm_i_big2dbl (x
) / (double) yy
);
3797 } else if (SCM_BIGP (y
)) {
3798 SCM w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3799 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3800 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 3);
3801 return (!SCM_UNBNDP (w
))
3803 : scm_make_real (scm_i_big2dbl (x
) / scm_i_big2dbl (y
));
3804 } else if (SCM_REALP (y
)) {
3805 return scm_make_real (scm_i_big2dbl (x
) / SCM_REAL_VALUE (y
));
3806 } else if (SCM_COMPLEXP (y
)) {
3807 a
= scm_i_big2dbl (x
);
3810 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3812 } else if (SCM_REALP (x
)) {
3813 double rx
= SCM_REAL_VALUE (x
);
3814 if (SCM_INUMP (y
)) {
3815 return scm_make_real (rx
/ (double) SCM_INUM (y
));
3816 } else if (SCM_BIGP (y
)) {
3817 return scm_make_real (rx
/ scm_i_big2dbl (y
));
3818 } else if (SCM_REALP (y
)) {
3819 return scm_make_real (rx
/ SCM_REAL_VALUE (y
));
3820 } else if (SCM_COMPLEXP (y
)) {
3824 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3826 } else if (SCM_COMPLEXP (x
)) {
3827 double rx
= SCM_COMPLEX_REAL (x
);
3828 double ix
= SCM_COMPLEX_IMAG (x
);
3829 if (SCM_INUMP (y
)) {
3830 double d
= SCM_INUM (y
);
3831 return scm_make_complex (rx
/ d
, ix
/ d
);
3832 } else if (SCM_BIGP (y
)) {
3833 double d
= scm_i_big2dbl (y
);
3834 return scm_make_complex (rx
/ d
, ix
/ d
);
3835 } else if (SCM_REALP (y
)) {
3836 double d
= SCM_REAL_VALUE (y
);
3837 return scm_make_complex (rx
/ d
, ix
/ d
);
3838 } else if (SCM_COMPLEXP (y
)) {
3839 double ry
= SCM_COMPLEX_REAL (y
);
3840 double iy
= SCM_COMPLEX_IMAG (y
);
3841 double d
= ry
* ry
+ iy
* iy
;
3842 return scm_make_complex ((rx
* ry
+ ix
* iy
) / d
,
3843 (ix
* ry
- rx
* iy
) / d
);
3845 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3848 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
3853 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
3854 /* "Return the inverse hyperbolic sine of @var{x}."
3857 scm_asinh (double x
)
3859 return log (x
+ sqrt (x
* x
+ 1));
3865 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
3866 /* "Return the inverse hyperbolic cosine of @var{x}."
3869 scm_acosh (double x
)
3871 return log (x
+ sqrt (x
* x
- 1));
3877 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
3878 /* "Return the inverse hyperbolic tangent of @var{x}."
3881 scm_atanh (double x
)
3883 return 0.5 * log ((1 + x
) / (1 - x
));
3889 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
3890 /* "Round the inexact number @var{x} towards zero."
3893 scm_truncate (double x
)
3902 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
3903 /* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
3904 * "numbers, round towards even."
3907 scm_round (double x
)
3909 double plus_half
= x
+ 0.5;
3910 double result
= floor (plus_half
);
3911 /* Adjust so that the scm_round is towards even. */
3912 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
3913 ? result
- 1 : result
;
3917 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
3918 /* "Round the number @var{x} towards minus infinity."
3920 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
3921 /* "Round the number @var{x} towards infinity."
3923 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
3924 /* "Return the square root of the real number @var{x}."
3926 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
3927 /* "Return the absolute value of the real number @var{x}."
3929 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
3930 /* "Return the @var{x}th power of e."
3932 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
3933 /* "Return the natural logarithm of the real number @var{x}."
3935 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
3936 /* "Return the sine of the real number @var{x}."
3938 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
3939 /* "Return the cosine of the real number @var{x}."
3941 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
3942 /* "Return the tangent of the real number @var{x}."
3944 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
3945 /* "Return the arc sine of the real number @var{x}."
3947 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
3948 /* "Return the arc cosine of the real number @var{x}."
3950 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
3951 /* "Return the arc tangent of the real number @var{x}."
3953 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
3954 /* "Return the hyperbolic sine of the real number @var{x}."
3956 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
3957 /* "Return the hyperbolic cosine of the real number @var{x}."
3959 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
3960 /* "Return the hyperbolic tangent of the real number @var{x}."
3968 static void scm_two_doubles (SCM x
,
3970 const char *sstring
,
3974 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
3976 if (SCM_INUMP (x
)) {
3977 xy
->x
= SCM_INUM (x
);
3978 } else if (SCM_BIGP (x
)) {
3979 xy
->x
= scm_i_big2dbl (x
);
3980 } else if (SCM_REALP (x
)) {
3981 xy
->x
= SCM_REAL_VALUE (x
);
3983 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
3986 if (SCM_INUMP (y
)) {
3987 xy
->y
= SCM_INUM (y
);
3988 } else if (SCM_BIGP (y
)) {
3989 xy
->y
= scm_i_big2dbl (y
);
3990 } else if (SCM_REALP (y
)) {
3991 xy
->y
= SCM_REAL_VALUE (y
);
3993 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
3998 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
4000 "Return @var{x} raised to the power of @var{y}. This\n"
4001 "procedure does not accept complex arguments.")
4002 #define FUNC_NAME s_scm_sys_expt
4005 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4006 return scm_make_real (pow (xy
.x
, xy
.y
));
4011 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4013 "Return the arc tangent of the two arguments @var{x} and\n"
4014 "@var{y}. This is similar to calculating the arc tangent of\n"
4015 "@var{x} / @var{y}, except that the signs of both arguments\n"
4016 "are used to determine the quadrant of the result. This\n"
4017 "procedure does not accept complex arguments.")
4018 #define FUNC_NAME s_scm_sys_atan2
4021 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4022 return scm_make_real (atan2 (xy
.x
, xy
.y
));
4027 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4028 (SCM real
, SCM imaginary
),
4029 "Return a complex number constructed of the given @var{real} and\n"
4030 "@var{imaginary} parts.")
4031 #define FUNC_NAME s_scm_make_rectangular
4034 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
4035 return scm_make_complex (xy
.x
, xy
.y
);
4041 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4043 "Return the complex number @var{x} * e^(i * @var{y}).")
4044 #define FUNC_NAME s_scm_make_polar
4047 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4048 return scm_make_complex (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
4053 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4054 /* "Return the real part of the number @var{z}."
4057 scm_real_part (SCM z
)
4059 if (SCM_INUMP (z
)) {
4061 } else if (SCM_BIGP (z
)) {
4063 } else if (SCM_REALP (z
)) {
4065 } else if (SCM_COMPLEXP (z
)) {
4066 return scm_make_real (SCM_COMPLEX_REAL (z
));
4068 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4073 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4074 /* "Return the imaginary part of the number @var{z}."
4077 scm_imag_part (SCM z
)
4079 if (SCM_INUMP (z
)) {
4081 } else if (SCM_BIGP (z
)) {
4083 } else if (SCM_REALP (z
)) {
4085 } else if (SCM_COMPLEXP (z
)) {
4086 return scm_make_real (SCM_COMPLEX_IMAG (z
));
4088 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4093 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4094 /* "Return the magnitude of the number @var{z}. This is the same as\n"
4095 * "@code{abs} for real arguments, but also allows complex numbers."
4098 scm_magnitude (SCM z
)
4100 if (SCM_INUMP (z
)) {
4101 long int zz
= SCM_INUM (z
);
4104 } else if (SCM_POSFIXABLE (-zz
)) {
4105 return SCM_MAKINUM (-zz
);
4108 return scm_i_long2big (-zz
);
4110 scm_num_overflow (s_magnitude
);
4113 } else if (SCM_BIGP (z
)) {
4114 if (!SCM_BIGSIGN (z
)) {
4117 return scm_i_copybig (z
, 0);
4119 } else if (SCM_REALP (z
)) {
4120 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
4121 } else if (SCM_COMPLEXP (z
)) {
4122 double r
= SCM_COMPLEX_REAL (z
);
4123 double i
= SCM_COMPLEX_IMAG (z
);
4124 return scm_make_real (sqrt (i
* i
+ r
* r
));
4126 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4131 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
4132 /* "Return the angle of the complex number @var{z}."
4137 if (SCM_INUMP (z
)) {
4138 if (SCM_INUM (z
) >= 0) {
4139 return scm_make_real (atan2 (0.0, 1.0));
4141 return scm_make_real (atan2 (0.0, -1.0));
4143 } else if (SCM_BIGP (z
)) {
4144 if (SCM_BIGSIGN (z
)) {
4145 return scm_make_real (atan2 (0.0, -1.0));
4147 return scm_make_real (atan2 (0.0, 1.0));
4149 } else if (SCM_REALP (z
)) {
4150 return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z
)));
4151 } else if (SCM_COMPLEXP (z
)) {
4152 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
4154 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
4159 SCM_GPROC (s_exact_to_inexact
, "exact->inexact", 1, 0, 0, scm_exact_to_inexact
, g_exact_to_inexact
);
4160 /* Convert the number @var{x} to its inexact representation.\n"
4163 scm_exact_to_inexact (SCM z
)
4166 return scm_make_real ((double) SCM_INUM (z
));
4167 else if (SCM_BIGP (z
))
4168 return scm_make_real (scm_i_big2dbl (z
));
4169 else if (SCM_INEXACTP (z
))
4172 SCM_WTA_DISPATCH_1 (g_exact_to_inexact
, z
, 1, s_exact_to_inexact
);
4176 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4178 "Return an exact number that is numerically closest to @var{z}.")
4179 #define FUNC_NAME s_scm_inexact_to_exact
4181 if (SCM_INUMP (z
)) {
4183 } else if (SCM_BIGP (z
)) {
4185 } else if (SCM_REALP (z
)) {
4186 double u
= floor (SCM_REAL_VALUE (z
) + 0.5);
4188 if (SCM_FIXABLE (lu
)) {
4189 return SCM_MAKINUM (lu
);
4191 } else if (isfinite (u
)) {
4192 return scm_i_dbl2big (u
);
4195 scm_num_overflow (s_scm_inexact_to_exact
);
4198 SCM_WRONG_TYPE_ARG (1, z
);
4205 /* d must be integer */
4208 scm_i_dbl2big (double d
)
4214 double u
= (d
< 0) ? -d
: d
;
4215 while (0 != floor (u
))
4220 ans
= scm_i_mkbig (i
, d
< 0);
4221 digits
= SCM_BDIGITS (ans
);
4229 #ifndef SCM_RECKLESS
4231 scm_num_overflow ("dbl2big");
4237 scm_i_big2dbl (SCM b
)
4240 size_t i
= SCM_NUMDIGS (b
);
4241 SCM_BIGDIG
*digits
= SCM_BDIGITS (b
);
4243 ans
= digits
[i
] + SCM_BIGRAD
* ans
;
4244 if (SCM_BIGSIGN (b
))
4251 #ifdef HAVE_LONG_LONGS
4253 # define ULLONG_MAX ((unsigned long long) (-1))
4254 # define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
4255 # define LLONG_MIN (~LLONG_MAX)
4260 #define SIZE_MAX ((size_t) (-1))
4264 /* the below is not really guaranteed to work (I think), but probably does: */
4265 #define PTRDIFF_MIN ((ptrdiff_t) ((ptrdiff_t)1 << (sizeof (ptrdiff_t)*8 - 1)))
4269 #define PTRDIFF_MAX (~ PTRDIFF_MIN)
4272 #define NUM2INTEGRAL scm_num2short
4273 #define INTEGRAL2NUM scm_short2num
4274 #define INTEGRAL2BIG scm_i_short2big
4276 #define MIN_VALUE SHRT_MIN
4277 #define MAX_VALUE SHRT_MAX
4278 #include "libguile/num2integral.i.c"
4280 #define NUM2INTEGRAL scm_num2ushort
4281 #define INTEGRAL2NUM scm_ushort2num
4282 #define INTEGRAL2BIG scm_i_ushort2big
4284 #define ITYPE unsigned short
4285 #define MAX_VALUE USHRT_MAX
4286 #include "libguile/num2integral.i.c"
4288 #define NUM2INTEGRAL scm_num2int
4289 #define INTEGRAL2NUM scm_int2num
4290 #define INTEGRAL2BIG scm_i_int2big
4292 #define MIN_VALUE INT_MIN
4293 #define MAX_VALUE INT_MAX
4294 #include "libguile/num2integral.i.c"
4296 #define NUM2INTEGRAL scm_num2uint
4297 #define INTEGRAL2NUM scm_uint2num
4298 #define INTEGRAL2BIG scm_i_uint2big
4300 #define ITYPE unsigned int
4301 #define MAX_VALUE UINT_MAX
4302 #include "libguile/num2integral.i.c"
4304 #define NUM2INTEGRAL scm_num2long
4305 #define INTEGRAL2NUM scm_long2num
4306 #define INTEGRAL2BIG scm_i_long2big
4308 #define MIN_VALUE LONG_MIN
4309 #define MAX_VALUE LONG_MAX
4310 #include "libguile/num2integral.i.c"
4312 #define NUM2INTEGRAL scm_num2ulong
4313 #define INTEGRAL2NUM scm_ulong2num
4314 #define INTEGRAL2BIG scm_i_ulong2big
4316 #define ITYPE unsigned long
4317 #define MAX_VALUE ULONG_MAX
4318 #include "libguile/num2integral.i.c"
4320 #define NUM2INTEGRAL scm_num2ptrdiff
4321 #define INTEGRAL2NUM scm_ptrdiff2num
4322 #define INTEGRAL2BIG scm_i_ptrdiff2big
4323 #define ITYPE ptrdiff_t
4324 #define MIN_VALUE PTRDIFF_MIN
4325 #define MAX_VALUE PTRDIFF_MAX
4326 #include "libguile/num2integral.i.c"
4328 #define NUM2INTEGRAL scm_num2size
4329 #define INTEGRAL2NUM scm_size2num
4330 #define INTEGRAL2BIG scm_i_size2big
4332 #define ITYPE size_t
4333 #define MAX_VALUE SIZE_MAX
4334 #include "libguile/num2integral.i.c"
4336 #ifdef HAVE_LONG_LONGS
4338 #ifndef ULONG_LONG_MAX
4339 #define ULONG_LONG_MAX (~0ULL)
4342 #define NUM2INTEGRAL scm_num2long_long
4343 #define INTEGRAL2NUM scm_long_long2num
4344 #define INTEGRAL2BIG scm_i_long_long2big
4345 #define ITYPE long long
4346 #define MIN_VALUE LLONG_MIN
4347 #define MAX_VALUE LLONG_MAX
4348 #include "libguile/num2integral.i.c"
4350 #define NUM2INTEGRAL scm_num2ulong_long
4351 #define INTEGRAL2NUM scm_ulong_long2num
4352 #define INTEGRAL2BIG scm_i_ulong_long2big
4354 #define ITYPE unsigned long long
4355 #define MAX_VALUE ULLONG_MAX
4356 #include "libguile/num2integral.i.c"
4358 #endif /* HAVE_LONG_LONGS */
4362 #define CHECK(type, v) \
4364 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
4383 CHECK (ptrdiff
, -1);
4385 CHECK (short, SHRT_MAX
);
4386 CHECK (short, SHRT_MIN
);
4387 CHECK (ushort
, USHRT_MAX
);
4388 CHECK (int, INT_MAX
);
4389 CHECK (int, INT_MIN
);
4390 CHECK (uint
, UINT_MAX
);
4391 CHECK (long, LONG_MAX
);
4392 CHECK (long, LONG_MIN
);
4393 CHECK (ulong
, ULONG_MAX
);
4394 CHECK (size
, SIZE_MAX
);
4395 CHECK (ptrdiff
, PTRDIFF_MAX
);
4396 CHECK (ptrdiff
, PTRDIFF_MIN
);
4398 #ifdef HAVE_LONG_LONGS
4399 CHECK (long_long
, 0LL);
4400 CHECK (ulong_long
, 0ULL);
4402 CHECK (long_long
, -1LL);
4404 CHECK (long_long
, LLONG_MAX
);
4405 CHECK (long_long
, LLONG_MIN
);
4406 CHECK (ulong_long
, ULLONG_MAX
);
4415 abs_most_negative_fixnum
= scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM
);
4416 scm_permanent_object (abs_most_negative_fixnum
);
4418 /* It may be possible to tune the performance of some algorithms by using
4419 * the following constants to avoid the creation of bignums. Please, before
4420 * using these values, remember the two rules of program optimization:
4421 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
4422 scm_c_define ("most-positive-fixnum",
4423 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
4424 scm_c_define ("most-negative-fixnum",
4425 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
4427 scm_add_feature ("complex");
4428 scm_add_feature ("inexact");
4429 scm_flo0
= scm_make_real (0.0);
4431 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4433 { /* determine floating point precision */
4435 double fsum
= 1.0 + f
;
4436 while (fsum
!= 1.0) {
4437 if (++scm_dblprec
> 20) {
4444 scm_dblprec
= scm_dblprec
- 1;
4446 #endif /* DBL_DIG */
4452 #ifndef SCM_MAGIC_SNARFER
4453 #include "libguile/numbers.x"