1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
7 * This program is free software; you can redistribute it and/or modify
8 * it under the terms of the GNU General Public License as published by
9 * the Free Software Foundation; either version 2, or (at your option)
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with this software; see the file COPYING. If not, write to
19 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
20 * Boston, MA 02111-1307 USA
22 * As a special exception, the Free Software Foundation gives permission
23 * for additional uses of the text contained in its release of GUILE.
25 * The exception is that, if you link the GUILE library with other files
26 * to produce an executable, this does not by itself cause the
27 * resulting executable to be covered by the GNU General Public License.
28 * Your use of that executable is in no way restricted on account of
29 * linking the GUILE library code into it.
31 * This exception does not however invalidate any other reasons why
32 * the executable file might be covered by the GNU General Public License.
34 * This exception applies only to the code released by the
35 * Free Software Foundation under the name GUILE. If you copy
36 * code from other Free Software Foundation releases into a copy of
37 * GUILE, as the General Public License permits, the exception does
38 * not apply to the code that you add in this way. To avoid misleading
39 * anyone as to the status of such modified files, you must delete
40 * this exception notice from them.
42 * If you write modifications of your own for GUILE, it is your choice
43 * whether to permit this exception to apply to your modifications.
44 * If you do not wish that, delete this exception notice. */
50 #include "libguile/_scm.h"
51 #include "libguile/feature.h"
52 #include "libguile/ports.h"
53 #include "libguile/root.h"
54 #include "libguile/smob.h"
55 #include "libguile/strings.h"
57 #include "libguile/validate.h"
58 #include "libguile/numbers.h"
59 #include "libguile/deprecation.h"
63 static SCM
scm_divbigbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
, int modes
);
64 static SCM
scm_divbigint (SCM x
, long z
, int sgn
, int mode
);
67 #define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0)
70 /* FLOBUFLEN is the maximum number of characters neccessary for the
71 * printed or scm_string representation of an inexact number.
73 #define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
76 /* IS_INF tests its floating point number for infiniteness
77 Dirk:FIXME:: This test does not work if x == 0
80 #define IS_INF(x) ((x) == (x) / 2)
84 /* Return true if X is not infinite and is not a NaN
85 Dirk:FIXME:: Since IS_INF is broken, this test does not work if x == 0
88 #define isfinite(x) (!IS_INF (x) && (x) == (x))
93 static SCM abs_most_negative_fixnum
;
98 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
100 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
102 #define FUNC_NAME s_scm_exact_p
106 } else if (SCM_BIGP (x
)) {
115 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
117 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
119 #define FUNC_NAME s_scm_odd_p
122 return SCM_BOOL ((4 & SCM_UNPACK (n
)) != 0);
123 } else if (SCM_BIGP (n
)) {
124 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) != 0);
126 SCM_WRONG_TYPE_ARG (1, n
);
132 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
134 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
136 #define FUNC_NAME s_scm_even_p
139 return SCM_BOOL ((4 & SCM_UNPACK (n
)) == 0);
140 } else if (SCM_BIGP (n
)) {
141 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) == 0);
143 SCM_WRONG_TYPE_ARG (1, n
);
149 SCM_GPROC (s_abs
, "abs", 1, 0, 0, scm_abs
, g_abs
);
150 /* "Return the absolute value of @var{x}."
156 long int xx
= SCM_INUM (x
);
159 } else if (SCM_POSFIXABLE (-xx
)) {
160 return SCM_MAKINUM (-xx
);
163 return scm_i_long2big (-xx
);
165 scm_num_overflow (s_abs
);
168 } else if (SCM_BIGP (x
)) {
169 if (!SCM_BIGSIGN (x
)) {
172 return scm_i_copybig (x
, 0);
174 } else if (SCM_REALP (x
)) {
175 return scm_make_real (fabs (SCM_REAL_VALUE (x
)));
177 SCM_WTA_DISPATCH_1 (g_abs
, x
, 1, s_abs
);
182 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
183 /* "Return the quotient of the numbers @var{x} and @var{y}."
186 scm_quotient (SCM x
, SCM y
)
189 long xx
= SCM_INUM (x
);
191 long yy
= SCM_INUM (y
);
193 scm_num_overflow (s_quotient
);
196 if (SCM_FIXABLE (z
)) {
197 return SCM_MAKINUM (z
);
200 return scm_i_long2big (z
);
202 scm_num_overflow (s_quotient
);
206 } else if (SCM_BIGP (y
)) {
207 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
208 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
210 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
211 return SCM_MAKINUM (-1);
214 return SCM_MAKINUM (0);
216 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
218 } else if (SCM_BIGP (x
)) {
220 long yy
= SCM_INUM (y
);
222 scm_num_overflow (s_quotient
);
223 } else if (yy
== 1) {
226 long z
= yy
< 0 ? -yy
: yy
;
228 if (z
< SCM_BIGRAD
) {
229 SCM sw
= scm_i_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
230 scm_divbigdig (SCM_BDIGITS (sw
), SCM_NUMDIGS (sw
), (SCM_BIGDIG
) z
);
231 return scm_i_normbig (sw
);
233 #ifndef SCM_DIGSTOOBIG
234 long w
= scm_pseudolong (z
);
235 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
236 (SCM_BIGDIG
*) & w
, SCM_DIGSPERLONG
,
237 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
239 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
240 scm_longdigs (z
, zdigs
);
241 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
242 zdigs
, SCM_DIGSPERLONG
,
243 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
247 } else if (SCM_BIGP (y
)) {
248 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
249 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
250 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 2);
252 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
255 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
260 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
261 /* "Return the remainder of the numbers @var{x} and @var{y}.\n"
263 * "(remainder 13 4) @result{} 1\n"
264 * "(remainder -13 4) @result{} -1\n"
268 scm_remainder (SCM x
, SCM y
)
272 long yy
= SCM_INUM (y
);
274 scm_num_overflow (s_remainder
);
276 long z
= SCM_INUM (x
) % yy
;
277 return SCM_MAKINUM (z
);
279 } else if (SCM_BIGP (y
)) {
280 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
281 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
283 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
284 return SCM_MAKINUM (0);
289 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
291 } else if (SCM_BIGP (x
)) {
293 long yy
= SCM_INUM (y
);
295 scm_num_overflow (s_remainder
);
297 return scm_divbigint (x
, yy
, SCM_BIGSIGN (x
), 0);
299 } else if (SCM_BIGP (y
)) {
300 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
301 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
304 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
307 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
312 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
313 /* "Return the modulo of the numbers @var{x} and @var{y}.\n"
315 * "(modulo 13 4) @result{} 1\n"
316 * "(modulo -13 4) @result{} 3\n"
320 scm_modulo (SCM x
, SCM y
)
323 long xx
= SCM_INUM (x
);
325 long yy
= SCM_INUM (y
);
327 scm_num_overflow (s_modulo
);
330 return SCM_MAKINUM (((yy
< 0) ? (z
> 0) : (z
< 0)) ? z
+ yy
: z
);
332 } else if (SCM_BIGP (y
)) {
333 return (SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0)) ? scm_sum (x
, y
) : x
;
335 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
337 } else if (SCM_BIGP (x
)) {
339 long yy
= SCM_INUM (y
);
341 scm_num_overflow (s_modulo
);
343 return scm_divbigint (x
, yy
, yy
< 0,
344 (SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0)) ? 1 : 0);
346 } else if (SCM_BIGP (y
)) {
347 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
348 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
350 (SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
)) ? 1 : 0);
352 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
355 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
360 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
361 /* "Return the greatest common divisor of all arguments.\n"
362 * "If called without arguments, 0 is returned."
365 scm_gcd (SCM x
, SCM y
)
367 if (SCM_UNBNDP (y
)) {
368 if (SCM_UNBNDP (x
)) {
378 long xx
= SCM_INUM (x
);
379 long yy
= SCM_INUM (y
);
380 long u
= xx
< 0 ? -xx
: xx
;
381 long v
= yy
< 0 ? -yy
: yy
;
386 } else if (yy
== 0) {
392 /* Determine a common factor 2^k */
393 while (!(1 & (u
| v
))) {
399 /* Now, any factor 2^n can be eliminated */
419 if (SCM_POSFIXABLE (result
)) {
420 return SCM_MAKINUM (result
);
423 return scm_i_long2big (result
);
425 scm_num_overflow (s_gcd
);
428 } else if (SCM_BIGP (y
)) {
432 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
434 } else if (SCM_BIGP (x
)) {
437 x
= scm_i_copybig (x
, 0);
440 if (SCM_EQ_P (y
, SCM_INUM0
)) {
445 } else if (SCM_BIGP (y
)) {
447 y
= scm_i_copybig (y
, 0);
448 switch (scm_bigcomp (x
, y
))
453 SCM t
= scm_remainder (x
, y
);
459 y
= scm_remainder (y
, x
);
461 default: /* x == y */
464 /* instead of the switch, we could just
465 return scm_gcd (y, scm_modulo (x, y)); */
467 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
470 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
475 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
476 /* "Return the least common multiple of the arguments.\n"
477 * "If called without arguments, 1 is returned."
480 scm_lcm (SCM n1
, SCM n2
)
482 if (SCM_UNBNDP (n2
)) {
483 if (SCM_UNBNDP (n1
)) {
484 return SCM_MAKINUM (1L);
486 n2
= SCM_MAKINUM (1L);
491 SCM_GASSERT2 (SCM_INUMP (n1
), g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
492 SCM_GASSERT2 (SCM_INUMP (n2
), g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
494 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
495 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
496 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
497 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
501 SCM d
= scm_gcd (n1
, n2
);
502 if (SCM_EQ_P (d
, SCM_INUM0
)) {
505 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
512 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
514 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
518 /* Emulating 2's complement bignums with sign magnitude arithmetic:
523 + + + x (map digit:logand X Y)
524 + - + x (map digit:logand X (lognot (+ -1 Y)))
525 - + + y (map digit:logand (lognot (+ -1 X)) Y)
526 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
531 + + + (map digit:logior X Y)
532 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
533 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
534 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
539 + + + (map digit:logxor X Y)
540 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
541 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
542 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
547 + + (any digit:logand X Y)
548 + - (any digit:logand X (lognot (+ -1 Y)))
549 - + (any digit:logand (lognot (+ -1 X)) Y)
556 SCM
scm_copy_big_dec(SCM b
, int sign
);
557 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, size_t nx
, int zsgn
);
558 SCM
scm_big_ior(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
559 SCM
scm_big_xor(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
560 SCM
scm_big_and(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int zsgn
);
561 SCM
scm_big_test(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
563 SCM
scm_copy_big_dec(SCM b
, int sign
)
566 size_t nx
= SCM_NUMDIGS(b
);
568 SCM ans
= scm_i_mkbig(nx
, sign
);
569 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
570 if SCM_BIGSIGN(b
) do {
572 if (num
< 0) {dst
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
573 else {dst
[i
] = SCM_BIGLO(num
); num
= 0;}
576 while (nx
--) dst
[nx
] = src
[nx
];
580 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, size_t nx
, int zsgn
)
584 SCM z
= scm_i_mkbig(nx
, zsgn
);
585 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
588 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
589 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
591 else do zds
[i
] = x
[i
]; while (++i
< nx
);
595 SCM
scm_big_ior(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
596 /* Assumes nx <= SCM_NUMDIGS(bigy) */
597 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
600 size_t i
= 0, ny
= SCM_NUMDIGS(bigy
);
601 SCM z
= scm_copy_big_dec (bigy
, xsgn
& SCM_BIGSIGN (bigy
));
602 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
606 if (num
< 0) {zds
[i
] |= num
+ SCM_BIGRAD
; num
= -1;}
607 else {zds
[i
] |= SCM_BIGLO(num
); num
= 0;}
609 /* ========= Need to increment zds now =========== */
613 zds
[i
++] = SCM_BIGLO(num
);
614 num
= SCM_BIGDN(num
);
617 scm_i_adjbig(z
, 1 + ny
); /* OOPS, overflowed into next digit. */
618 SCM_BDIGITS(z
)[ny
] = 1;
621 else do zds
[i
] = zds
[i
] | x
[i
]; while (++i
< nx
);
625 SCM
scm_big_xor(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
626 /* Assumes nx <= SCM_NUMDIGS(bigy) */
627 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
630 size_t i
= 0, ny
= SCM_NUMDIGS(bigy
);
631 SCM z
= scm_copy_big_dec(bigy
, xsgn
^ SCM_BIGSIGN(bigy
));
632 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
635 if (num
< 0) {zds
[i
] ^= num
+ SCM_BIGRAD
; num
= -1;}
636 else {zds
[i
] ^= SCM_BIGLO(num
); num
= 0;}
639 zds
[i
] = zds
[i
] ^ x
[i
];
642 if (xsgn
^ SCM_BIGSIGN(bigy
)) {
643 /* ========= Need to increment zds now =========== */
647 zds
[i
++] = SCM_BIGLO(num
);
648 num
= SCM_BIGDN(num
);
649 if (!num
) return scm_i_normbig(z
);
652 return scm_i_normbig(z
);
655 SCM
scm_big_and(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int zsgn
)
656 /* Assumes nx <= SCM_NUMDIGS(bigy) */
657 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
658 /* return sign equals either 0 or SCM_BIGSIGNFLAG */
665 z
= scm_copy_smaller(x
, nx
, zsgn
);
666 x
= SCM_BDIGITS(bigy
);
667 xsgn
= SCM_BIGSIGN(bigy
);
669 else z
= scm_copy_big_dec(bigy
, zsgn
);
670 zds
= SCM_BDIGITS(z
);
675 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
676 else {zds
[i
] &= SCM_BIGLO(num
); num
= 0;}
678 else do zds
[i
] = zds
[i
] & ~x
[i
]; while (++i
< nx
);
679 /* ========= need to increment zds now =========== */
683 zds
[i
++] = SCM_BIGLO(num
);
684 num
= SCM_BIGDN(num
);
685 if (!num
) return scm_i_normbig(z
);
689 unsigned long int carry
= 1;
691 unsigned long int mask
= (SCM_BIGDIG
) ~x
[i
] + carry
;
692 zds
[i
] = zds
[i
] & (SCM_BIGDIG
) mask
;
693 carry
= (mask
>= SCM_BIGRAD
) ? 1 : 0;
695 } else do zds
[i
] = zds
[i
] & x
[i
]; while (++i
< nx
);
696 return scm_i_normbig(z
);
699 SCM
scm_big_test(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
700 /* Assumes nx <= SCM_NUMDIGS(bigy) */
701 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
706 if (SCM_BIGSIGN(bigy
) & xsgn
) return SCM_BOOL_T
;
707 if (SCM_NUMDIGS(bigy
) != nx
&& xsgn
) return SCM_BOOL_T
;
708 y
= SCM_BDIGITS(bigy
);
713 if (y
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
717 if (y
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
721 else if SCM_BIGSIGN(bigy
)
725 if (x
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
729 if (x
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
734 do if (x
[i
] & y
[i
]) return SCM_BOOL_T
;
741 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
743 "Return the bitwise AND of the integer arguments.\n\n"
745 "(logand) @result{} -1\n"
746 "(logand 7) @result{} 7\n"
747 "(logand #b111 #b011 #\b001) @result{} 1\n"
749 #define FUNC_NAME s_scm_logand
753 if (SCM_UNBNDP (n2
)) {
754 if (SCM_UNBNDP (n1
)) {
755 return SCM_MAKINUM (-1);
756 } else if (!SCM_NUMBERP (n1
)) {
757 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
759 } else if (SCM_NUMBERP (n1
)) {
762 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
770 if (SCM_INUMP (n1
)) {
772 if (SCM_INUMP (n2
)) {
773 long nn2
= SCM_INUM (n2
);
774 return SCM_MAKINUM (nn1
& nn2
);
775 } else if SCM_BIGP (n2
) {
778 # ifndef SCM_DIGSTOOBIG
779 long z
= scm_pseudolong (nn1
);
780 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
781 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
782 SCM_BIGSIGNFLAG
, n2
);
784 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
785 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
788 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
789 scm_longdigs (nn1
, zdigs
);
790 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
791 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
793 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
794 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
799 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
801 } else if (SCM_BIGP (n1
)) {
802 if (SCM_INUMP (n2
)) {
806 } else if (SCM_BIGP (n2
)) {
807 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
810 if ((SCM_BIGSIGN (n1
)) && SCM_BIGSIGN (n2
)) {
811 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
812 SCM_BIGSIGNFLAG
, n2
);
814 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
815 SCM_BIGSIGN (n1
), n2
, 0);
818 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
821 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
827 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
829 "Return the bitwise OR of the integer arguments.\n\n"
831 "(logior) @result{} 0\n"
832 "(logior 7) @result{} 7\n"
833 "(logior #b000 #b001 #b011) @result{} 3\n"
835 #define FUNC_NAME s_scm_logior
839 if (SCM_UNBNDP (n2
)) {
840 if (SCM_UNBNDP (n1
)) {
843 } else if (SCM_NUMBERP (n1
)) {
846 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
854 if (SCM_INUMP (n1
)) {
856 if (SCM_INUMP (n2
)) {
857 long nn2
= SCM_INUM (n2
);
858 return SCM_MAKINUM (nn1
| nn2
);
859 } else if (SCM_BIGP (n2
)) {
862 # ifndef SCM_DIGSTOOBIG
863 long z
= scm_pseudolong (nn1
);
864 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
865 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
866 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
868 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
869 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
872 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
873 scm_longdigs (nn1
, zdigs
);
874 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
875 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
,
876 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
878 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
879 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
884 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
886 } else if (SCM_BIGP (n1
)) {
887 if (SCM_INUMP (n2
)) {
891 } else if (SCM_BIGP (n2
)) {
892 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
895 if ((!SCM_BIGSIGN (n1
)) && !SCM_BIGSIGN (n2
)) {
896 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
897 SCM_BIGSIGN (n1
), n2
);
899 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
900 SCM_BIGSIGN (n1
), n2
, SCM_BIGSIGNFLAG
);
903 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
906 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
912 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
914 "Return the bitwise XOR of the integer arguments. A bit is\n"
915 "set in the result if it is set in an odd number of arguments.\n"
917 "(logxor) @result{} 0\n"
918 "(logxor 7) @result{} 7\n"
919 "(logxor #b000 #b001 #b011) @result{} 2\n"
920 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
922 #define FUNC_NAME s_scm_logxor
926 if (SCM_UNBNDP (n2
)) {
927 if (SCM_UNBNDP (n1
)) {
930 } else if (SCM_NUMBERP (n1
)) {
933 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
941 if (SCM_INUMP (n1
)) {
943 if (SCM_INUMP (n2
)) {
944 long nn2
= SCM_INUM (n2
);
945 return SCM_MAKINUM (nn1
^ nn2
);
946 } else if (SCM_BIGP (n2
)) {
949 # ifndef SCM_DIGSTOOBIG
950 long z
= scm_pseudolong (nn1
);
951 return scm_big_xor ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
952 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
954 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
955 scm_longdigs (nn1
, zdigs
);
956 return scm_big_xor (zdigs
, SCM_DIGSPERLONG
,
957 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
961 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
963 } else if (SCM_BIGP (n1
)) {
964 if (SCM_INUMP (n2
)) {
968 } else if (SCM_BIGP (n2
)) {
969 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {
972 return scm_big_xor (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
973 SCM_BIGSIGN (n1
), n2
);
975 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
978 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
984 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
987 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
988 "(logtest #b0100 #b1011) @result{} #f\n"
989 "(logtest #b0100 #b0111) @result{} #t\n"
991 #define FUNC_NAME s_scm_logtest
998 long nk
= SCM_INUM (k
);
999 return SCM_BOOL (nj
& nk
);
1000 } else if (SCM_BIGP (k
)) {
1003 # ifndef SCM_DIGSTOOBIG
1004 long z
= scm_pseudolong (nj
);
1005 return scm_big_test ((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
1006 (nj
< 0) ? SCM_BIGSIGNFLAG
: 0, k
);
1008 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
1009 scm_longdigs (nj
, zdigs
);
1010 return scm_big_test (zdigs
, SCM_DIGSPERLONG
,
1011 (nj
< 0) ? SCM_BIGSIGNFLAG
: 0, k
);
1015 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1017 } else if (SCM_BIGP (j
)) {
1018 if (SCM_INUMP (k
)) {
1022 } else if (SCM_BIGP (k
)) {
1023 if (SCM_NUMDIGS (j
) > SCM_NUMDIGS (k
)) {
1026 return scm_big_test (SCM_BDIGITS (j
), SCM_NUMDIGS (j
),
1027 SCM_BIGSIGN (j
), k
);
1029 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1032 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
1038 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
1041 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1042 "(logbit? 0 #b1101) @result{} #t\n"
1043 "(logbit? 1 #b1101) @result{} #f\n"
1044 "(logbit? 2 #b1101) @result{} #t\n"
1045 "(logbit? 3 #b1101) @result{} #t\n"
1046 "(logbit? 4 #b1101) @result{} #f\n"
1048 #define FUNC_NAME s_scm_logbit_p
1050 unsigned long int iindex
;
1052 SCM_VALIDATE_INUM_MIN (SCM_ARG1
, index
, 0);
1053 iindex
= (unsigned long int) SCM_INUM (index
);
1055 if (SCM_INUMP (j
)) {
1056 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1057 } else if (SCM_BIGP (j
)) {
1058 if (SCM_NUMDIGS (j
) * SCM_BITSPERDIG
< iindex
) {
1060 } else if (SCM_BIGSIGN (j
)) {
1063 SCM_BIGDIG
* x
= SCM_BDIGITS (j
);
1064 size_t nx
= iindex
/ SCM_BITSPERDIG
;
1068 return SCM_BOOL (((1L << (iindex
% SCM_BITSPERDIG
)) & num
) == 0);
1069 } else if (num
< 0) {
1076 return SCM_BOOL (SCM_BDIGITS (j
) [iindex
/ SCM_BITSPERDIG
]
1077 & (1L << (iindex
% SCM_BITSPERDIG
)));
1080 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1086 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1088 "Return the integer which is the 2s-complement of the integer\n"
1092 "(number->string (lognot #b10000000) 2)\n"
1093 " @result{} \"-10000001\"\n"
1094 "(number->string (lognot #b0) 2)\n"
1095 " @result{} \"-1\"\n"
1097 #define FUNC_NAME s_scm_lognot
1099 return scm_difference (SCM_MAKINUM (-1L), n
);
1103 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1105 "Return @var{n} raised to the non-negative integer exponent\n"
1109 "(integer-expt 2 5)\n"
1111 "(integer-expt -3 3)\n"
1114 #define FUNC_NAME s_scm_integer_expt
1116 SCM acc
= SCM_MAKINUM (1L);
1119 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1121 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1122 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1126 double r
= SCM_REAL_VALUE (k
);
1129 SCM_WRONG_TYPE_ARG (2, k
);
1132 SCM_VALIDATE_ULONG_COPY (2,k
,i2
);
1136 n
= scm_divide (n
, SCM_UNDEFINED
);
1143 return scm_product (acc
, n
);
1145 acc
= scm_product (acc
, n
);
1146 n
= scm_product (n
, n
);
1152 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1154 "The function ash performs an arithmetic shift left by @var{cnt}\n"
1155 "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n"
1156 "means, that the function does not guarantee to keep the bit\n"
1157 "structure of @var{n}, but rather guarantees that the result\n"
1158 "will always be rounded towards minus infinity. Therefore, the\n"
1159 "results of ash and a corresponding bitwise shift will differ if\n"
1160 "@var{n} is negative.\n"
1162 "Formally, the function returns an integer equivalent to\n"
1163 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n"
1166 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1167 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
1169 #define FUNC_NAME s_scm_ash
1174 SCM_VALIDATE_INUM (1, n
)
1176 SCM_VALIDATE_INUM (2, cnt
);
1178 bits_to_shift
= SCM_INUM (cnt
);
1180 if (bits_to_shift
< 0) {
1181 /* Shift right by abs(cnt) bits. This is realized as a division by
1182 div:=2^abs(cnt). However, to guarantee the floor rounding, negative
1183 values require some special treatment.
1185 SCM div
= scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift
));
1186 if (SCM_FALSEP (scm_negative_p (n
)))
1187 return scm_quotient (n
, div
);
1189 return scm_sum (SCM_MAKINUM (-1L),
1190 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1192 /* Shift left is done by multiplication with 2^CNT */
1193 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1195 if (bits_to_shift
< 0)
1196 /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */
1197 return SCM_MAKINUM (SCM_SRS (SCM_INUM (n
), -bits_to_shift
));
1199 /* Shift left, but make sure not to leave the range of inums */
1200 SCM res
= SCM_MAKINUM (SCM_INUM (n
) << cnt
);
1201 if (SCM_INUM (res
) >> cnt
!= SCM_INUM (n
))
1202 scm_num_overflow (FUNC_NAME
);
1210 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1211 (SCM n
, SCM start
, SCM end
),
1212 "Return the integer composed of the @var{start} (inclusive)\n"
1213 "through @var{end} (exclusive) bits of @var{n}. The\n"
1214 "@var{start}th bit becomes the 0-th bit in the result.\n"
1217 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1218 " @result{} \"1010\"\n"
1219 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1220 " @result{} \"10110\"\n"
1222 #define FUNC_NAME s_scm_bit_extract
1224 unsigned long int istart
, iend
;
1225 SCM_VALIDATE_INUM_MIN_COPY (2,start
,0,istart
);
1226 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1227 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1229 if (SCM_INUMP (n
)) {
1230 long int in
= SCM_INUM (n
);
1231 unsigned long int bits
= iend
- istart
;
1233 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
1235 /* Since we emulate two's complement encoded numbers, this special
1236 * case requires us to produce a result that has more bits than can be
1237 * stored in a fixnum. Thus, we fall back to the more general
1238 * algorithm that is used for bignums.
1243 if (istart
< SCM_I_FIXNUM_BIT
)
1246 if (bits
< SCM_I_FIXNUM_BIT
)
1247 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1248 else /* we know: in >= 0 */
1249 return SCM_MAKINUM (in
);
1253 return SCM_MAKINUM (-1L & ((1L << bits
) - 1));
1257 return SCM_MAKINUM (0);
1259 } else if (SCM_BIGP (n
)) {
1262 SCM num1
= SCM_MAKINUM (1L);
1263 SCM num2
= SCM_MAKINUM (2L);
1264 SCM bits
= SCM_MAKINUM (iend
- istart
);
1265 SCM mask
= scm_difference (scm_integer_expt (num2
, bits
), num1
);
1266 return scm_logand (mask
, scm_ash (n
, SCM_MAKINUM (-istart
)));
1269 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1275 static const char scm_logtab
[] = {
1276 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1279 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1281 "Return the number of bits in integer @var{n}. If integer is\n"
1282 "positive, the 1-bits in its binary representation are counted.\n"
1283 "If negative, the 0-bits in its two's-complement binary\n"
1284 "representation are counted. If 0, 0 is returned.\n"
1287 "(logcount #b10101010)\n"
1294 #define FUNC_NAME s_scm_logcount
1296 if (SCM_INUMP (n
)) {
1297 unsigned long int c
= 0;
1298 long int nn
= SCM_INUM (n
);
1303 c
+= scm_logtab
[15 & nn
];
1306 return SCM_MAKINUM (c
);
1307 } else if (SCM_BIGP (n
)) {
1308 if (SCM_BIGSIGN (n
)) {
1309 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n
));
1311 unsigned long int c
= 0;
1312 size_t i
= SCM_NUMDIGS (n
);
1313 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1316 for (d
= ds
[i
]; d
; d
>>= 4) {
1317 c
+= scm_logtab
[15 & d
];
1320 return SCM_MAKINUM (c
);
1323 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1329 static const char scm_ilentab
[] = {
1330 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1333 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1335 "Return the number of bits necessary to represent @var{n}.\n"
1338 "(integer-length #b10101010)\n"
1340 "(integer-length 0)\n"
1342 "(integer-length #b1111)\n"
1345 #define FUNC_NAME s_scm_integer_length
1347 if (SCM_INUMP (n
)) {
1348 unsigned long int c
= 0;
1350 long int nn
= SCM_INUM (n
);
1356 l
= scm_ilentab
[15 & nn
];
1359 return SCM_MAKINUM (c
- 4 + l
);
1360 } else if (SCM_BIGP (n
)) {
1361 if (SCM_BIGSIGN (n
)) {
1362 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n
));
1364 unsigned long int digs
= SCM_NUMDIGS (n
) - 1;
1365 unsigned long int c
= digs
* SCM_BITSPERDIG
;
1367 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1368 SCM_BIGDIG d
= ds
[digs
];
1371 l
= scm_ilentab
[15 & d
];
1374 return SCM_MAKINUM (c
- 4 + l
);
1377 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1384 static const char s_bignum
[] = "bignum";
1387 scm_i_mkbig (size_t nlen
, int sign
)
1392 if (((nlen
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1393 scm_memory_error (s_bignum
);
1395 base
= scm_gc_malloc (nlen
* sizeof (SCM_BIGDIG
), s_bignum
);
1397 v
= scm_cell (SCM_MAKE_BIGNUM_TAG (nlen
, sign
), (scm_t_bits
) base
);
1402 scm_i_big2inum (SCM b
, size_t l
)
1404 unsigned long num
= 0;
1405 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1407 num
= SCM_BIGUP (num
) + tmp
[l
];
1408 if (!SCM_BIGSIGN (b
))
1410 if (SCM_POSFIXABLE (num
))
1411 return SCM_MAKINUM (num
);
1413 else if (num
<= -SCM_MOST_NEGATIVE_FIXNUM
)
1414 return SCM_MAKINUM (-num
);
1418 static const char s_adjbig
[] = "scm_i_adjbig";
1421 scm_i_adjbig (SCM b
, size_t nlen
)
1424 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1425 scm_memory_error (s_adjbig
);
1431 scm_gc_realloc (SCM_BDIGITS (b
),
1432 SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
),
1433 nsiz
* sizeof (SCM_BIGDIG
), s_bignum
));
1435 SCM_SET_BIGNUM_BASE (b
, digits
);
1436 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1443 scm_i_normbig (SCM b
)
1446 size_t nlen
= SCM_NUMDIGS (b
);
1448 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1450 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1451 while (nlen
-- && !zds
[nlen
]);
1453 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1454 if (SCM_INUMP (b
= scm_i_big2inum (b
, (size_t) nlen
)))
1456 if (SCM_NUMDIGS (b
) == nlen
)
1458 return scm_i_adjbig (b
, (size_t) nlen
);
1462 scm_i_copybig (SCM b
, int sign
)
1464 size_t i
= SCM_NUMDIGS (b
);
1465 SCM ans
= scm_i_mkbig (i
, sign
);
1466 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1473 scm_bigcomp (SCM x
, SCM y
)
1475 int xsign
= SCM_BIGSIGN (x
);
1476 int ysign
= SCM_BIGSIGN (y
);
1479 /* Look at the signs, first. */
1485 /* They're the same sign, so see which one has more digits. Note
1486 that, if they are negative, the longer number is the lesser. */
1487 ylen
= SCM_NUMDIGS (y
);
1488 xlen
= SCM_NUMDIGS (x
);
1490 return (xsign
) ? -1 : 1;
1492 return (xsign
) ? 1 : -1;
1494 /* They have the same number of digits, so find the most significant
1495 digit where they differ. */
1499 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1500 /* Make the discrimination based on the digit that differs. */
1501 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1503 : (xsign
? 1 : -1));
1506 /* The numbers are identical. */
1510 #ifndef SCM_DIGSTOOBIG
1514 scm_pseudolong (long x
)
1519 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1525 while (i
< SCM_DIGSPERLONG
)
1527 p
.bd
[i
++] = SCM_BIGLO (x
);
1530 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1538 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1543 while (i
< SCM_DIGSPERLONG
)
1545 digs
[i
++] = SCM_BIGLO (x
);
1554 scm_addbig (SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int sgny
)
1556 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1557 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1559 size_t i
= 0, ny
= SCM_NUMDIGS (bigy
);
1560 SCM z
= scm_i_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1561 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1562 if (xsgn
^ SCM_BIGSIGN (z
))
1566 num
+= (long) zds
[i
] - x
[i
];
1569 zds
[i
] = num
+ SCM_BIGRAD
;
1574 zds
[i
] = SCM_BIGLO (num
);
1579 if (num
&& nx
== ny
)
1583 SCM_SET_CELL_WORD_0 (z
, SCM_CELL_WORD_0 (z
) ^ SCM_BIGSIGNFLAG
);
1586 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1587 zds
[i
++] = SCM_BIGLO (num
);
1588 num
= SCM_BIGDN (num
);
1598 zds
[i
++] = num
+ SCM_BIGRAD
;
1603 zds
[i
++] = SCM_BIGLO (num
);
1612 num
+= (long) zds
[i
] + x
[i
];
1613 zds
[i
++] = SCM_BIGLO (num
);
1614 num
= SCM_BIGDN (num
);
1622 zds
[i
++] = SCM_BIGLO (num
);
1623 num
= SCM_BIGDN (num
);
1629 z
= scm_i_adjbig (z
, ny
+ 1);
1630 SCM_BDIGITS (z
)[ny
] = num
;
1634 return scm_i_normbig (z
);
1639 scm_mulbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
)
1641 size_t i
= 0, j
= nx
+ ny
;
1642 unsigned long n
= 0;
1643 SCM z
= scm_i_mkbig (j
, sgn
);
1644 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1654 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1655 zds
[i
+ j
++] = SCM_BIGLO (n
);
1667 return scm_i_normbig (z
);
1672 scm_divbigdig (SCM_BIGDIG
* ds
, size_t h
, SCM_BIGDIG div
)
1674 register unsigned long t2
= 0;
1677 t2
= SCM_BIGUP (t2
) + ds
[h
];
1687 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1693 register unsigned long t2
= 0;
1694 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1695 size_t nd
= SCM_NUMDIGS (x
);
1697 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1700 return SCM_MAKINUM (sgn
? -t2
: t2
);
1703 #ifndef SCM_DIGSTOOBIG
1704 unsigned long t2
= scm_pseudolong (z
);
1705 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1706 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1709 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1710 scm_longdigs (z
, t2
);
1711 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1712 t2
, SCM_DIGSPERLONG
,
1720 scm_divbigbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
, int modes
)
1722 /* modes description
1726 3 quotient but returns SCM_UNDEFINED if division is not exact. */
1727 size_t i
= 0, j
= 0;
1729 unsigned long t2
= 0;
1731 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1732 /* algorithm requires nx >= ny */
1736 case 0: /* remainder -- just return x */
1737 z
= scm_i_mkbig (nx
, sgn
);
1738 zds
= SCM_BDIGITS (z
);
1745 case 1: /* scm_modulo -- return y-x */
1746 z
= scm_i_mkbig (ny
, sgn
);
1747 zds
= SCM_BDIGITS (z
);
1750 num
+= (long) y
[i
] - x
[i
];
1753 zds
[i
] = num
+ SCM_BIGRAD
;
1768 zds
[i
++] = num
+ SCM_BIGRAD
;
1779 return SCM_INUM0
; /* quotient is zero */
1781 return SCM_UNDEFINED
; /* the division is not exact */
1784 z
= scm_i_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1785 zds
= SCM_BDIGITS (z
);
1789 ny
--; /* in case y came in as a psuedolong */
1790 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1791 { /* normalize operands */
1792 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1793 newy
= scm_i_mkbig (ny
, 0);
1794 yds
= SCM_BDIGITS (newy
);
1797 t2
+= (unsigned long) y
[j
] * d
;
1798 yds
[j
++] = SCM_BIGLO (t2
);
1799 t2
= SCM_BIGDN (t2
);
1806 t2
+= (unsigned long) x
[j
] * d
;
1807 zds
[j
++] = SCM_BIGLO (t2
);
1808 t2
= SCM_BIGDN (t2
);
1818 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1820 { /* loop over digits of quotient */
1821 if (zds
[j
] == y
[ny
- 1])
1822 qhat
= SCM_BIGRAD
- 1;
1824 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1831 { /* multiply and subtract */
1832 t2
+= (unsigned long) y
[i
] * qhat
;
1833 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1836 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1841 zds
[j
- ny
+ i
] = num
;
1844 t2
= SCM_BIGDN (t2
);
1847 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1849 { /* "add back" required */
1855 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1856 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1857 num
= SCM_BIGDN (num
);
1868 case 3: /* check that remainder==0 */
1869 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1871 return SCM_UNDEFINED
;
1872 case 2: /* move quotient down in z */
1873 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
1874 for (i
= 0; i
< j
; i
++)
1875 zds
[i
] = zds
[i
+ ny
];
1878 case 1: /* subtract for scm_modulo */
1884 num
+= y
[i
] - zds
[i
];
1888 zds
[i
] = num
+ SCM_BIGRAD
;
1900 case 0: /* just normalize remainder */
1902 scm_divbigdig (zds
, ny
, d
);
1905 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1906 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
1907 if (SCM_INUMP (z
= scm_i_big2inum (z
, j
)))
1909 return scm_i_adjbig (z
, j
);
1917 /*** NUMBERS -> STRINGS ***/
1919 static const double fx
[] =
1920 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1921 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1922 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1923 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1929 idbl2str (double f
, char *a
)
1931 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1936 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1955 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1956 make-uniform-vector, from causing infinite loops. */
1960 if (exp
-- < DBL_MIN_10_EXP
)
1966 if (exp
++ > DBL_MAX_10_EXP
)
1981 if (f
+ fx
[wp
] >= 10.0)
1988 dpt
= (exp
+ 9999) % 3;
1992 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2017 if (f
+ fx
[wp
] >= 1.0)
2031 if ((dpt
> 4) && (exp
> 6))
2033 d
= (a
[0] == '-' ? 2 : 1);
2034 for (i
= ch
++; i
> d
; i
--)
2047 if (a
[ch
- 1] == '.')
2048 a
[ch
++] = '0'; /* trailing zero */
2057 for (i
= 10; i
<= exp
; i
*= 10);
2058 for (i
/= 10; i
; i
/= 10)
2060 a
[ch
++] = exp
/ i
+ '0';
2069 iflo2str (SCM flt
, char *str
)
2072 if (SCM_REALP (flt
))
2073 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2076 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2077 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2079 if (0 <= SCM_COMPLEX_IMAG (flt
))
2081 i
+= idbl2str (SCM_COMPLEX_IMAG (flt
), &str
[i
]);
2088 /* convert a long to a string (unterminated). returns the number of
2089 characters in the result.
2091 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2093 scm_iint2str (long num
, int rad
, char *p
)
2097 unsigned long n
= (num
< 0) ? -num
: num
;
2099 for (n
/= rad
; n
> 0; n
/= rad
)
2116 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2125 big2str (SCM b
, unsigned int radix
)
2127 SCM t
= scm_i_copybig (b
, 0); /* sign of temp doesn't matter */
2128 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2129 size_t i
= SCM_NUMDIGS (t
);
2130 size_t j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2131 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2132 : (SCM_BITSPERDIG
* i
) + 2;
2135 SCM_BIGDIG radpow
= 1, radmod
= 0;
2136 SCM ss
= scm_allocate_string (j
);
2137 char *s
= SCM_STRING_CHARS (ss
), c
;
2138 while ((long) radpow
* radix
< SCM_BIGRAD
)
2143 while ((i
|| radmod
) && j
)
2147 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2155 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2158 if (SCM_BIGSIGN (b
))
2163 /* The pre-reserved string length was too large. */
2164 unsigned long int length
= SCM_STRING_LENGTH (ss
);
2165 ss
= scm_substring (ss
, SCM_MAKINUM (j
), SCM_MAKINUM (length
));
2168 return scm_return_first (ss
, t
);
2173 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2175 "Return a string holding the external representation of the\n"
2176 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2177 "inexact, a radix of 10 will be used.")
2178 #define FUNC_NAME s_scm_number_to_string
2182 if (SCM_UNBNDP (radix
)) {
2185 SCM_VALIDATE_INUM (2, radix
);
2186 base
= SCM_INUM (radix
);
2187 SCM_ASSERT_RANGE (2, radix
, base
>= 2);
2190 if (SCM_INUMP (n
)) {
2191 char num_buf
[SCM_INTBUFLEN
];
2192 size_t length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2193 return scm_mem2string (num_buf
, length
);
2194 } else if (SCM_BIGP (n
)) {
2195 return big2str (n
, (unsigned int) base
);
2196 } else if (SCM_INEXACTP (n
)) {
2197 char num_buf
[FLOBUFLEN
];
2198 return scm_mem2string (num_buf
, iflo2str (n
, num_buf
));
2200 SCM_WRONG_TYPE_ARG (1, n
);
2206 /* These print routines are stubbed here so that scm_repl.c doesn't need
2207 SCM_BIGDIG conditionals */
2210 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2212 char num_buf
[FLOBUFLEN
];
2213 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2218 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2220 char num_buf
[FLOBUFLEN
];
2221 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2226 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2229 exp
= big2str (exp
, (unsigned int) 10);
2230 scm_lfwrite (SCM_STRING_CHARS (exp
), (size_t) SCM_STRING_LENGTH (exp
), port
);
2232 scm_ipruk ("bignum", exp
, port
);
2236 /*** END nums->strs ***/
2239 /*** STRINGS -> NUMBERS ***/
2241 /* The following functions implement the conversion from strings to numbers.
2242 * The implementation somehow follows the grammar for numbers as it is given
2243 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
2244 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
2245 * points should be noted about the implementation:
2246 * * Each function keeps a local index variable 'idx' that points at the
2247 * current position within the parsed string. The global index is only
2248 * updated if the function could parse the corresponding syntactic unit
2250 * * Similarly, the functions keep track of indicators of inexactness ('#',
2251 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
2252 * global exactness information is only updated after each part has been
2253 * successfully parsed.
2254 * * Sequences of digits are parsed into temporary variables holding fixnums.
2255 * Only if these fixnums would overflow, the result variables are updated
2256 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
2257 * the temporary variables holding the fixnums are cleared, and the process
2258 * starts over again. If for example fixnums were able to store five decimal
2259 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
2260 * and the result was computed as 12345 * 100000 + 67890. In other words,
2261 * only every five digits two bignum operations were performed.
2264 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
2266 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
2268 /* In non ASCII-style encodings the following macro might not work. */
2269 #define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
2272 mem2uinteger (const char* mem
, size_t len
, unsigned int *p_idx
,
2273 unsigned int radix
, enum t_exactness
*p_exactness
)
2275 unsigned int idx
= *p_idx
;
2276 unsigned int hash_seen
= 0;
2277 scm_t_bits shift
= 1;
2279 unsigned int digit_value
;
2289 digit_value
= XDIGIT2UINT (c
);
2290 if (digit_value
>= radix
)
2294 result
= SCM_MAKINUM (digit_value
);
2302 digit_value
= XDIGIT2UINT (c
);
2303 if (digit_value
>= radix
)
2315 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
2317 result
= scm_product (result
, SCM_MAKINUM (shift
));
2319 result
= scm_sum (result
, SCM_MAKINUM (add
));
2326 shift
= shift
* radix
;
2327 add
= add
* radix
+ digit_value
;
2332 result
= scm_product (result
, SCM_MAKINUM (shift
));
2334 result
= scm_sum (result
, SCM_MAKINUM (add
));
2338 *p_exactness
= INEXACT
;
2344 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2345 * covers the parts of the rules that start at a potential point. The value
2346 * of the digits up to the point have been parsed by the caller and are given
2347 * in variable result. The content of *p_exactness indicates, whether a hash
2348 * has already been seen in the digits before the point.
2351 /* In non ASCII-style encodings the following macro might not work. */
2352 #define DIGIT2UINT(d) ((d) - '0')
2355 mem2decimal_from_point (SCM result
, const char* mem
, size_t len
,
2356 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
2358 unsigned int idx
= *p_idx
;
2359 enum t_exactness x
= *p_exactness
;
2364 if (mem
[idx
] == '.')
2366 scm_t_bits shift
= 1;
2368 unsigned int digit_value
;
2369 SCM big_shift
= SCM_MAKINUM (1);
2380 digit_value
= DIGIT2UINT (c
);
2391 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
2393 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2394 result
= scm_product (result
, SCM_MAKINUM (shift
));
2396 result
= scm_sum (result
, SCM_MAKINUM (add
));
2404 add
= add
* 10 + digit_value
;
2410 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2411 result
= scm_product (result
, SCM_MAKINUM (shift
));
2412 result
= scm_sum (result
, SCM_MAKINUM (add
));
2415 result
= scm_divide (result
, big_shift
);
2417 /* We've seen a decimal point, thus the value is implicitly inexact. */
2429 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2460 exponent
= DIGIT2UINT (c
);
2467 if (exponent
<= SCM_MAXEXP
)
2468 exponent
= exponent
* 10 + DIGIT2UINT (c
);
2474 if (exponent
> SCM_MAXEXP
)
2476 size_t exp_len
= idx
- start
;
2477 SCM exp_string
= scm_mem2string (&mem
[start
], exp_len
);
2478 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
2479 scm_out_of_range ("string->number", exp_num
);
2482 e
= scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent
));
2484 result
= scm_product (result
, e
);
2486 result
= scm_divide (result
, e
);
2488 /* We've seen an exponent, thus the value is implicitly inexact. */
2506 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2509 mem2ureal (const char* mem
, size_t len
, unsigned int *p_idx
,
2510 unsigned int radix
, enum t_exactness
*p_exactness
)
2512 unsigned int idx
= *p_idx
;
2517 if (mem
[idx
] == '.')
2521 else if (idx
+ 1 == len
)
2523 else if (!isdigit (mem
[idx
+ 1]))
2526 return mem2decimal_from_point (SCM_MAKINUM (0), mem
, len
,
2527 p_idx
, p_exactness
);
2531 enum t_exactness x
= EXACT
;
2535 uinteger
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2536 if (SCM_FALSEP (uinteger
))
2541 else if (mem
[idx
] == '/')
2547 divisor
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2548 if (SCM_FALSEP (divisor
))
2551 result
= scm_divide (uinteger
, divisor
);
2553 else if (radix
== 10)
2555 result
= mem2decimal_from_point (uinteger
, mem
, len
, &idx
, &x
);
2556 if (SCM_FALSEP (result
))
2571 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2574 mem2complex (const char* mem
, size_t len
, unsigned int idx
,
2575 unsigned int radix
, enum t_exactness
*p_exactness
)
2599 ureal
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2600 if (SCM_FALSEP (ureal
))
2602 /* input must be either +i or -i */
2607 if (mem
[idx
] == 'i' || mem
[idx
] == 'I')
2613 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign
));
2621 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
2630 /* either +<ureal>i or -<ureal>i */
2637 return scm_make_rectangular (SCM_MAKINUM (0), ureal
);
2640 /* polar input: <real>@<real>. */
2665 angle
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2666 if (SCM_FALSEP (angle
))
2672 angle
= scm_difference (angle
, SCM_UNDEFINED
);
2674 result
= scm_make_polar (ureal
, angle
);
2679 /* expecting input matching <real>[+-]<ureal>?i */
2686 int sign
= (c
== '+') ? 1 : -1;
2687 SCM imag
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2689 if (SCM_FALSEP (imag
))
2690 imag
= SCM_MAKINUM (sign
);
2691 else if (sign
== -1)
2692 imag
= scm_difference (imag
, SCM_UNDEFINED
);
2696 if (mem
[idx
] != 'i' && mem
[idx
] != 'I')
2703 return scm_make_rectangular (ureal
, imag
);
2712 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2714 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
2717 scm_i_mem2number (const char* mem
, size_t len
, unsigned int default_radix
)
2719 unsigned int idx
= 0;
2720 unsigned int radix
= NO_RADIX
;
2721 enum t_exactness forced_x
= NO_EXACTNESS
;
2722 enum t_exactness implicit_x
= EXACT
;
2725 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2726 while (idx
+ 2 < len
&& mem
[idx
] == '#')
2728 switch (mem
[idx
+ 1])
2731 if (radix
!= NO_RADIX
)
2736 if (radix
!= NO_RADIX
)
2741 if (forced_x
!= NO_EXACTNESS
)
2746 if (forced_x
!= NO_EXACTNESS
)
2751 if (radix
!= NO_RADIX
)
2756 if (radix
!= NO_RADIX
)
2766 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2767 if (radix
== NO_RADIX
)
2768 result
= mem2complex (mem
, len
, idx
, default_radix
, &implicit_x
);
2770 result
= mem2complex (mem
, len
, idx
, (unsigned int) radix
, &implicit_x
);
2772 if (SCM_FALSEP (result
))
2778 if (SCM_INEXACTP (result
))
2779 /* FIXME: This may change the value. */
2780 return scm_inexact_to_exact (result
);
2784 if (SCM_INEXACTP (result
))
2787 return scm_exact_to_inexact (result
);
2790 if (implicit_x
== INEXACT
)
2792 if (SCM_INEXACTP (result
))
2795 return scm_exact_to_inexact (result
);
2803 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2804 (SCM string
, SCM radix
),
2805 "Return a number of the maximally precise representation\n"
2806 "expressed by the given @var{string}. @var{radix} must be an\n"
2807 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2808 "is a default radix that may be overridden by an explicit radix\n"
2809 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2810 "supplied, then the default radix is 10. If string is not a\n"
2811 "syntactically valid notation for a number, then\n"
2812 "@code{string->number} returns @code{#f}.")
2813 #define FUNC_NAME s_scm_string_to_number
2817 SCM_VALIDATE_STRING (1, string
);
2818 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2819 answer
= scm_i_mem2number (SCM_STRING_CHARS (string
),
2820 SCM_STRING_LENGTH (string
),
2822 return scm_return_first (answer
, string
);
2827 /*** END strs->nums ***/
2831 scm_make_real (double x
)
2834 z
= scm_double_cell (scm_tc16_real
, 0, 0, 0);
2835 SCM_REAL_VALUE (z
) = x
;
2841 scm_make_complex (double x
, double y
)
2844 return scm_make_real (x
);
2847 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_gc_malloc (2*sizeof (double),
2849 SCM_COMPLEX_REAL (z
) = x
;
2850 SCM_COMPLEX_IMAG (z
) = y
;
2857 scm_bigequal (SCM x
, SCM y
)
2860 if (0 == scm_bigcomp (x
, y
))
2867 scm_real_equalp (SCM x
, SCM y
)
2869 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2873 scm_complex_equalp (SCM x
, SCM y
)
2875 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2876 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2881 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2882 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2883 * "else. Note that the sets of complex, real, rational and\n"
2884 * "integer values form subsets of the set of numbers, i. e. the\n"
2885 * "predicate will be fulfilled for any number."
2887 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2889 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2890 "otherwise. Note that the sets of real, rational and integer\n"
2891 "values form subsets of the set of complex numbers, i. e. the\n"
2892 "predicate will also be fulfilled if @var{x} is a real,\n"
2893 "rational or integer number.")
2894 #define FUNC_NAME s_scm_number_p
2896 return SCM_BOOL (SCM_NUMBERP (x
));
2901 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2902 /* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
2903 * "Note that the sets of integer and rational values form a subset\n"
2904 * "of the set of real numbers, i. e. the predicate will also\n"
2905 * "be fulfilled if @var{x} is an integer or a rational number."
2907 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2909 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
2910 "otherwise. Note that the set of integer values forms a subset of\n"
2911 "the set of rational numbers, i. e. the predicate will also be\n"
2912 "fulfilled if @var{x} is an integer number. Real numbers\n"
2913 "will also satisfy this predicate, because of their limited\n"
2915 #define FUNC_NAME s_scm_real_p
2917 if (SCM_INUMP (x
)) {
2919 } else if (SCM_IMP (x
)) {
2921 } else if (SCM_REALP (x
)) {
2923 } else if (SCM_BIGP (x
)) {
2932 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2934 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2936 #define FUNC_NAME s_scm_integer_p
2945 if (!SCM_INEXACTP (x
))
2947 if (SCM_COMPLEXP (x
))
2949 r
= SCM_REAL_VALUE (x
);
2957 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
2959 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
2961 #define FUNC_NAME s_scm_inexact_p
2963 return SCM_BOOL (SCM_INEXACTP (x
));
2968 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
2969 /* "Return @code{#t} if all parameters are numerically equal." */
2971 scm_num_eq_p (SCM x
, SCM y
)
2973 if (SCM_INUMP (x
)) {
2974 long xx
= SCM_INUM (x
);
2975 if (SCM_INUMP (y
)) {
2976 long yy
= SCM_INUM (y
);
2977 return SCM_BOOL (xx
== yy
);
2978 } else if (SCM_BIGP (y
)) {
2980 } else if (SCM_REALP (y
)) {
2981 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
2982 } else if (SCM_COMPLEXP (y
)) {
2983 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
2984 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2986 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2988 } else if (SCM_BIGP (x
)) {
2989 if (SCM_INUMP (y
)) {
2991 } else if (SCM_BIGP (y
)) {
2992 return SCM_BOOL (0 == scm_bigcomp (x
, y
));
2993 } else if (SCM_REALP (y
)) {
2994 return SCM_BOOL (scm_i_big2dbl (x
) == SCM_REAL_VALUE (y
));
2995 } else if (SCM_COMPLEXP (y
)) {
2996 return SCM_BOOL ((scm_i_big2dbl (x
) == SCM_COMPLEX_REAL (y
))
2997 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2999 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3001 } else if (SCM_REALP (x
)) {
3002 if (SCM_INUMP (y
)) {
3003 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3004 } else if (SCM_BIGP (y
)) {
3005 return SCM_BOOL (SCM_REAL_VALUE (x
) == scm_i_big2dbl (y
));
3006 } else if (SCM_REALP (y
)) {
3007 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3008 } else if (SCM_COMPLEXP (y
)) {
3009 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3010 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3012 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3014 } else if (SCM_COMPLEXP (x
)) {
3015 if (SCM_INUMP (y
)) {
3016 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3017 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3018 } else if (SCM_BIGP (y
)) {
3019 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == scm_i_big2dbl (y
))
3020 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3021 } else if (SCM_REALP (y
)) {
3022 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3023 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3024 } else if (SCM_COMPLEXP (y
)) {
3025 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3026 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3028 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3031 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3036 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3037 /* "Return @code{#t} if the list of parameters is monotonically\n"
3041 scm_less_p (SCM x
, SCM y
)
3043 if (SCM_INUMP (x
)) {
3044 long xx
= SCM_INUM (x
);
3045 if (SCM_INUMP (y
)) {
3046 long yy
= SCM_INUM (y
);
3047 return SCM_BOOL (xx
< yy
);
3048 } else if (SCM_BIGP (y
)) {
3049 return SCM_BOOL (!SCM_BIGSIGN (y
));
3050 } else if (SCM_REALP (y
)) {
3051 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3053 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3055 } else if (SCM_BIGP (x
)) {
3056 if (SCM_INUMP (y
)) {
3057 return SCM_BOOL (SCM_BIGSIGN (x
));
3058 } else if (SCM_BIGP (y
)) {
3059 return SCM_BOOL (1 == scm_bigcomp (x
, y
));
3060 } else if (SCM_REALP (y
)) {
3061 return SCM_BOOL (scm_i_big2dbl (x
) < SCM_REAL_VALUE (y
));
3063 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3065 } else if (SCM_REALP (x
)) {
3066 if (SCM_INUMP (y
)) {
3067 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3068 } else if (SCM_BIGP (y
)) {
3069 return SCM_BOOL (SCM_REAL_VALUE (x
) < scm_i_big2dbl (y
));
3070 } else if (SCM_REALP (y
)) {
3071 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3073 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3076 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3081 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3082 /* "Return @code{#t} if the list of parameters is monotonically\n"
3085 #define FUNC_NAME s_scm_gr_p
3087 scm_gr_p (SCM x
, SCM y
)
3089 if (!SCM_NUMBERP (x
))
3090 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3091 else if (!SCM_NUMBERP (y
))
3092 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3094 return scm_less_p (y
, x
);
3099 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3100 /* "Return @code{#t} if the list of parameters is monotonically\n"
3103 #define FUNC_NAME s_scm_leq_p
3105 scm_leq_p (SCM x
, SCM y
)
3107 if (!SCM_NUMBERP (x
))
3108 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3109 else if (!SCM_NUMBERP (y
))
3110 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3112 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3117 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3118 /* "Return @code{#t} if the list of parameters is monotonically\n"
3121 #define FUNC_NAME s_scm_geq_p
3123 scm_geq_p (SCM x
, SCM y
)
3125 if (!SCM_NUMBERP (x
))
3126 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3127 else if (!SCM_NUMBERP (y
))
3128 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3130 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3135 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3136 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3142 if (SCM_INUMP (z
)) {
3143 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3144 } else if (SCM_BIGP (z
)) {
3146 } else if (SCM_REALP (z
)) {
3147 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3148 } else if (SCM_COMPLEXP (z
)) {
3149 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3150 && SCM_COMPLEX_IMAG (z
) == 0.0);
3152 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3157 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3158 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3162 scm_positive_p (SCM x
)
3164 if (SCM_INUMP (x
)) {
3165 return SCM_BOOL (SCM_INUM (x
) > 0);
3166 } else if (SCM_BIGP (x
)) {
3167 return SCM_BOOL (!SCM_BIGSIGN (x
));
3168 } else if (SCM_REALP (x
)) {
3169 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3171 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3176 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3177 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3181 scm_negative_p (SCM x
)
3183 if (SCM_INUMP (x
)) {
3184 return SCM_BOOL (SCM_INUM (x
) < 0);
3185 } else if (SCM_BIGP (x
)) {
3186 return SCM_BOOL (SCM_BIGSIGN (x
));
3187 } else if (SCM_REALP (x
)) {
3188 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3190 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3195 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3196 /* "Return the maximum of all parameter values."
3199 scm_max (SCM x
, SCM y
)
3201 if (SCM_UNBNDP (y
)) {
3202 if (SCM_UNBNDP (x
)) {
3203 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
3204 } else if (SCM_NUMBERP (x
)) {
3207 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3211 if (SCM_INUMP (x
)) {
3212 long xx
= SCM_INUM (x
);
3213 if (SCM_INUMP (y
)) {
3214 long yy
= SCM_INUM (y
);
3215 return (xx
< yy
) ? y
: x
;
3216 } else if (SCM_BIGP (y
)) {
3217 return SCM_BIGSIGN (y
) ? x
: y
;
3218 } else if (SCM_REALP (y
)) {
3220 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3222 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3224 } else if (SCM_BIGP (x
)) {
3225 if (SCM_INUMP (y
)) {
3226 return SCM_BIGSIGN (x
) ? y
: x
;
3227 } else if (SCM_BIGP (y
)) {
3228 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3229 } else if (SCM_REALP (y
)) {
3230 double z
= scm_i_big2dbl (x
);
3231 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3233 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3235 } else if (SCM_REALP (x
)) {
3236 if (SCM_INUMP (y
)) {
3237 double z
= SCM_INUM (y
);
3238 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3239 } else if (SCM_BIGP (y
)) {
3240 double z
= scm_i_big2dbl (y
);
3241 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3242 } else if (SCM_REALP (y
)) {
3243 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? y
: x
;
3245 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3248 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3253 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3254 /* "Return the minium of all parameter values."
3257 scm_min (SCM x
, SCM y
)
3259 if (SCM_UNBNDP (y
)) {
3260 if (SCM_UNBNDP (x
)) {
3261 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
3262 } else if (SCM_NUMBERP (x
)) {
3265 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3269 if (SCM_INUMP (x
)) {
3270 long xx
= SCM_INUM (x
);
3271 if (SCM_INUMP (y
)) {
3272 long yy
= SCM_INUM (y
);
3273 return (xx
< yy
) ? x
: y
;
3274 } else if (SCM_BIGP (y
)) {
3275 return SCM_BIGSIGN (y
) ? y
: x
;
3276 } else if (SCM_REALP (y
)) {
3278 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3280 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3282 } else if (SCM_BIGP (x
)) {
3283 if (SCM_INUMP (y
)) {
3284 return SCM_BIGSIGN (x
) ? x
: y
;
3285 } else if (SCM_BIGP (y
)) {
3286 return (-1 == scm_bigcomp (x
, y
)) ? y
: x
;
3287 } else if (SCM_REALP (y
)) {
3288 double z
= scm_i_big2dbl (x
);
3289 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3291 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3293 } else if (SCM_REALP (x
)) {
3294 if (SCM_INUMP (y
)) {
3295 double z
= SCM_INUM (y
);
3296 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3297 } else if (SCM_BIGP (y
)) {
3298 double z
= scm_i_big2dbl (y
);
3299 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3300 } else if (SCM_REALP (y
)) {
3301 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? x
: y
;
3303 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3306 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3311 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3312 /* "Return the sum of all parameter values. Return 0 if called without\n"
3316 scm_sum (SCM x
, SCM y
)
3318 if (SCM_UNBNDP (y
)) {
3319 if (SCM_UNBNDP (x
)) {
3321 } else if (SCM_NUMBERP (x
)) {
3324 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3328 if (SCM_INUMP (x
)) {
3329 long int xx
= SCM_INUM (x
);
3330 if (SCM_INUMP (y
)) {
3331 long int yy
= SCM_INUM (y
);
3332 long int z
= xx
+ yy
;
3333 if (SCM_FIXABLE (z
)) {
3334 return SCM_MAKINUM (z
);
3337 return scm_i_long2big (z
);
3338 #else /* SCM_BIGDIG */
3339 return scm_make_real ((double) z
);
3340 #endif /* SCM_BIGDIG */
3342 } else if (SCM_BIGP (y
)) {
3345 long int xx
= SCM_INUM (x
);
3346 #ifndef SCM_DIGSTOOBIG
3347 long z
= scm_pseudolong (xx
);
3348 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3349 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3350 #else /* SCM_DIGSTOOBIG */
3351 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3352 scm_longdigs (xx
, zdigs
);
3353 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3354 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3355 #endif /* SCM_DIGSTOOBIG */
3357 } else if (SCM_REALP (y
)) {
3358 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3359 } else if (SCM_COMPLEXP (y
)) {
3360 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3361 SCM_COMPLEX_IMAG (y
));
3363 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3365 } else if (SCM_BIGP (x
)) {
3366 if (SCM_INUMP (y
)) {
3369 } else if (SCM_BIGP (y
)) {
3370 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
)) {
3373 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3374 SCM_BIGSIGN (x
), y
, 0);
3375 } else if (SCM_REALP (y
)) {
3376 return scm_make_real (scm_i_big2dbl (x
) + SCM_REAL_VALUE (y
));
3377 } else if (SCM_COMPLEXP (y
)) {
3378 return scm_make_complex (scm_i_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3379 SCM_COMPLEX_IMAG (y
));
3381 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3383 } else if (SCM_REALP (x
)) {
3384 if (SCM_INUMP (y
)) {
3385 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3386 } else if (SCM_BIGP (y
)) {
3387 return scm_make_real (SCM_REAL_VALUE (x
) + scm_i_big2dbl (y
));
3388 } else if (SCM_REALP (y
)) {
3389 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3390 } else if (SCM_COMPLEXP (y
)) {
3391 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3392 SCM_COMPLEX_IMAG (y
));
3394 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3396 } else if (SCM_COMPLEXP (x
)) {
3397 if (SCM_INUMP (y
)) {
3398 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3399 SCM_COMPLEX_IMAG (x
));
3400 } else if (SCM_BIGP (y
)) {
3401 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_i_big2dbl (y
),
3402 SCM_COMPLEX_IMAG (x
));
3403 } else if (SCM_REALP (y
)) {
3404 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3405 SCM_COMPLEX_IMAG (x
));
3406 } else if (SCM_COMPLEXP (y
)) {
3407 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3408 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3410 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3413 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3418 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3419 /* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3420 * the sum of all but the first argument are subtracted from the first
3422 #define FUNC_NAME s_difference
3424 scm_difference (SCM x
, SCM y
)
3426 if (SCM_UNBNDP (y
)) {
3427 if (SCM_UNBNDP (x
)) {
3428 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3429 } else if (SCM_INUMP (x
)) {
3430 long xx
= -SCM_INUM (x
);
3431 if (SCM_FIXABLE (xx
)) {
3432 return SCM_MAKINUM (xx
);
3435 return scm_i_long2big (xx
);
3437 return scm_make_real ((double) xx
);
3440 } else if (SCM_BIGP (x
)) {
3441 SCM z
= scm_i_copybig (x
, !SCM_BIGSIGN (x
));
3442 unsigned int digs
= SCM_NUMDIGS (z
);
3443 unsigned int size
= digs
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
;
3444 return size
<= sizeof (SCM
) ? scm_i_big2inum (z
, digs
) : z
;
3445 } else if (SCM_REALP (x
)) {
3446 return scm_make_real (-SCM_REAL_VALUE (x
));
3447 } else if (SCM_COMPLEXP (x
)) {
3448 return scm_make_complex (-SCM_COMPLEX_REAL (x
), -SCM_COMPLEX_IMAG (x
));
3450 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3454 if (SCM_INUMP (x
)) {
3455 long int xx
= SCM_INUM (x
);
3456 if (SCM_INUMP (y
)) {
3457 long int yy
= SCM_INUM (y
);
3458 long int z
= xx
- yy
;
3459 if (SCM_FIXABLE (z
)) {
3460 return SCM_MAKINUM (z
);
3463 return scm_i_long2big (z
);
3465 return scm_make_real ((double) z
);
3468 } else if (SCM_BIGP (y
)) {
3469 #ifndef SCM_DIGSTOOBIG
3470 long z
= scm_pseudolong (xx
);
3471 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3472 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3474 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3475 scm_longdigs (xx
, zdigs
);
3476 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3477 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3479 } else if (SCM_REALP (y
)) {
3480 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
3481 } else if (SCM_COMPLEXP (y
)) {
3482 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
3483 -SCM_COMPLEX_IMAG (y
));
3485 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3487 } else if (SCM_BIGP (x
)) {
3488 if (SCM_INUMP (y
)) {
3489 long int yy
= SCM_INUM (y
);
3490 #ifndef SCM_DIGSTOOBIG
3491 long z
= scm_pseudolong (yy
);
3492 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3493 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3495 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3496 scm_longdigs (yy
, zdigs
);
3497 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3498 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3500 } else if (SCM_BIGP (y
)) {
3501 return (SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3502 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3503 SCM_BIGSIGN (x
), y
, SCM_BIGSIGNFLAG
)
3504 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3505 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
, x
, 0);
3506 } else if (SCM_REALP (y
)) {
3507 return scm_make_real (scm_i_big2dbl (x
) - SCM_REAL_VALUE (y
));
3508 } else if (SCM_COMPLEXP (y
)) {
3509 return scm_make_complex (scm_i_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3510 - SCM_COMPLEX_IMAG (y
));
3512 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3514 } else if (SCM_REALP (x
)) {
3515 if (SCM_INUMP (y
)) {
3516 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
3517 } else if (SCM_BIGP (y
)) {
3518 return scm_make_real (SCM_REAL_VALUE (x
) - scm_i_big2dbl (y
));
3519 } else if (SCM_REALP (y
)) {
3520 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3521 } else if (SCM_COMPLEXP (y
)) {
3522 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3523 -SCM_COMPLEX_IMAG (y
));
3525 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3527 } else if (SCM_COMPLEXP (x
)) {
3528 if (SCM_INUMP (y
)) {
3529 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
3530 SCM_COMPLEX_IMAG (x
));
3531 } else if (SCM_BIGP (y
)) {
3532 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_i_big2dbl (y
),
3533 SCM_COMPLEX_IMAG (x
));
3534 } else if (SCM_REALP (y
)) {
3535 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3536 SCM_COMPLEX_IMAG (x
));
3537 } else if (SCM_COMPLEXP (y
)) {
3538 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3539 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3541 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3544 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3549 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3550 /* "Return the product of all arguments. If called without arguments,\n"
3554 scm_product (SCM x
, SCM y
)
3556 if (SCM_UNBNDP (y
)) {
3557 if (SCM_UNBNDP (x
)) {
3558 return SCM_MAKINUM (1L);
3559 } else if (SCM_NUMBERP (x
)) {
3562 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3566 if (SCM_INUMP (x
)) {
3574 } else if (xx
== 1) {
3578 if (SCM_INUMP (y
)) {
3579 long yy
= SCM_INUM (y
);
3581 SCM k
= SCM_MAKINUM (kk
);
3582 if (kk
!= SCM_INUM (k
) || kk
/ xx
!= yy
) {
3584 int sgn
= (xx
< 0) ^ (yy
< 0);
3585 #ifndef SCM_DIGSTOOBIG
3586 long i
= scm_pseudolong (xx
);
3587 long j
= scm_pseudolong (yy
);
3588 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3589 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3590 #else /* SCM_DIGSTOOBIG */
3591 SCM_BIGDIG xdigs
[SCM_DIGSPERLONG
];
3592 SCM_BIGDIG ydigs
[SCM_DIGSPERLONG
];
3593 scm_longdigs (xx
, xdigs
);
3594 scm_longdigs (yy
, ydigs
);
3595 return scm_mulbig (xdigs
, SCM_DIGSPERLONG
,
3596 ydigs
, SCM_DIGSPERLONG
,
3600 return scm_make_real (((double) xx
) * ((double) yy
));
3605 } else if (SCM_BIGP (y
)) {
3606 #ifndef SCM_DIGSTOOBIG
3607 long z
= scm_pseudolong (xx
);
3608 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3609 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3610 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3612 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3613 scm_longdigs (xx
, zdigs
);
3614 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3615 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3616 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3618 } else if (SCM_REALP (y
)) {
3619 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3620 } else if (SCM_COMPLEXP (y
)) {
3621 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3622 xx
* SCM_COMPLEX_IMAG (y
));
3624 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3626 } else if (SCM_BIGP (x
)) {
3627 if (SCM_INUMP (y
)) {
3630 } else if (SCM_BIGP (y
)) {
3631 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3632 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3633 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3634 } else if (SCM_REALP (y
)) {
3635 return scm_make_real (scm_i_big2dbl (x
) * SCM_REAL_VALUE (y
));
3636 } else if (SCM_COMPLEXP (y
)) {
3637 double z
= scm_i_big2dbl (x
);
3638 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3639 z
* SCM_COMPLEX_IMAG (y
));
3641 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3643 } else if (SCM_REALP (x
)) {
3644 if (SCM_INUMP (y
)) {
3645 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3646 } else if (SCM_BIGP (y
)) {
3647 return scm_make_real (scm_i_big2dbl (y
) * SCM_REAL_VALUE (x
));
3648 } else if (SCM_REALP (y
)) {
3649 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
3650 } else if (SCM_COMPLEXP (y
)) {
3651 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
3652 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3654 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3656 } else if (SCM_COMPLEXP (x
)) {
3657 if (SCM_INUMP (y
)) {
3658 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3659 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3660 } else if (SCM_BIGP (y
)) {
3661 double z
= scm_i_big2dbl (y
);
3662 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
3663 z
* SCM_COMPLEX_IMAG (x
));
3664 } else if (SCM_REALP (y
)) {
3665 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3666 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
3667 } else if (SCM_COMPLEXP (y
)) {
3668 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
3669 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
3670 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3671 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3673 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3676 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3682 scm_num2dbl (SCM a
, const char *why
)
3683 #define FUNC_NAME why
3685 if (SCM_INUMP (a
)) {
3686 return (double) SCM_INUM (a
);
3687 } else if (SCM_BIGP (a
)) {
3688 return scm_i_big2dbl (a
);
3689 } else if (SCM_REALP (a
)) {
3690 return (SCM_REAL_VALUE (a
));
3692 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3698 /* The code below for complex division is adapted from the GNU
3699 libstdc++, which adapted it from f2c's libF77, and is subject to
3702 /****************************************************************
3703 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
3705 Permission to use, copy, modify, and distribute this software
3706 and its documentation for any purpose and without fee is hereby
3707 granted, provided that the above copyright notice appear in all
3708 copies and that both that the copyright notice and this
3709 permission notice and warranty disclaimer appear in supporting
3710 documentation, and that the names of AT&T Bell Laboratories or
3711 Bellcore or any of their entities not be used in advertising or
3712 publicity pertaining to distribution of the software without
3713 specific, written prior permission.
3715 AT&T and Bellcore disclaim all warranties with regard to this
3716 software, including all implied warranties of merchantability
3717 and fitness. In no event shall AT&T or Bellcore be liable for
3718 any special, indirect or consequential damages or any damages
3719 whatsoever resulting from loss of use, data or profits, whether
3720 in an action of contract, negligence or other tortious action,
3721 arising out of or in connection with the use or performance of
3723 ****************************************************************/
3725 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3726 /* Divide the first argument by the product of the remaining
3727 arguments. If called with one argument @var{z1}, 1/@var{z1} is
3729 #define FUNC_NAME s_divide
3731 scm_divide (SCM x
, SCM y
)
3735 if (SCM_UNBNDP (y
)) {
3736 if (SCM_UNBNDP (x
)) {
3737 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
3738 } else if (SCM_INUMP (x
)) {
3739 long xx
= SCM_INUM (x
);
3740 if (xx
== 1 || xx
== -1) {
3742 } else if (xx
== 0) {
3743 scm_num_overflow (s_divide
);
3745 return scm_make_real (1.0 / (double) xx
);
3747 } else if (SCM_BIGP (x
)) {
3748 return scm_make_real (1.0 / scm_i_big2dbl (x
));
3749 } else if (SCM_REALP (x
)) {
3750 double xx
= SCM_REAL_VALUE (x
);
3752 scm_num_overflow (s_divide
);
3754 return scm_make_real (1.0 / xx
);
3755 } else if (SCM_COMPLEXP (x
)) {
3756 double r
= SCM_COMPLEX_REAL (x
);
3757 double i
= SCM_COMPLEX_IMAG (x
);
3760 double d
= i
* (1.0 + t
* t
);
3761 return scm_make_complex (t
/ d
, -1.0 / d
);
3764 double d
= r
* (1.0 + t
* t
);
3765 return scm_make_complex (1.0 / d
, -t
/ d
);
3768 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3772 if (SCM_INUMP (x
)) {
3773 long xx
= SCM_INUM (x
);
3774 if (SCM_INUMP (y
)) {
3775 long yy
= SCM_INUM (y
);
3777 scm_num_overflow (s_divide
);
3778 } else if (xx
% yy
!= 0) {
3779 return scm_make_real ((double) xx
/ (double) yy
);
3782 if (SCM_FIXABLE (z
)) {
3783 return SCM_MAKINUM (z
);
3786 return scm_i_long2big (z
);
3788 return scm_make_real ((double) xx
/ (double) yy
);
3792 } else if (SCM_BIGP (y
)) {
3793 return scm_make_real ((double) xx
/ scm_i_big2dbl (y
));
3794 } else if (SCM_REALP (y
)) {
3795 double yy
= SCM_REAL_VALUE (y
);
3797 scm_num_overflow (s_divide
);
3799 return scm_make_real ((double) xx
/ yy
);
3800 } else if (SCM_COMPLEXP (y
)) {
3802 complex_div
: /* y _must_ be a complex number */
3804 double r
= SCM_COMPLEX_REAL (y
);
3805 double i
= SCM_COMPLEX_IMAG (y
);
3808 double d
= i
* (1.0 + t
* t
);
3809 return scm_make_complex ((a
* t
) / d
, -a
/ d
);
3812 double d
= r
* (1.0 + t
* t
);
3813 return scm_make_complex (a
/ d
, -(a
* t
) / d
);
3817 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3819 } else if (SCM_BIGP (x
)) {
3820 if (SCM_INUMP (y
)) {
3821 long int yy
= SCM_INUM (y
);
3823 scm_num_overflow (s_divide
);
3824 } else if (yy
== 1) {
3827 long z
= yy
< 0 ? -yy
: yy
;
3828 if (z
< SCM_BIGRAD
) {
3829 SCM w
= scm_i_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
3830 return scm_divbigdig (SCM_BDIGITS (w
), SCM_NUMDIGS (w
),
3832 ? scm_make_real (scm_i_big2dbl (x
) / (double) yy
)
3833 : scm_i_normbig (w
);
3836 #ifndef SCM_DIGSTOOBIG
3837 z
= scm_pseudolong (z
);
3838 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3839 (SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3840 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3842 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3843 scm_longdigs (z
, zdigs
);
3844 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3845 zdigs
, SCM_DIGSPERLONG
,
3846 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3848 return (!SCM_UNBNDP (w
))
3850 : scm_make_real (scm_i_big2dbl (x
) / (double) yy
);
3853 } else if (SCM_BIGP (y
)) {
3854 SCM w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3855 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3856 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 3);
3857 return (!SCM_UNBNDP (w
))
3859 : scm_make_real (scm_i_big2dbl (x
) / scm_i_big2dbl (y
));
3860 } else if (SCM_REALP (y
)) {
3861 double yy
= SCM_REAL_VALUE (y
);
3863 scm_num_overflow (s_divide
);
3865 return scm_make_real (scm_i_big2dbl (x
) / yy
);
3866 } else if (SCM_COMPLEXP (y
)) {
3867 a
= scm_i_big2dbl (x
);
3870 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3872 } else if (SCM_REALP (x
)) {
3873 double rx
= SCM_REAL_VALUE (x
);
3874 if (SCM_INUMP (y
)) {
3875 long int yy
= SCM_INUM (y
);
3877 scm_num_overflow (s_divide
);
3879 return scm_make_real (rx
/ (double) yy
);
3881 } else if (SCM_BIGP (y
)) {
3882 return scm_make_real (rx
/ scm_i_big2dbl (y
));
3883 } else if (SCM_REALP (y
)) {
3884 double yy
= SCM_REAL_VALUE (y
);
3886 scm_num_overflow (s_divide
);
3888 return scm_make_real (rx
/ yy
);
3889 } else if (SCM_COMPLEXP (y
)) {
3893 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3895 } else if (SCM_COMPLEXP (x
)) {
3896 double rx
= SCM_COMPLEX_REAL (x
);
3897 double ix
= SCM_COMPLEX_IMAG (x
);
3898 if (SCM_INUMP (y
)) {
3899 long int yy
= SCM_INUM (y
);
3901 scm_num_overflow (s_divide
);
3904 return scm_make_complex (rx
/ d
, ix
/ d
);
3906 } else if (SCM_BIGP (y
)) {
3907 double d
= scm_i_big2dbl (y
);
3908 return scm_make_complex (rx
/ d
, ix
/ d
);
3909 } else if (SCM_REALP (y
)) {
3910 double yy
= SCM_REAL_VALUE (y
);
3912 scm_num_overflow (s_divide
);
3914 return scm_make_complex (rx
/ yy
, ix
/ yy
);
3915 } else if (SCM_COMPLEXP (y
)) {
3916 double ry
= SCM_COMPLEX_REAL (y
);
3917 double iy
= SCM_COMPLEX_IMAG (y
);
3920 double d
= iy
* (1.0 + t
* t
);
3921 return scm_make_complex ((rx
* t
+ ix
) / d
, (ix
* t
- rx
) / d
);
3924 double d
= ry
* (1.0 + t
* t
);
3925 return scm_make_complex ((rx
+ ix
* t
) / d
, (ix
- rx
* t
) / d
);
3928 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3931 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
3936 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
3937 /* "Return the inverse hyperbolic sine of @var{x}."
3940 scm_asinh (double x
)
3942 return log (x
+ sqrt (x
* x
+ 1));
3948 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
3949 /* "Return the inverse hyperbolic cosine of @var{x}."
3952 scm_acosh (double x
)
3954 return log (x
+ sqrt (x
* x
- 1));
3960 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
3961 /* "Return the inverse hyperbolic tangent of @var{x}."
3964 scm_atanh (double x
)
3966 return 0.5 * log ((1 + x
) / (1 - x
));
3972 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
3973 /* "Round the inexact number @var{x} towards zero."
3976 scm_truncate (double x
)
3985 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
3986 /* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
3987 * "numbers, round towards even."
3990 scm_round (double x
)
3992 double plus_half
= x
+ 0.5;
3993 double result
= floor (plus_half
);
3994 /* Adjust so that the scm_round is towards even. */
3995 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
3996 ? result
- 1 : result
;
4000 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
4001 /* "Round the number @var{x} towards minus infinity."
4003 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
4004 /* "Round the number @var{x} towards infinity."
4006 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
4007 /* "Return the square root of the real number @var{x}."
4009 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
4010 /* "Return the absolute value of the real number @var{x}."
4012 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
4013 /* "Return the @var{x}th power of e."
4015 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
4016 /* "Return the natural logarithm of the real number @var{x}."
4018 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
4019 /* "Return the sine of the real number @var{x}."
4021 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
4022 /* "Return the cosine of the real number @var{x}."
4024 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
4025 /* "Return the tangent of the real number @var{x}."
4027 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
4028 /* "Return the arc sine of the real number @var{x}."
4030 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
4031 /* "Return the arc cosine of the real number @var{x}."
4033 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
4034 /* "Return the arc tangent of the real number @var{x}."
4036 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
4037 /* "Return the hyperbolic sine of the real number @var{x}."
4039 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
4040 /* "Return the hyperbolic cosine of the real number @var{x}."
4042 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
4043 /* "Return the hyperbolic tangent of the real number @var{x}."
4051 static void scm_two_doubles (SCM x
,
4053 const char *sstring
,
4057 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
4059 if (SCM_INUMP (x
)) {
4060 xy
->x
= SCM_INUM (x
);
4061 } else if (SCM_BIGP (x
)) {
4062 xy
->x
= scm_i_big2dbl (x
);
4063 } else if (SCM_REALP (x
)) {
4064 xy
->x
= SCM_REAL_VALUE (x
);
4066 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
4069 if (SCM_INUMP (y
)) {
4070 xy
->y
= SCM_INUM (y
);
4071 } else if (SCM_BIGP (y
)) {
4072 xy
->y
= scm_i_big2dbl (y
);
4073 } else if (SCM_REALP (y
)) {
4074 xy
->y
= SCM_REAL_VALUE (y
);
4076 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
4081 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
4083 "Return @var{x} raised to the power of @var{y}. This\n"
4084 "procedure does not accept complex arguments.")
4085 #define FUNC_NAME s_scm_sys_expt
4088 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4089 return scm_make_real (pow (xy
.x
, xy
.y
));
4094 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4096 "Return the arc tangent of the two arguments @var{x} and\n"
4097 "@var{y}. This is similar to calculating the arc tangent of\n"
4098 "@var{x} / @var{y}, except that the signs of both arguments\n"
4099 "are used to determine the quadrant of the result. This\n"
4100 "procedure does not accept complex arguments.")
4101 #define FUNC_NAME s_scm_sys_atan2
4104 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4105 return scm_make_real (atan2 (xy
.x
, xy
.y
));
4110 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4111 (SCM real
, SCM imaginary
),
4112 "Return a complex number constructed of the given @var{real} and\n"
4113 "@var{imaginary} parts.")
4114 #define FUNC_NAME s_scm_make_rectangular
4117 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
4118 return scm_make_complex (xy
.x
, xy
.y
);
4124 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4126 "Return the complex number @var{x} * e^(i * @var{y}).")
4127 #define FUNC_NAME s_scm_make_polar
4130 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4131 return scm_make_complex (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
4136 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4137 /* "Return the real part of the number @var{z}."
4140 scm_real_part (SCM z
)
4142 if (SCM_INUMP (z
)) {
4144 } else if (SCM_BIGP (z
)) {
4146 } else if (SCM_REALP (z
)) {
4148 } else if (SCM_COMPLEXP (z
)) {
4149 return scm_make_real (SCM_COMPLEX_REAL (z
));
4151 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4156 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4157 /* "Return the imaginary part of the number @var{z}."
4160 scm_imag_part (SCM z
)
4162 if (SCM_INUMP (z
)) {
4164 } else if (SCM_BIGP (z
)) {
4166 } else if (SCM_REALP (z
)) {
4168 } else if (SCM_COMPLEXP (z
)) {
4169 return scm_make_real (SCM_COMPLEX_IMAG (z
));
4171 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4176 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4177 /* "Return the magnitude of the number @var{z}. This is the same as\n"
4178 * "@code{abs} for real arguments, but also allows complex numbers."
4181 scm_magnitude (SCM z
)
4183 if (SCM_INUMP (z
)) {
4184 long int zz
= SCM_INUM (z
);
4187 } else if (SCM_POSFIXABLE (-zz
)) {
4188 return SCM_MAKINUM (-zz
);
4191 return scm_i_long2big (-zz
);
4193 scm_num_overflow (s_magnitude
);
4196 } else if (SCM_BIGP (z
)) {
4197 if (!SCM_BIGSIGN (z
)) {
4200 return scm_i_copybig (z
, 0);
4202 } else if (SCM_REALP (z
)) {
4203 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
4204 } else if (SCM_COMPLEXP (z
)) {
4205 double r
= SCM_COMPLEX_REAL (z
);
4206 double i
= SCM_COMPLEX_IMAG (z
);
4207 return scm_make_real (sqrt (i
* i
+ r
* r
));
4209 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4214 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
4215 /* "Return the angle of the complex number @var{z}."
4220 if (SCM_INUMP (z
)) {
4221 if (SCM_INUM (z
) >= 0) {
4222 return scm_make_real (atan2 (0.0, 1.0));
4224 return scm_make_real (atan2 (0.0, -1.0));
4226 } else if (SCM_BIGP (z
)) {
4227 if (SCM_BIGSIGN (z
)) {
4228 return scm_make_real (atan2 (0.0, -1.0));
4230 return scm_make_real (atan2 (0.0, 1.0));
4232 } else if (SCM_REALP (z
)) {
4233 return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z
)));
4234 } else if (SCM_COMPLEXP (z
)) {
4235 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
4237 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
4242 SCM_GPROC (s_exact_to_inexact
, "exact->inexact", 1, 0, 0, scm_exact_to_inexact
, g_exact_to_inexact
);
4243 /* Convert the number @var{x} to its inexact representation.\n"
4246 scm_exact_to_inexact (SCM z
)
4249 return scm_make_real ((double) SCM_INUM (z
));
4250 else if (SCM_BIGP (z
))
4251 return scm_make_real (scm_i_big2dbl (z
));
4252 else if (SCM_INEXACTP (z
))
4255 SCM_WTA_DISPATCH_1 (g_exact_to_inexact
, z
, 1, s_exact_to_inexact
);
4259 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4261 "Return an exact number that is numerically closest to @var{z}.")
4262 #define FUNC_NAME s_scm_inexact_to_exact
4264 if (SCM_INUMP (z
)) {
4266 } else if (SCM_BIGP (z
)) {
4268 } else if (SCM_REALP (z
)) {
4269 double u
= floor (SCM_REAL_VALUE (z
) + 0.5);
4271 if (SCM_FIXABLE (lu
)) {
4272 return SCM_MAKINUM (lu
);
4274 } else if (isfinite (u
)) {
4275 return scm_i_dbl2big (u
);
4278 scm_num_overflow (s_scm_inexact_to_exact
);
4281 SCM_WRONG_TYPE_ARG (1, z
);
4288 /* d must be integer */
4291 scm_i_dbl2big (double d
)
4297 double u
= (d
< 0) ? -d
: d
;
4298 while (0 != floor (u
))
4303 ans
= scm_i_mkbig (i
, d
< 0);
4304 digits
= SCM_BDIGITS (ans
);
4312 #ifndef SCM_RECKLESS
4314 scm_num_overflow ("dbl2big");
4320 scm_i_big2dbl (SCM b
)
4323 size_t i
= SCM_NUMDIGS (b
);
4324 SCM_BIGDIG
*digits
= SCM_BDIGITS (b
);
4326 ans
= digits
[i
] + SCM_BIGRAD
* ans
;
4327 if (SCM_BIGSIGN (b
))
4334 #ifdef HAVE_LONG_LONGS
4336 # define ULLONG_MAX ((unsigned long long) (-1))
4337 # define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
4338 # define LLONG_MIN (~LLONG_MAX)
4342 /* Parameters for creating integer conversion routines.
4344 Define the following preprocessor macros before including
4345 "libguile/num2integral.i.c":
4347 NUM2INTEGRAL - the name of the function for converting from a
4348 Scheme object to the integral type. This function
4349 will be defined when including "num2integral.i.c".
4351 INTEGRAL2NUM - the name of the function for converting from the
4352 integral type to a Scheme object. This function
4355 INTEGRAL2BIG - the name of an internal function that createas a
4356 bignum from the integral type. This function will
4357 be defined. The name should start with "scm_i_".
4359 ITYPE - the name of the integral type.
4361 UNSIGNED - Define this when ITYPE is an unsigned type. Do not
4362 define it otherwise.
4365 - the name of the the unsigned variant of the
4366 integral type. If you don't define this, it defaults
4367 to "unsigned ITYPE" for signed types and simply "ITYPE"
4370 SIZEOF_ITYPE - an expression giving the size of the integral type in
4371 bytes. This expression must be computable by the
4372 preprocessor. If you don't know a value for this,
4373 don't define it. The purpose of this parameter is
4374 mainly to suppress some warnings. The generated
4375 code will work correctly without it.
4378 #define NUM2INTEGRAL scm_num2short
4379 #define INTEGRAL2NUM scm_short2num
4380 #define INTEGRAL2BIG scm_i_short2big
4382 #define SIZEOF_ITYPE SIZEOF_SHORT
4383 #include "libguile/num2integral.i.c"
4385 #define NUM2INTEGRAL scm_num2ushort
4386 #define INTEGRAL2NUM scm_ushort2num
4387 #define INTEGRAL2BIG scm_i_ushort2big
4389 #define ITYPE unsigned short
4390 #define SIZEOF_ITYPE SIZEOF_SHORT
4391 #include "libguile/num2integral.i.c"
4393 #define NUM2INTEGRAL scm_num2int
4394 #define INTEGRAL2NUM scm_int2num
4395 #define INTEGRAL2BIG scm_i_int2big
4397 #define SIZEOF_ITYPE SIZEOF_INT
4398 #include "libguile/num2integral.i.c"
4400 #define NUM2INTEGRAL scm_num2uint
4401 #define INTEGRAL2NUM scm_uint2num
4402 #define INTEGRAL2BIG scm_i_uint2big
4404 #define ITYPE unsigned int
4405 #define SIZEOF_ITYPE SIZEOF_INT
4406 #include "libguile/num2integral.i.c"
4408 #define NUM2INTEGRAL scm_num2long
4409 #define INTEGRAL2NUM scm_long2num
4410 #define INTEGRAL2BIG scm_i_long2big
4412 #define SIZEOF_ITYPE SIZEOF_LONG
4413 #include "libguile/num2integral.i.c"
4415 #define NUM2INTEGRAL scm_num2ulong
4416 #define INTEGRAL2NUM scm_ulong2num
4417 #define INTEGRAL2BIG scm_i_ulong2big
4419 #define ITYPE unsigned long
4420 #define SIZEOF_ITYPE SIZEOF_LONG
4421 #include "libguile/num2integral.i.c"
4423 #define NUM2INTEGRAL scm_num2ptrdiff
4424 #define INTEGRAL2NUM scm_ptrdiff2num
4425 #define INTEGRAL2BIG scm_i_ptrdiff2big
4426 #define ITYPE ptrdiff_t
4427 #define UNSIGNED_ITYPE size_t
4428 #define SIZEOF_ITYPE SIZEOF_PTRDIFF_T
4429 #include "libguile/num2integral.i.c"
4431 #define NUM2INTEGRAL scm_num2size
4432 #define INTEGRAL2NUM scm_size2num
4433 #define INTEGRAL2BIG scm_i_size2big
4435 #define ITYPE size_t
4436 #define SIZEOF_ITYPE SIZEOF_SIZE_T
4437 #include "libguile/num2integral.i.c"
4439 #ifdef HAVE_LONG_LONGS
4441 #ifndef ULONG_LONG_MAX
4442 #define ULONG_LONG_MAX (~0ULL)
4445 #define NUM2INTEGRAL scm_num2long_long
4446 #define INTEGRAL2NUM scm_long_long2num
4447 #define INTEGRAL2BIG scm_i_long_long2big
4448 #define ITYPE long long
4449 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
4450 #include "libguile/num2integral.i.c"
4452 #define NUM2INTEGRAL scm_num2ulong_long
4453 #define INTEGRAL2NUM scm_ulong_long2num
4454 #define INTEGRAL2BIG scm_i_ulong_long2big
4456 #define ITYPE unsigned long long
4457 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
4458 #include "libguile/num2integral.i.c"
4460 #endif /* HAVE_LONG_LONGS */
4462 #define NUM2FLOAT scm_num2float
4463 #define FLOAT2NUM scm_float2num
4465 #include "libguile/num2float.i.c"
4467 #define NUM2FLOAT scm_num2double
4468 #define FLOAT2NUM scm_double2num
4469 #define FTYPE double
4470 #include "libguile/num2float.i.c"
4475 #define SIZE_MAX ((size_t) (-1))
4478 #define PTRDIFF_MIN \
4479 ((ptrdiff_t) ((ptrdiff_t) 1 << (sizeof (ptrdiff_t) * 8 - 1)))
4482 #define PTRDIFF_MAX (~ PTRDIFF_MIN)
4485 #define CHECK(type, v) \
4487 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
4506 CHECK (ptrdiff
, -1);
4508 CHECK (short, SHRT_MAX
);
4509 CHECK (short, SHRT_MIN
);
4510 CHECK (ushort
, USHRT_MAX
);
4511 CHECK (int, INT_MAX
);
4512 CHECK (int, INT_MIN
);
4513 CHECK (uint
, UINT_MAX
);
4514 CHECK (long, LONG_MAX
);
4515 CHECK (long, LONG_MIN
);
4516 CHECK (ulong
, ULONG_MAX
);
4517 CHECK (size
, SIZE_MAX
);
4518 CHECK (ptrdiff
, PTRDIFF_MAX
);
4519 CHECK (ptrdiff
, PTRDIFF_MIN
);
4521 #ifdef HAVE_LONG_LONGS
4522 CHECK (long_long
, 0LL);
4523 CHECK (ulong_long
, 0ULL);
4524 CHECK (long_long
, -1LL);
4525 CHECK (long_long
, LLONG_MAX
);
4526 CHECK (long_long
, LLONG_MIN
);
4527 CHECK (ulong_long
, ULLONG_MAX
);
4534 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
4535 if (!SCM_FALSEP (data)) abort();
4538 check_body (void *data
)
4540 SCM num
= *(SCM
*) data
;
4541 scm_num2ulong (num
, 1, NULL
);
4543 return SCM_UNSPECIFIED
;
4547 check_handler (void *data
, SCM tag
, SCM throw_args
)
4549 SCM
*num
= (SCM
*) data
;
4552 return SCM_UNSPECIFIED
;
4555 SCM_DEFINE (scm_sys_check_number_conversions
, "%check-number-conversions", 0, 0, 0,
4557 "Number conversion sanity checking.")
4558 #define FUNC_NAME s_scm_sys_check_number_conversions
4560 SCM data
= SCM_MAKINUM (-1);
4562 data
= scm_int2num (INT_MIN
);
4564 data
= scm_ulong2num (ULONG_MAX
);
4565 data
= scm_difference (SCM_INUM0
, data
);
4567 data
= scm_ulong2num (ULONG_MAX
);
4568 data
= scm_sum (SCM_MAKINUM (1), data
); data
= scm_difference (SCM_INUM0
, data
);
4570 data
= scm_int2num (-10000); data
= scm_product (data
, data
); data
= scm_product (data
, data
);
4573 return SCM_UNSPECIFIED
;
4582 abs_most_negative_fixnum
= scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM
);
4583 scm_permanent_object (abs_most_negative_fixnum
);
4585 /* It may be possible to tune the performance of some algorithms by using
4586 * the following constants to avoid the creation of bignums. Please, before
4587 * using these values, remember the two rules of program optimization:
4588 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
4589 scm_c_define ("most-positive-fixnum",
4590 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
4591 scm_c_define ("most-negative-fixnum",
4592 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
4594 scm_add_feature ("complex");
4595 scm_add_feature ("inexact");
4596 scm_flo0
= scm_make_real (0.0);
4598 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4600 { /* determine floating point precision */
4602 double fsum
= 1.0 + f
;
4603 while (fsum
!= 1.0) {
4604 if (++scm_dblprec
> 20) {
4611 scm_dblprec
= scm_dblprec
- 1;
4613 #endif /* DBL_DIG */
4619 #include "libguile/numbers.x"