1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
46 #include "libguile/_scm.h"
47 #include "libguile/feature.h"
48 #include "libguile/ports.h"
49 #include "libguile/root.h"
50 #include "libguile/smob.h"
51 #include "libguile/strings.h"
53 #include "libguile/validate.h"
54 #include "libguile/numbers.h"
55 #include "libguile/deprecation.h"
59 static SCM
scm_divbigbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
, int modes
);
60 static SCM
scm_divbigint (SCM x
, long z
, int sgn
, int mode
);
63 #define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0)
66 /* FLOBUFLEN is the maximum number of characters neccessary for the
67 * printed or scm_string representation of an inexact number.
69 #define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
72 /* IS_INF tests its floating point number for infiniteness
73 Dirk:FIXME:: This test does not work if x == 0
76 #define IS_INF(x) ((x) == (x) / 2)
80 /* Return true if X is not infinite and is not a NaN
81 Dirk:FIXME:: Since IS_INF is broken, this test does not work if x == 0
84 #define isfinite(x) (!IS_INF (x) && (x) == (x))
89 static SCM abs_most_negative_fixnum
;
94 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
96 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
98 #define FUNC_NAME s_scm_exact_p
102 } else if (SCM_BIGP (x
)) {
111 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
113 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
115 #define FUNC_NAME s_scm_odd_p
118 return SCM_BOOL ((4 & SCM_UNPACK (n
)) != 0);
119 } else if (SCM_BIGP (n
)) {
120 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) != 0);
122 SCM_WRONG_TYPE_ARG (1, n
);
128 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
130 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
132 #define FUNC_NAME s_scm_even_p
135 return SCM_BOOL ((4 & SCM_UNPACK (n
)) == 0);
136 } else if (SCM_BIGP (n
)) {
137 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) == 0);
139 SCM_WRONG_TYPE_ARG (1, n
);
145 SCM_GPROC (s_abs
, "abs", 1, 0, 0, scm_abs
, g_abs
);
146 /* "Return the absolute value of @var{x}."
152 long int xx
= SCM_INUM (x
);
155 } else if (SCM_POSFIXABLE (-xx
)) {
156 return SCM_MAKINUM (-xx
);
159 return scm_i_long2big (-xx
);
161 scm_num_overflow (s_abs
);
164 } else if (SCM_BIGP (x
)) {
165 if (!SCM_BIGSIGN (x
)) {
168 return scm_i_copybig (x
, 0);
170 } else if (SCM_REALP (x
)) {
171 return scm_make_real (fabs (SCM_REAL_VALUE (x
)));
173 SCM_WTA_DISPATCH_1 (g_abs
, x
, 1, s_abs
);
178 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
179 /* "Return the quotient of the numbers @var{x} and @var{y}."
182 scm_quotient (SCM x
, SCM y
)
185 long xx
= SCM_INUM (x
);
187 long yy
= SCM_INUM (y
);
189 scm_num_overflow (s_quotient
);
192 if (SCM_FIXABLE (z
)) {
193 return SCM_MAKINUM (z
);
196 return scm_i_long2big (z
);
198 scm_num_overflow (s_quotient
);
202 } else if (SCM_BIGP (y
)) {
203 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
204 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
206 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
207 return SCM_MAKINUM (-1);
210 return SCM_MAKINUM (0);
212 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
214 } else if (SCM_BIGP (x
)) {
216 long yy
= SCM_INUM (y
);
218 scm_num_overflow (s_quotient
);
219 } else if (yy
== 1) {
222 long z
= yy
< 0 ? -yy
: yy
;
224 if (z
< SCM_BIGRAD
) {
225 SCM sw
= scm_i_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
226 scm_divbigdig (SCM_BDIGITS (sw
), SCM_NUMDIGS (sw
), (SCM_BIGDIG
) z
);
227 return scm_i_normbig (sw
);
229 #ifndef SCM_DIGSTOOBIG
230 long w
= scm_pseudolong (z
);
231 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
232 (SCM_BIGDIG
*) & w
, SCM_DIGSPERLONG
,
233 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
235 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
236 scm_longdigs (z
, zdigs
);
237 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
238 zdigs
, SCM_DIGSPERLONG
,
239 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
243 } else if (SCM_BIGP (y
)) {
244 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
245 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
246 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 2);
248 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
251 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
256 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
257 /* "Return the remainder of the numbers @var{x} and @var{y}.\n"
259 * "(remainder 13 4) @result{} 1\n"
260 * "(remainder -13 4) @result{} -1\n"
264 scm_remainder (SCM x
, SCM y
)
268 long yy
= SCM_INUM (y
);
270 scm_num_overflow (s_remainder
);
272 long z
= SCM_INUM (x
) % yy
;
273 return SCM_MAKINUM (z
);
275 } else if (SCM_BIGP (y
)) {
276 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
277 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
279 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
280 return SCM_MAKINUM (0);
285 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
287 } else if (SCM_BIGP (x
)) {
289 long yy
= SCM_INUM (y
);
291 scm_num_overflow (s_remainder
);
293 return scm_divbigint (x
, yy
, SCM_BIGSIGN (x
), 0);
295 } else if (SCM_BIGP (y
)) {
296 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
297 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
300 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
303 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
308 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
309 /* "Return the modulo of the numbers @var{x} and @var{y}.\n"
311 * "(modulo 13 4) @result{} 1\n"
312 * "(modulo -13 4) @result{} 3\n"
316 scm_modulo (SCM x
, SCM y
)
319 long xx
= SCM_INUM (x
);
321 long yy
= SCM_INUM (y
);
323 scm_num_overflow (s_modulo
);
326 return SCM_MAKINUM (((yy
< 0) ? (z
> 0) : (z
< 0)) ? z
+ yy
: z
);
328 } else if (SCM_BIGP (y
)) {
329 return (SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0)) ? scm_sum (x
, y
) : x
;
331 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
333 } else if (SCM_BIGP (x
)) {
335 long yy
= SCM_INUM (y
);
337 scm_num_overflow (s_modulo
);
339 return scm_divbigint (x
, yy
, yy
< 0,
340 (SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0)) ? 1 : 0);
342 } else if (SCM_BIGP (y
)) {
343 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
344 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
346 (SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
)) ? 1 : 0);
348 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
351 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
356 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
357 /* "Return the greatest common divisor of all arguments.\n"
358 * "If called without arguments, 0 is returned."
361 scm_gcd (SCM x
, SCM y
)
363 if (SCM_UNBNDP (y
)) {
364 if (SCM_UNBNDP (x
)) {
374 long xx
= SCM_INUM (x
);
375 long yy
= SCM_INUM (y
);
376 long u
= xx
< 0 ? -xx
: xx
;
377 long v
= yy
< 0 ? -yy
: yy
;
382 } else if (yy
== 0) {
388 /* Determine a common factor 2^k */
389 while (!(1 & (u
| v
))) {
395 /* Now, any factor 2^n can be eliminated */
415 if (SCM_POSFIXABLE (result
)) {
416 return SCM_MAKINUM (result
);
419 return scm_i_long2big (result
);
421 scm_num_overflow (s_gcd
);
424 } else if (SCM_BIGP (y
)) {
428 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
430 } else if (SCM_BIGP (x
)) {
433 x
= scm_i_copybig (x
, 0);
436 if (SCM_EQ_P (y
, SCM_INUM0
)) {
441 } else if (SCM_BIGP (y
)) {
443 y
= scm_i_copybig (y
, 0);
444 switch (scm_bigcomp (x
, y
))
449 SCM t
= scm_remainder (x
, y
);
455 y
= scm_remainder (y
, x
);
457 default: /* x == y */
460 /* instead of the switch, we could just
461 return scm_gcd (y, scm_modulo (x, y)); */
463 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
466 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
471 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
472 /* "Return the least common multiple of the arguments.\n"
473 * "If called without arguments, 1 is returned."
476 scm_lcm (SCM n1
, SCM n2
)
478 if (SCM_UNBNDP (n2
)) {
479 if (SCM_UNBNDP (n1
)) {
480 return SCM_MAKINUM (1L);
482 n2
= SCM_MAKINUM (1L);
487 SCM_GASSERT2 (SCM_INUMP (n1
), g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
488 SCM_GASSERT2 (SCM_INUMP (n2
), g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
490 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
491 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
492 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
493 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
497 SCM d
= scm_gcd (n1
, n2
);
498 if (SCM_EQ_P (d
, SCM_INUM0
)) {
501 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
508 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
510 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
514 /* Emulating 2's complement bignums with sign magnitude arithmetic:
519 + + + x (map digit:logand X Y)
520 + - + x (map digit:logand X (lognot (+ -1 Y)))
521 - + + y (map digit:logand (lognot (+ -1 X)) Y)
522 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
527 + + + (map digit:logior X Y)
528 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
529 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
530 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
535 + + + (map digit:logxor X Y)
536 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
537 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
538 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
543 + + (any digit:logand X Y)
544 + - (any digit:logand X (lognot (+ -1 Y)))
545 - + (any digit:logand (lognot (+ -1 X)) Y)
552 SCM
scm_copy_big_dec(SCM b
, int sign
);
553 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, size_t nx
, int zsgn
);
554 SCM
scm_big_ior(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
555 SCM
scm_big_xor(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
556 SCM
scm_big_and(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int zsgn
);
557 SCM
scm_big_test(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
);
559 SCM
scm_copy_big_dec(SCM b
, int sign
)
562 size_t nx
= SCM_NUMDIGS(b
);
564 SCM ans
= scm_i_mkbig(nx
, sign
);
565 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
566 if SCM_BIGSIGN(b
) do {
568 if (num
< 0) {dst
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
569 else {dst
[i
] = SCM_BIGLO(num
); num
= 0;}
572 while (nx
--) dst
[nx
] = src
[nx
];
576 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, size_t nx
, int zsgn
)
580 SCM z
= scm_i_mkbig(nx
, zsgn
);
581 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
584 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
585 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
587 else do zds
[i
] = x
[i
]; while (++i
< nx
);
591 SCM
scm_big_ior(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
592 /* Assumes nx <= SCM_NUMDIGS(bigy) */
593 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
596 size_t i
= 0, ny
= SCM_NUMDIGS(bigy
);
597 SCM z
= scm_copy_big_dec (bigy
, xsgn
& SCM_BIGSIGN (bigy
));
598 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
602 if (num
< 0) {zds
[i
] |= num
+ SCM_BIGRAD
; num
= -1;}
603 else {zds
[i
] |= SCM_BIGLO(num
); num
= 0;}
605 /* ========= Need to increment zds now =========== */
609 zds
[i
++] = SCM_BIGLO(num
);
610 num
= SCM_BIGDN(num
);
613 scm_i_adjbig(z
, 1 + ny
); /* OOPS, overflowed into next digit. */
614 SCM_BDIGITS(z
)[ny
] = 1;
617 else do zds
[i
] = zds
[i
] | x
[i
]; while (++i
< nx
);
621 SCM
scm_big_xor(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
622 /* Assumes nx <= SCM_NUMDIGS(bigy) */
623 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
626 size_t i
= 0, ny
= SCM_NUMDIGS(bigy
);
627 SCM z
= scm_copy_big_dec(bigy
, xsgn
^ SCM_BIGSIGN(bigy
));
628 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
631 if (num
< 0) {zds
[i
] ^= num
+ SCM_BIGRAD
; num
= -1;}
632 else {zds
[i
] ^= SCM_BIGLO(num
); num
= 0;}
635 zds
[i
] = zds
[i
] ^ x
[i
];
638 if (xsgn
^ SCM_BIGSIGN(bigy
)) {
639 /* ========= Need to increment zds now =========== */
643 zds
[i
++] = SCM_BIGLO(num
);
644 num
= SCM_BIGDN(num
);
645 if (!num
) return scm_i_normbig(z
);
648 return scm_i_normbig(z
);
651 SCM
scm_big_and(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int zsgn
)
652 /* Assumes nx <= SCM_NUMDIGS(bigy) */
653 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
654 /* return sign equals either 0 or SCM_BIGSIGNFLAG */
661 z
= scm_copy_smaller(x
, nx
, zsgn
);
662 x
= SCM_BDIGITS(bigy
);
663 xsgn
= SCM_BIGSIGN(bigy
);
665 else z
= scm_copy_big_dec(bigy
, zsgn
);
666 zds
= SCM_BDIGITS(z
);
671 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
672 else {zds
[i
] &= SCM_BIGLO(num
); num
= 0;}
674 else do zds
[i
] = zds
[i
] & ~x
[i
]; while (++i
< nx
);
675 /* ========= need to increment zds now =========== */
679 zds
[i
++] = SCM_BIGLO(num
);
680 num
= SCM_BIGDN(num
);
681 if (!num
) return scm_i_normbig(z
);
685 unsigned long int carry
= 1;
687 unsigned long int mask
= (SCM_BIGDIG
) ~x
[i
] + carry
;
688 zds
[i
] = zds
[i
] & (SCM_BIGDIG
) mask
;
689 carry
= (mask
>= SCM_BIGRAD
) ? 1 : 0;
691 } else do zds
[i
] = zds
[i
] & x
[i
]; while (++i
< nx
);
692 return scm_i_normbig(z
);
695 SCM
scm_big_test(SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
)
696 /* Assumes nx <= SCM_NUMDIGS(bigy) */
697 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
702 if (SCM_BIGSIGN(bigy
) & xsgn
) return SCM_BOOL_T
;
703 if (SCM_NUMDIGS(bigy
) != nx
&& xsgn
) return SCM_BOOL_T
;
704 y
= SCM_BDIGITS(bigy
);
709 if (y
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
713 if (y
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
717 else if SCM_BIGSIGN(bigy
)
721 if (x
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
725 if (x
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
730 do if (x
[i
] & y
[i
]) return SCM_BOOL_T
;
737 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
739 "Return the bitwise AND of the integer arguments.\n\n"
741 "(logand) @result{} -1\n"
742 "(logand 7) @result{} 7\n"
743 "(logand #b111 #b011 #\b001) @result{} 1\n"
745 #define FUNC_NAME s_scm_logand
749 if (SCM_UNBNDP (n2
)) {
750 if (SCM_UNBNDP (n1
)) {
751 return SCM_MAKINUM (-1);
752 } else if (!SCM_NUMBERP (n1
)) {
753 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
755 } else if (SCM_NUMBERP (n1
)) {
758 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
766 if (SCM_INUMP (n1
)) {
768 if (SCM_INUMP (n2
)) {
769 long nn2
= SCM_INUM (n2
);
770 return SCM_MAKINUM (nn1
& nn2
);
771 } else if SCM_BIGP (n2
) {
774 # ifndef SCM_DIGSTOOBIG
775 long z
= scm_pseudolong (nn1
);
776 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
777 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
778 SCM_BIGSIGNFLAG
, n2
);
780 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
781 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
784 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
785 scm_longdigs (nn1
, zdigs
);
786 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
787 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
789 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
790 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
795 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
797 } else if (SCM_BIGP (n1
)) {
798 if (SCM_INUMP (n2
)) {
802 } else if (SCM_BIGP (n2
)) {
803 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
806 if ((SCM_BIGSIGN (n1
)) && SCM_BIGSIGN (n2
)) {
807 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
808 SCM_BIGSIGNFLAG
, n2
);
810 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
811 SCM_BIGSIGN (n1
), n2
, 0);
814 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
817 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
823 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
825 "Return the bitwise OR of the integer arguments.\n\n"
827 "(logior) @result{} 0\n"
828 "(logior 7) @result{} 7\n"
829 "(logior #b000 #b001 #b011) @result{} 3\n"
831 #define FUNC_NAME s_scm_logior
835 if (SCM_UNBNDP (n2
)) {
836 if (SCM_UNBNDP (n1
)) {
839 } else if (SCM_NUMBERP (n1
)) {
842 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
850 if (SCM_INUMP (n1
)) {
852 if (SCM_INUMP (n2
)) {
853 long nn2
= SCM_INUM (n2
);
854 return SCM_MAKINUM (nn1
| nn2
);
855 } else if (SCM_BIGP (n2
)) {
858 # ifndef SCM_DIGSTOOBIG
859 long z
= scm_pseudolong (nn1
);
860 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
861 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
862 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
864 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
865 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
868 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
869 scm_longdigs (nn1
, zdigs
);
870 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
871 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
,
872 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
874 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
875 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
880 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
882 } else if (SCM_BIGP (n1
)) {
883 if (SCM_INUMP (n2
)) {
887 } else if (SCM_BIGP (n2
)) {
888 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
891 if ((!SCM_BIGSIGN (n1
)) && !SCM_BIGSIGN (n2
)) {
892 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
893 SCM_BIGSIGN (n1
), n2
);
895 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
896 SCM_BIGSIGN (n1
), n2
, SCM_BIGSIGNFLAG
);
899 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
902 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
908 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
910 "Return the bitwise XOR of the integer arguments. A bit is\n"
911 "set in the result if it is set in an odd number of arguments.\n"
913 "(logxor) @result{} 0\n"
914 "(logxor 7) @result{} 7\n"
915 "(logxor #b000 #b001 #b011) @result{} 2\n"
916 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
918 #define FUNC_NAME s_scm_logxor
922 if (SCM_UNBNDP (n2
)) {
923 if (SCM_UNBNDP (n1
)) {
926 } else if (SCM_NUMBERP (n1
)) {
929 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
937 if (SCM_INUMP (n1
)) {
939 if (SCM_INUMP (n2
)) {
940 long nn2
= SCM_INUM (n2
);
941 return SCM_MAKINUM (nn1
^ nn2
);
942 } else if (SCM_BIGP (n2
)) {
945 # ifndef SCM_DIGSTOOBIG
946 long z
= scm_pseudolong (nn1
);
947 return scm_big_xor ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
948 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
950 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
951 scm_longdigs (nn1
, zdigs
);
952 return scm_big_xor (zdigs
, SCM_DIGSPERLONG
,
953 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
957 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
959 } else if (SCM_BIGP (n1
)) {
960 if (SCM_INUMP (n2
)) {
964 } else if (SCM_BIGP (n2
)) {
965 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {
968 return scm_big_xor (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
969 SCM_BIGSIGN (n1
), n2
);
971 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
974 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
980 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
983 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
984 "(logtest #b0100 #b1011) @result{} #f\n"
985 "(logtest #b0100 #b0111) @result{} #t\n"
987 #define FUNC_NAME s_scm_logtest
994 long nk
= SCM_INUM (k
);
995 return SCM_BOOL (nj
& nk
);
996 } else if (SCM_BIGP (k
)) {
999 # ifndef SCM_DIGSTOOBIG
1000 long z
= scm_pseudolong (nj
);
1001 return scm_big_test ((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
1002 (nj
< 0) ? SCM_BIGSIGNFLAG
: 0, k
);
1004 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
1005 scm_longdigs (nj
, zdigs
);
1006 return scm_big_test (zdigs
, SCM_DIGSPERLONG
,
1007 (nj
< 0) ? SCM_BIGSIGNFLAG
: 0, k
);
1011 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1013 } else if (SCM_BIGP (j
)) {
1014 if (SCM_INUMP (k
)) {
1018 } else if (SCM_BIGP (k
)) {
1019 if (SCM_NUMDIGS (j
) > SCM_NUMDIGS (k
)) {
1022 return scm_big_test (SCM_BDIGITS (j
), SCM_NUMDIGS (j
),
1023 SCM_BIGSIGN (j
), k
);
1025 SCM_WRONG_TYPE_ARG (SCM_ARG2
, k
);
1028 SCM_WRONG_TYPE_ARG (SCM_ARG1
, j
);
1034 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
1037 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1038 "(logbit? 0 #b1101) @result{} #t\n"
1039 "(logbit? 1 #b1101) @result{} #f\n"
1040 "(logbit? 2 #b1101) @result{} #t\n"
1041 "(logbit? 3 #b1101) @result{} #t\n"
1042 "(logbit? 4 #b1101) @result{} #f\n"
1044 #define FUNC_NAME s_scm_logbit_p
1046 unsigned long int iindex
;
1048 SCM_VALIDATE_INUM_MIN (SCM_ARG1
, index
, 0);
1049 iindex
= (unsigned long int) SCM_INUM (index
);
1051 if (SCM_INUMP (j
)) {
1052 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1053 } else if (SCM_BIGP (j
)) {
1054 if (SCM_NUMDIGS (j
) * SCM_BITSPERDIG
< iindex
) {
1056 } else if (SCM_BIGSIGN (j
)) {
1059 SCM_BIGDIG
* x
= SCM_BDIGITS (j
);
1060 size_t nx
= iindex
/ SCM_BITSPERDIG
;
1064 return SCM_BOOL (((1L << (iindex
% SCM_BITSPERDIG
)) & num
) == 0);
1065 } else if (num
< 0) {
1072 return SCM_BOOL (SCM_BDIGITS (j
) [iindex
/ SCM_BITSPERDIG
]
1073 & (1L << (iindex
% SCM_BITSPERDIG
)));
1076 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1082 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1084 "Return the integer which is the 2s-complement of the integer\n"
1088 "(number->string (lognot #b10000000) 2)\n"
1089 " @result{} \"-10000001\"\n"
1090 "(number->string (lognot #b0) 2)\n"
1091 " @result{} \"-1\"\n"
1093 #define FUNC_NAME s_scm_lognot
1095 return scm_difference (SCM_MAKINUM (-1L), n
);
1099 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1101 "Return @var{n} raised to the non-negative integer exponent\n"
1105 "(integer-expt 2 5)\n"
1107 "(integer-expt -3 3)\n"
1110 #define FUNC_NAME s_scm_integer_expt
1112 SCM acc
= SCM_MAKINUM (1L);
1115 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1117 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1118 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1122 double r
= SCM_REAL_VALUE (k
);
1125 SCM_WRONG_TYPE_ARG (2, k
);
1128 SCM_VALIDATE_ULONG_COPY (2,k
,i2
);
1132 n
= scm_divide (n
, SCM_UNDEFINED
);
1139 return scm_product (acc
, n
);
1141 acc
= scm_product (acc
, n
);
1142 n
= scm_product (n
, n
);
1148 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1150 "The function ash performs an arithmetic shift left by @var{cnt}\n"
1151 "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n"
1152 "means, that the function does not guarantee to keep the bit\n"
1153 "structure of @var{n}, but rather guarantees that the result\n"
1154 "will always be rounded towards minus infinity. Therefore, the\n"
1155 "results of ash and a corresponding bitwise shift will differ if\n"
1156 "@var{n} is negative.\n"
1158 "Formally, the function returns an integer equivalent to\n"
1159 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n"
1162 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1163 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
1165 #define FUNC_NAME s_scm_ash
1170 SCM_VALIDATE_INUM (1, n
)
1172 SCM_VALIDATE_INUM (2, cnt
);
1174 bits_to_shift
= SCM_INUM (cnt
);
1176 if (bits_to_shift
< 0) {
1177 /* Shift right by abs(cnt) bits. This is realized as a division by
1178 div:=2^abs(cnt). However, to guarantee the floor rounding, negative
1179 values require some special treatment.
1181 SCM div
= scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift
));
1182 if (SCM_FALSEP (scm_negative_p (n
)))
1183 return scm_quotient (n
, div
);
1185 return scm_sum (SCM_MAKINUM (-1L),
1186 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1188 /* Shift left is done by multiplication with 2^CNT */
1189 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1191 if (bits_to_shift
< 0)
1192 /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */
1193 return SCM_MAKINUM (SCM_SRS (SCM_INUM (n
), -bits_to_shift
));
1195 /* Shift left, but make sure not to leave the range of inums */
1196 SCM res
= SCM_MAKINUM (SCM_INUM (n
) << cnt
);
1197 if (SCM_INUM (res
) >> cnt
!= SCM_INUM (n
))
1198 scm_num_overflow (FUNC_NAME
);
1206 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1207 (SCM n
, SCM start
, SCM end
),
1208 "Return the integer composed of the @var{start} (inclusive)\n"
1209 "through @var{end} (exclusive) bits of @var{n}. The\n"
1210 "@var{start}th bit becomes the 0-th bit in the result.\n"
1213 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1214 " @result{} \"1010\"\n"
1215 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1216 " @result{} \"10110\"\n"
1218 #define FUNC_NAME s_scm_bit_extract
1220 unsigned long int istart
, iend
;
1221 SCM_VALIDATE_INUM_MIN_COPY (2,start
,0,istart
);
1222 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1223 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1225 if (SCM_INUMP (n
)) {
1226 long int in
= SCM_INUM (n
);
1227 unsigned long int bits
= iend
- istart
;
1229 if (in
< 0 && bits
>= SCM_I_FIXNUM_BIT
)
1231 /* Since we emulate two's complement encoded numbers, this special
1232 * case requires us to produce a result that has more bits than can be
1233 * stored in a fixnum. Thus, we fall back to the more general
1234 * algorithm that is used for bignums.
1239 if (istart
< SCM_I_FIXNUM_BIT
)
1242 if (bits
< SCM_I_FIXNUM_BIT
)
1243 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1244 else /* we know: in >= 0 */
1245 return SCM_MAKINUM (in
);
1249 return SCM_MAKINUM (-1L & ((1L << bits
) - 1));
1253 return SCM_MAKINUM (0);
1255 } else if (SCM_BIGP (n
)) {
1258 SCM num1
= SCM_MAKINUM (1L);
1259 SCM num2
= SCM_MAKINUM (2L);
1260 SCM bits
= SCM_MAKINUM (iend
- istart
);
1261 SCM mask
= scm_difference (scm_integer_expt (num2
, bits
), num1
);
1262 return scm_logand (mask
, scm_ash (n
, SCM_MAKINUM (-istart
)));
1265 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1271 static const char scm_logtab
[] = {
1272 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1275 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1277 "Return the number of bits in integer @var{n}. If integer is\n"
1278 "positive, the 1-bits in its binary representation are counted.\n"
1279 "If negative, the 0-bits in its two's-complement binary\n"
1280 "representation are counted. If 0, 0 is returned.\n"
1283 "(logcount #b10101010)\n"
1290 #define FUNC_NAME s_scm_logcount
1292 if (SCM_INUMP (n
)) {
1293 unsigned long int c
= 0;
1294 long int nn
= SCM_INUM (n
);
1299 c
+= scm_logtab
[15 & nn
];
1302 return SCM_MAKINUM (c
);
1303 } else if (SCM_BIGP (n
)) {
1304 if (SCM_BIGSIGN (n
)) {
1305 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n
));
1307 unsigned long int c
= 0;
1308 size_t i
= SCM_NUMDIGS (n
);
1309 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1312 for (d
= ds
[i
]; d
; d
>>= 4) {
1313 c
+= scm_logtab
[15 & d
];
1316 return SCM_MAKINUM (c
);
1319 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1325 static const char scm_ilentab
[] = {
1326 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1329 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1331 "Return the number of bits neccessary to represent @var{n}.\n"
1334 "(integer-length #b10101010)\n"
1336 "(integer-length 0)\n"
1338 "(integer-length #b1111)\n"
1341 #define FUNC_NAME s_scm_integer_length
1343 if (SCM_INUMP (n
)) {
1344 unsigned long int c
= 0;
1346 long int nn
= SCM_INUM (n
);
1352 l
= scm_ilentab
[15 & nn
];
1355 return SCM_MAKINUM (c
- 4 + l
);
1356 } else if (SCM_BIGP (n
)) {
1357 if (SCM_BIGSIGN (n
)) {
1358 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n
));
1360 unsigned long int digs
= SCM_NUMDIGS (n
) - 1;
1361 unsigned long int c
= digs
* SCM_BITSPERDIG
;
1363 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1364 SCM_BIGDIG d
= ds
[digs
];
1367 l
= scm_ilentab
[15 & d
];
1370 return SCM_MAKINUM (c
- 4 + l
);
1373 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1380 static const char s_bignum
[] = "bignum";
1383 scm_i_mkbig (size_t nlen
, int sign
)
1388 if (((nlen
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1389 scm_memory_error (s_bignum
);
1391 base
= scm_gc_malloc (nlen
* sizeof (SCM_BIGDIG
), s_bignum
);
1393 v
= scm_alloc_cell (SCM_MAKE_BIGNUM_TAG (nlen
, sign
), (scm_t_bits
) base
);
1398 scm_i_big2inum (SCM b
, size_t l
)
1400 unsigned long num
= 0;
1401 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1403 num
= SCM_BIGUP (num
) + tmp
[l
];
1404 if (!SCM_BIGSIGN (b
))
1406 if (SCM_POSFIXABLE (num
))
1407 return SCM_MAKINUM (num
);
1409 else if (num
<= -SCM_MOST_NEGATIVE_FIXNUM
)
1410 return SCM_MAKINUM (-num
);
1414 static const char s_adjbig
[] = "scm_i_adjbig";
1417 scm_i_adjbig (SCM b
, size_t nlen
)
1420 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1421 scm_memory_error (s_adjbig
);
1427 scm_gc_realloc (SCM_BDIGITS (b
),
1428 SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
),
1429 nsiz
* sizeof (SCM_BIGDIG
), s_bignum
));
1431 SCM_SET_BIGNUM_BASE (b
, digits
);
1432 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1439 scm_i_normbig (SCM b
)
1442 size_t nlen
= SCM_NUMDIGS (b
);
1444 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1446 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1447 while (nlen
-- && !zds
[nlen
]);
1449 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1450 if (SCM_INUMP (b
= scm_i_big2inum (b
, (size_t) nlen
)))
1452 if (SCM_NUMDIGS (b
) == nlen
)
1454 return scm_i_adjbig (b
, (size_t) nlen
);
1458 scm_i_copybig (SCM b
, int sign
)
1460 size_t i
= SCM_NUMDIGS (b
);
1461 SCM ans
= scm_i_mkbig (i
, sign
);
1462 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1469 scm_bigcomp (SCM x
, SCM y
)
1471 int xsign
= SCM_BIGSIGN (x
);
1472 int ysign
= SCM_BIGSIGN (y
);
1475 /* Look at the signs, first. */
1481 /* They're the same sign, so see which one has more digits. Note
1482 that, if they are negative, the longer number is the lesser. */
1483 ylen
= SCM_NUMDIGS (y
);
1484 xlen
= SCM_NUMDIGS (x
);
1486 return (xsign
) ? -1 : 1;
1488 return (xsign
) ? 1 : -1;
1490 /* They have the same number of digits, so find the most significant
1491 digit where they differ. */
1495 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1496 /* Make the discrimination based on the digit that differs. */
1497 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1499 : (xsign
? 1 : -1));
1502 /* The numbers are identical. */
1506 #ifndef SCM_DIGSTOOBIG
1510 scm_pseudolong (long x
)
1515 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1521 while (i
< SCM_DIGSPERLONG
)
1523 p
.bd
[i
++] = SCM_BIGLO (x
);
1526 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1534 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1539 while (i
< SCM_DIGSPERLONG
)
1541 digs
[i
++] = SCM_BIGLO (x
);
1550 scm_addbig (SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int sgny
)
1552 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1553 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1555 size_t i
= 0, ny
= SCM_NUMDIGS (bigy
);
1556 SCM z
= scm_i_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1557 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1558 if (xsgn
^ SCM_BIGSIGN (z
))
1562 num
+= (long) zds
[i
] - x
[i
];
1565 zds
[i
] = num
+ SCM_BIGRAD
;
1570 zds
[i
] = SCM_BIGLO (num
);
1575 if (num
&& nx
== ny
)
1579 SCM_SET_CELL_WORD_0 (z
, SCM_CELL_WORD_0 (z
) ^ SCM_BIGSIGNFLAG
);
1582 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1583 zds
[i
++] = SCM_BIGLO (num
);
1584 num
= SCM_BIGDN (num
);
1594 zds
[i
++] = num
+ SCM_BIGRAD
;
1599 zds
[i
++] = SCM_BIGLO (num
);
1608 num
+= (long) zds
[i
] + x
[i
];
1609 zds
[i
++] = SCM_BIGLO (num
);
1610 num
= SCM_BIGDN (num
);
1618 zds
[i
++] = SCM_BIGLO (num
);
1619 num
= SCM_BIGDN (num
);
1625 z
= scm_i_adjbig (z
, ny
+ 1);
1626 SCM_BDIGITS (z
)[ny
] = num
;
1630 return scm_i_normbig (z
);
1635 scm_mulbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
)
1637 size_t i
= 0, j
= nx
+ ny
;
1638 unsigned long n
= 0;
1639 SCM z
= scm_i_mkbig (j
, sgn
);
1640 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1650 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1651 zds
[i
+ j
++] = SCM_BIGLO (n
);
1663 return scm_i_normbig (z
);
1668 scm_divbigdig (SCM_BIGDIG
* ds
, size_t h
, SCM_BIGDIG div
)
1670 register unsigned long t2
= 0;
1673 t2
= SCM_BIGUP (t2
) + ds
[h
];
1683 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1689 register unsigned long t2
= 0;
1690 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1691 size_t nd
= SCM_NUMDIGS (x
);
1693 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1696 return SCM_MAKINUM (sgn
? -t2
: t2
);
1699 #ifndef SCM_DIGSTOOBIG
1700 unsigned long t2
= scm_pseudolong (z
);
1701 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1702 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1705 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1706 scm_longdigs (z
, t2
);
1707 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1708 t2
, SCM_DIGSPERLONG
,
1716 scm_divbigbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
, int modes
)
1718 /* modes description
1722 3 quotient but returns SCM_UNDEFINED if division is not exact. */
1723 size_t i
= 0, j
= 0;
1725 unsigned long t2
= 0;
1727 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1728 /* algorithm requires nx >= ny */
1732 case 0: /* remainder -- just return x */
1733 z
= scm_i_mkbig (nx
, sgn
);
1734 zds
= SCM_BDIGITS (z
);
1741 case 1: /* scm_modulo -- return y-x */
1742 z
= scm_i_mkbig (ny
, sgn
);
1743 zds
= SCM_BDIGITS (z
);
1746 num
+= (long) y
[i
] - x
[i
];
1749 zds
[i
] = num
+ SCM_BIGRAD
;
1764 zds
[i
++] = num
+ SCM_BIGRAD
;
1775 return SCM_INUM0
; /* quotient is zero */
1777 return SCM_UNDEFINED
; /* the division is not exact */
1780 z
= scm_i_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1781 zds
= SCM_BDIGITS (z
);
1785 ny
--; /* in case y came in as a psuedolong */
1786 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1787 { /* normalize operands */
1788 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1789 newy
= scm_i_mkbig (ny
, 0);
1790 yds
= SCM_BDIGITS (newy
);
1793 t2
+= (unsigned long) y
[j
] * d
;
1794 yds
[j
++] = SCM_BIGLO (t2
);
1795 t2
= SCM_BIGDN (t2
);
1802 t2
+= (unsigned long) x
[j
] * d
;
1803 zds
[j
++] = SCM_BIGLO (t2
);
1804 t2
= SCM_BIGDN (t2
);
1814 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1816 { /* loop over digits of quotient */
1817 if (zds
[j
] == y
[ny
- 1])
1818 qhat
= SCM_BIGRAD
- 1;
1820 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1827 { /* multiply and subtract */
1828 t2
+= (unsigned long) y
[i
] * qhat
;
1829 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1832 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1837 zds
[j
- ny
+ i
] = num
;
1840 t2
= SCM_BIGDN (t2
);
1843 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1845 { /* "add back" required */
1851 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1852 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1853 num
= SCM_BIGDN (num
);
1864 case 3: /* check that remainder==0 */
1865 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1867 return SCM_UNDEFINED
;
1868 case 2: /* move quotient down in z */
1869 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
1870 for (i
= 0; i
< j
; i
++)
1871 zds
[i
] = zds
[i
+ ny
];
1874 case 1: /* subtract for scm_modulo */
1880 num
+= y
[i
] - zds
[i
];
1884 zds
[i
] = num
+ SCM_BIGRAD
;
1896 case 0: /* just normalize remainder */
1898 scm_divbigdig (zds
, ny
, d
);
1901 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1902 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
1903 if (SCM_INUMP (z
= scm_i_big2inum (z
, j
)))
1905 return scm_i_adjbig (z
, j
);
1913 /*** NUMBERS -> STRINGS ***/
1915 static const double fx
[] =
1916 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1917 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1918 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1919 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1925 idbl2str (double f
, char *a
)
1927 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1932 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1951 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1952 make-uniform-vector, from causing infinite loops. */
1956 if (exp
-- < DBL_MIN_10_EXP
)
1962 if (exp
++ > DBL_MAX_10_EXP
)
1977 if (f
+ fx
[wp
] >= 10.0)
1984 dpt
= (exp
+ 9999) % 3;
1988 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2013 if (f
+ fx
[wp
] >= 1.0)
2027 if ((dpt
> 4) && (exp
> 6))
2029 d
= (a
[0] == '-' ? 2 : 1);
2030 for (i
= ch
++; i
> d
; i
--)
2043 if (a
[ch
- 1] == '.')
2044 a
[ch
++] = '0'; /* trailing zero */
2053 for (i
= 10; i
<= exp
; i
*= 10);
2054 for (i
/= 10; i
; i
/= 10)
2056 a
[ch
++] = exp
/ i
+ '0';
2065 iflo2str (SCM flt
, char *str
)
2068 if (SCM_REALP (flt
))
2069 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2072 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2073 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2075 if (0 <= SCM_COMPLEX_IMAG (flt
))
2077 i
+= idbl2str (SCM_COMPLEX_IMAG (flt
), &str
[i
]);
2084 /* convert a long to a string (unterminated). returns the number of
2085 characters in the result.
2087 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2089 scm_iint2str (long num
, int rad
, char *p
)
2093 unsigned long n
= (num
< 0) ? -num
: num
;
2095 for (n
/= rad
; n
> 0; n
/= rad
)
2112 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2121 big2str (SCM b
, unsigned int radix
)
2123 SCM t
= scm_i_copybig (b
, 0); /* sign of temp doesn't matter */
2124 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2125 size_t i
= SCM_NUMDIGS (t
);
2126 size_t j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2127 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2128 : (SCM_BITSPERDIG
* i
) + 2;
2131 SCM_BIGDIG radpow
= 1, radmod
= 0;
2132 SCM ss
= scm_allocate_string (j
);
2133 char *s
= SCM_STRING_CHARS (ss
), c
;
2134 while ((long) radpow
* radix
< SCM_BIGRAD
)
2139 while ((i
|| radmod
) && j
)
2143 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2151 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2154 if (SCM_BIGSIGN (b
))
2159 /* The pre-reserved string length was too large. */
2160 unsigned long int length
= SCM_STRING_LENGTH (ss
);
2161 ss
= scm_substring (ss
, SCM_MAKINUM (j
), SCM_MAKINUM (length
));
2164 return scm_return_first (ss
, t
);
2169 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2171 "Return a string holding the external representation of the\n"
2172 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2173 "inexact, a radix of 10 will be used.")
2174 #define FUNC_NAME s_scm_number_to_string
2178 if (SCM_UNBNDP (radix
)) {
2181 SCM_VALIDATE_INUM (2, radix
);
2182 base
= SCM_INUM (radix
);
2183 SCM_ASSERT_RANGE (2, radix
, base
>= 2);
2186 if (SCM_INUMP (n
)) {
2187 char num_buf
[SCM_INTBUFLEN
];
2188 size_t length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2189 return scm_mem2string (num_buf
, length
);
2190 } else if (SCM_BIGP (n
)) {
2191 return big2str (n
, (unsigned int) base
);
2192 } else if (SCM_INEXACTP (n
)) {
2193 char num_buf
[FLOBUFLEN
];
2194 return scm_mem2string (num_buf
, iflo2str (n
, num_buf
));
2196 SCM_WRONG_TYPE_ARG (1, n
);
2202 /* These print routines are stubbed here so that scm_repl.c doesn't need
2203 SCM_BIGDIG conditionals */
2206 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2208 char num_buf
[FLOBUFLEN
];
2209 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2214 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2216 char num_buf
[FLOBUFLEN
];
2217 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2222 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2225 exp
= big2str (exp
, (unsigned int) 10);
2226 scm_lfwrite (SCM_STRING_CHARS (exp
), (size_t) SCM_STRING_LENGTH (exp
), port
);
2228 scm_ipruk ("bignum", exp
, port
);
2232 /*** END nums->strs ***/
2235 /*** STRINGS -> NUMBERS ***/
2237 /* The following functions implement the conversion from strings to numbers.
2238 * The implementation somehow follows the grammar for numbers as it is given
2239 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
2240 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
2241 * points should be noted about the implementation:
2242 * * Each function keeps a local index variable 'idx' that points at the
2243 * current position within the parsed string. The global index is only
2244 * updated if the function could parse the corresponding syntactic unit
2246 * * Similarly, the functions keep track of indicators of inexactness ('#',
2247 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
2248 * global exactness information is only updated after each part has been
2249 * successfully parsed.
2250 * * Sequences of digits are parsed into temporary variables holding fixnums.
2251 * Only if these fixnums would overflow, the result variables are updated
2252 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
2253 * the temporary variables holding the fixnums are cleared, and the process
2254 * starts over again. If for example fixnums were able to store five decimal
2255 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
2256 * and the result was computed as 12345 * 100000 + 67890. In other words,
2257 * only every five digits two bignum operations were performed.
2260 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
2262 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
2264 /* In non ASCII-style encodings the following macro might not work. */
2265 #define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
2268 mem2uinteger (const char* mem
, size_t len
, unsigned int *p_idx
,
2269 unsigned int radix
, enum t_exactness
*p_exactness
)
2271 unsigned int idx
= *p_idx
;
2272 unsigned int hash_seen
= 0;
2273 scm_t_bits shift
= 1;
2275 unsigned int digit_value
;
2285 digit_value
= XDIGIT2UINT (c
);
2286 if (digit_value
>= radix
)
2290 result
= SCM_MAKINUM (digit_value
);
2298 digit_value
= XDIGIT2UINT (c
);
2299 if (digit_value
>= radix
)
2311 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
2313 result
= scm_product (result
, SCM_MAKINUM (shift
));
2315 result
= scm_sum (result
, SCM_MAKINUM (add
));
2322 shift
= shift
* radix
;
2323 add
= add
* radix
+ digit_value
;
2328 result
= scm_product (result
, SCM_MAKINUM (shift
));
2330 result
= scm_sum (result
, SCM_MAKINUM (add
));
2334 *p_exactness
= INEXACT
;
2340 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2341 * covers the parts of the rules that start at a potential point. The value
2342 * of the digits up to the point have been parsed by the caller and are given
2343 * in variable result. The content of *p_exactness indicates, whether a hash
2344 * has already been seen in the digits before the point.
2347 /* In non ASCII-style encodings the following macro might not work. */
2348 #define DIGIT2UINT(d) ((d) - '0')
2351 mem2decimal_from_point (SCM result
, const char* mem
, size_t len
,
2352 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
2354 unsigned int idx
= *p_idx
;
2355 enum t_exactness x
= *p_exactness
;
2360 if (mem
[idx
] == '.')
2362 scm_t_bits shift
= 1;
2364 unsigned int digit_value
;
2365 SCM big_shift
= SCM_MAKINUM (1);
2376 digit_value
= DIGIT2UINT (c
);
2387 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
2389 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2390 result
= scm_product (result
, SCM_MAKINUM (shift
));
2392 result
= scm_sum (result
, SCM_MAKINUM (add
));
2400 add
= add
* 10 + digit_value
;
2406 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2407 result
= scm_product (result
, SCM_MAKINUM (shift
));
2408 result
= scm_sum (result
, SCM_MAKINUM (add
));
2411 result
= scm_divide (result
, big_shift
);
2413 /* We've seen a decimal point, thus the value is implicitly inexact. */
2425 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2456 exponent
= DIGIT2UINT (c
);
2463 if (exponent
<= SCM_MAXEXP
)
2464 exponent
= exponent
* 10 + DIGIT2UINT (c
);
2470 if (exponent
> SCM_MAXEXP
)
2472 size_t exp_len
= idx
- start
;
2473 SCM exp_string
= scm_mem2string (&mem
[start
], exp_len
);
2474 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
2475 scm_out_of_range ("string->number", exp_num
);
2478 e
= scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent
));
2480 result
= scm_product (result
, e
);
2482 result
= scm_divide (result
, e
);
2484 /* We've seen an exponent, thus the value is implicitly inexact. */
2502 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2505 mem2ureal (const char* mem
, size_t len
, unsigned int *p_idx
,
2506 unsigned int radix
, enum t_exactness
*p_exactness
)
2508 unsigned int idx
= *p_idx
;
2513 if (mem
[idx
] == '.')
2517 else if (idx
+ 1 == len
)
2519 else if (!isdigit (mem
[idx
+ 1]))
2522 return mem2decimal_from_point (SCM_MAKINUM (0), mem
, len
,
2523 p_idx
, p_exactness
);
2527 enum t_exactness x
= EXACT
;
2531 uinteger
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2532 if (SCM_FALSEP (uinteger
))
2537 else if (mem
[idx
] == '/')
2543 divisor
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2544 if (SCM_FALSEP (divisor
))
2547 result
= scm_divide (uinteger
, divisor
);
2549 else if (radix
== 10)
2551 result
= mem2decimal_from_point (uinteger
, mem
, len
, &idx
, &x
);
2552 if (SCM_FALSEP (result
))
2567 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2570 mem2complex (const char* mem
, size_t len
, unsigned int idx
,
2571 unsigned int radix
, enum t_exactness
*p_exactness
)
2595 ureal
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2596 if (SCM_FALSEP (ureal
))
2598 /* input must be either +i or -i */
2603 if (mem
[idx
] == 'i' || mem
[idx
] == 'I')
2609 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign
));
2617 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
2626 /* either +<ureal>i or -<ureal>i */
2633 return scm_make_rectangular (SCM_MAKINUM (0), ureal
);
2636 /* polar input: <real>@<real>. */
2661 angle
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2662 if (SCM_FALSEP (angle
))
2668 angle
= scm_difference (angle
, SCM_UNDEFINED
);
2670 result
= scm_make_polar (ureal
, angle
);
2675 /* expecting input matching <real>[+-]<ureal>?i */
2682 int sign
= (c
== '+') ? 1 : -1;
2683 SCM imag
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2685 if (SCM_FALSEP (imag
))
2686 imag
= SCM_MAKINUM (sign
);
2687 else if (sign
== -1)
2688 imag
= scm_difference (imag
, SCM_UNDEFINED
);
2692 if (mem
[idx
] != 'i' && mem
[idx
] != 'I')
2699 return scm_make_rectangular (ureal
, imag
);
2708 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2710 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
2713 scm_i_mem2number (const char* mem
, size_t len
, unsigned int default_radix
)
2715 unsigned int idx
= 0;
2716 unsigned int radix
= NO_RADIX
;
2717 enum t_exactness forced_x
= NO_EXACTNESS
;
2718 enum t_exactness implicit_x
= EXACT
;
2721 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2722 while (idx
+ 2 < len
&& mem
[idx
] == '#')
2724 switch (mem
[idx
+ 1])
2727 if (radix
!= NO_RADIX
)
2732 if (radix
!= NO_RADIX
)
2737 if (forced_x
!= NO_EXACTNESS
)
2742 if (forced_x
!= NO_EXACTNESS
)
2747 if (radix
!= NO_RADIX
)
2752 if (radix
!= NO_RADIX
)
2762 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2763 if (radix
== NO_RADIX
)
2764 result
= mem2complex (mem
, len
, idx
, default_radix
, &implicit_x
);
2766 result
= mem2complex (mem
, len
, idx
, (unsigned int) radix
, &implicit_x
);
2768 if (SCM_FALSEP (result
))
2774 if (SCM_INEXACTP (result
))
2775 /* FIXME: This may change the value. */
2776 return scm_inexact_to_exact (result
);
2780 if (SCM_INEXACTP (result
))
2783 return scm_exact_to_inexact (result
);
2786 if (implicit_x
== INEXACT
)
2788 if (SCM_INEXACTP (result
))
2791 return scm_exact_to_inexact (result
);
2799 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2800 (SCM string
, SCM radix
),
2801 "Return a number of the maximally precise representation\n"
2802 "expressed by the given @var{string}. @var{radix} must be an\n"
2803 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2804 "is a default radix that may be overridden by an explicit radix\n"
2805 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2806 "supplied, then the default radix is 10. If string is not a\n"
2807 "syntactically valid notation for a number, then\n"
2808 "@code{string->number} returns @code{#f}.")
2809 #define FUNC_NAME s_scm_string_to_number
2813 SCM_VALIDATE_STRING (1, string
);
2814 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2815 answer
= scm_i_mem2number (SCM_STRING_CHARS (string
),
2816 SCM_STRING_LENGTH (string
),
2818 return scm_return_first (answer
, string
);
2823 /*** END strs->nums ***/
2827 scm_make_real (double x
)
2830 z
= scm_alloc_double_cell (scm_tc16_real
, 0, 0, 0);
2831 SCM_REAL_VALUE (z
) = x
;
2837 scm_make_complex (double x
, double y
)
2840 return scm_make_real (x
);
2843 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_gc_malloc (2*sizeof (double),
2845 SCM_COMPLEX_REAL (z
) = x
;
2846 SCM_COMPLEX_IMAG (z
) = y
;
2853 scm_bigequal (SCM x
, SCM y
)
2856 if (0 == scm_bigcomp (x
, y
))
2863 scm_real_equalp (SCM x
, SCM y
)
2865 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2869 scm_complex_equalp (SCM x
, SCM y
)
2871 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2872 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2877 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2878 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2879 * "else. Note that the sets of complex, real, rational and\n"
2880 * "integer values form subsets of the set of numbers, i. e. the\n"
2881 * "predicate will be fulfilled for any number."
2883 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2885 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2886 "else. Note that the sets of real, rational and integer\n"
2887 "values form subsets of the set of complex numbers, i. e. the\n"
2888 "predicate will also be fulfilled if @var{x} is a real,\n"
2889 "rational or integer number.")
2890 #define FUNC_NAME s_scm_number_p
2892 return SCM_BOOL (SCM_NUMBERP (x
));
2897 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2898 /* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
2899 * "Note that the sets of integer and rational values form a subset\n"
2900 * "of the set of real numbers, i. e. the predicate will also\n"
2901 * "be fulfilled if @var{x} is an integer or a rational number."
2903 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2905 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
2906 "else. Note that the set of integer values forms a subset of\n"
2907 "the set of rational numbers, i. e. the predicate will also be\n"
2908 "fulfilled if @var{x} is an integer number. Real numbers\n"
2909 "will also satisfy this predicate, because of their limited\n"
2911 #define FUNC_NAME s_scm_real_p
2913 if (SCM_INUMP (x
)) {
2915 } else if (SCM_IMP (x
)) {
2917 } else if (SCM_REALP (x
)) {
2919 } else if (SCM_BIGP (x
)) {
2928 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2930 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2932 #define FUNC_NAME s_scm_integer_p
2941 if (!SCM_INEXACTP (x
))
2943 if (SCM_COMPLEXP (x
))
2945 r
= SCM_REAL_VALUE (x
);
2953 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
2955 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
2957 #define FUNC_NAME s_scm_inexact_p
2959 return SCM_BOOL (SCM_INEXACTP (x
));
2964 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
2965 /* "Return @code{#t} if all parameters are numerically equal." */
2967 scm_num_eq_p (SCM x
, SCM y
)
2969 if (SCM_INUMP (x
)) {
2970 long xx
= SCM_INUM (x
);
2971 if (SCM_INUMP (y
)) {
2972 long yy
= SCM_INUM (y
);
2973 return SCM_BOOL (xx
== yy
);
2974 } else if (SCM_BIGP (y
)) {
2976 } else if (SCM_REALP (y
)) {
2977 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
2978 } else if (SCM_COMPLEXP (y
)) {
2979 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
2980 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2982 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2984 } else if (SCM_BIGP (x
)) {
2985 if (SCM_INUMP (y
)) {
2987 } else if (SCM_BIGP (y
)) {
2988 return SCM_BOOL (0 == scm_bigcomp (x
, y
));
2989 } else if (SCM_REALP (y
)) {
2990 return SCM_BOOL (scm_i_big2dbl (x
) == SCM_REAL_VALUE (y
));
2991 } else if (SCM_COMPLEXP (y
)) {
2992 return SCM_BOOL ((scm_i_big2dbl (x
) == SCM_COMPLEX_REAL (y
))
2993 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2995 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2997 } else if (SCM_REALP (x
)) {
2998 if (SCM_INUMP (y
)) {
2999 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3000 } else if (SCM_BIGP (y
)) {
3001 return SCM_BOOL (SCM_REAL_VALUE (x
) == scm_i_big2dbl (y
));
3002 } else if (SCM_REALP (y
)) {
3003 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3004 } else if (SCM_COMPLEXP (y
)) {
3005 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3006 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3008 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3010 } else if (SCM_COMPLEXP (x
)) {
3011 if (SCM_INUMP (y
)) {
3012 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3013 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3014 } else if (SCM_BIGP (y
)) {
3015 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == scm_i_big2dbl (y
))
3016 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3017 } else if (SCM_REALP (y
)) {
3018 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3019 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3020 } else if (SCM_COMPLEXP (y
)) {
3021 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3022 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3024 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3027 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3032 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3033 /* "Return @code{#t} if the list of parameters is monotonically\n"
3037 scm_less_p (SCM x
, SCM y
)
3039 if (SCM_INUMP (x
)) {
3040 long xx
= SCM_INUM (x
);
3041 if (SCM_INUMP (y
)) {
3042 long yy
= SCM_INUM (y
);
3043 return SCM_BOOL (xx
< yy
);
3044 } else if (SCM_BIGP (y
)) {
3045 return SCM_BOOL (!SCM_BIGSIGN (y
));
3046 } else if (SCM_REALP (y
)) {
3047 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3049 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3051 } else if (SCM_BIGP (x
)) {
3052 if (SCM_INUMP (y
)) {
3053 return SCM_BOOL (SCM_BIGSIGN (x
));
3054 } else if (SCM_BIGP (y
)) {
3055 return SCM_BOOL (1 == scm_bigcomp (x
, y
));
3056 } else if (SCM_REALP (y
)) {
3057 return SCM_BOOL (scm_i_big2dbl (x
) < SCM_REAL_VALUE (y
));
3059 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3061 } else if (SCM_REALP (x
)) {
3062 if (SCM_INUMP (y
)) {
3063 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3064 } else if (SCM_BIGP (y
)) {
3065 return SCM_BOOL (SCM_REAL_VALUE (x
) < scm_i_big2dbl (y
));
3066 } else if (SCM_REALP (y
)) {
3067 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3069 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3072 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3077 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3078 /* "Return @code{#t} if the list of parameters is monotonically\n"
3081 #define FUNC_NAME s_scm_gr_p
3083 scm_gr_p (SCM x
, SCM y
)
3085 if (!SCM_NUMBERP (x
))
3086 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3087 else if (!SCM_NUMBERP (y
))
3088 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3090 return scm_less_p (y
, x
);
3095 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3096 /* "Return @code{#t} if the list of parameters is monotonically\n"
3099 #define FUNC_NAME s_scm_leq_p
3101 scm_leq_p (SCM x
, SCM y
)
3103 if (!SCM_NUMBERP (x
))
3104 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3105 else if (!SCM_NUMBERP (y
))
3106 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3108 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3113 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3114 /* "Return @code{#t} if the list of parameters is monotonically\n"
3117 #define FUNC_NAME s_scm_geq_p
3119 scm_geq_p (SCM x
, SCM y
)
3121 if (!SCM_NUMBERP (x
))
3122 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3123 else if (!SCM_NUMBERP (y
))
3124 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3126 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3131 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3132 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3138 if (SCM_INUMP (z
)) {
3139 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3140 } else if (SCM_BIGP (z
)) {
3142 } else if (SCM_REALP (z
)) {
3143 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3144 } else if (SCM_COMPLEXP (z
)) {
3145 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3146 && SCM_COMPLEX_IMAG (z
) == 0.0);
3148 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3153 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3154 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3158 scm_positive_p (SCM x
)
3160 if (SCM_INUMP (x
)) {
3161 return SCM_BOOL (SCM_INUM (x
) > 0);
3162 } else if (SCM_BIGP (x
)) {
3163 return SCM_BOOL (!SCM_BIGSIGN (x
));
3164 } else if (SCM_REALP (x
)) {
3165 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3167 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3172 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3173 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3177 scm_negative_p (SCM x
)
3179 if (SCM_INUMP (x
)) {
3180 return SCM_BOOL (SCM_INUM (x
) < 0);
3181 } else if (SCM_BIGP (x
)) {
3182 return SCM_BOOL (SCM_BIGSIGN (x
));
3183 } else if (SCM_REALP (x
)) {
3184 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3186 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3191 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3192 /* "Return the maximum of all parameter values."
3195 scm_max (SCM x
, SCM y
)
3197 if (SCM_UNBNDP (y
)) {
3198 if (SCM_UNBNDP (x
)) {
3199 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
3200 } else if (SCM_NUMBERP (x
)) {
3203 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3207 if (SCM_INUMP (x
)) {
3208 long xx
= SCM_INUM (x
);
3209 if (SCM_INUMP (y
)) {
3210 long yy
= SCM_INUM (y
);
3211 return (xx
< yy
) ? y
: x
;
3212 } else if (SCM_BIGP (y
)) {
3213 return SCM_BIGSIGN (y
) ? x
: y
;
3214 } else if (SCM_REALP (y
)) {
3216 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3218 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3220 } else if (SCM_BIGP (x
)) {
3221 if (SCM_INUMP (y
)) {
3222 return SCM_BIGSIGN (x
) ? y
: x
;
3223 } else if (SCM_BIGP (y
)) {
3224 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3225 } else if (SCM_REALP (y
)) {
3226 double z
= scm_i_big2dbl (x
);
3227 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3229 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3231 } else if (SCM_REALP (x
)) {
3232 if (SCM_INUMP (y
)) {
3233 double z
= SCM_INUM (y
);
3234 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3235 } else if (SCM_BIGP (y
)) {
3236 double z
= scm_i_big2dbl (y
);
3237 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3238 } else if (SCM_REALP (y
)) {
3239 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? y
: x
;
3241 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3244 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3249 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3250 /* "Return the minium of all parameter values."
3253 scm_min (SCM x
, SCM y
)
3255 if (SCM_UNBNDP (y
)) {
3256 if (SCM_UNBNDP (x
)) {
3257 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
3258 } else if (SCM_NUMBERP (x
)) {
3261 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3265 if (SCM_INUMP (x
)) {
3266 long xx
= SCM_INUM (x
);
3267 if (SCM_INUMP (y
)) {
3268 long yy
= SCM_INUM (y
);
3269 return (xx
< yy
) ? x
: y
;
3270 } else if (SCM_BIGP (y
)) {
3271 return SCM_BIGSIGN (y
) ? y
: x
;
3272 } else if (SCM_REALP (y
)) {
3274 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3276 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3278 } else if (SCM_BIGP (x
)) {
3279 if (SCM_INUMP (y
)) {
3280 return SCM_BIGSIGN (x
) ? x
: y
;
3281 } else if (SCM_BIGP (y
)) {
3282 return (-1 == scm_bigcomp (x
, y
)) ? y
: x
;
3283 } else if (SCM_REALP (y
)) {
3284 double z
= scm_i_big2dbl (x
);
3285 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3287 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3289 } else if (SCM_REALP (x
)) {
3290 if (SCM_INUMP (y
)) {
3291 double z
= SCM_INUM (y
);
3292 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3293 } else if (SCM_BIGP (y
)) {
3294 double z
= scm_i_big2dbl (y
);
3295 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3296 } else if (SCM_REALP (y
)) {
3297 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? x
: y
;
3299 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3302 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3307 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3308 /* "Return the sum of all parameter values. Return 0 if called without\n"
3312 scm_sum (SCM x
, SCM y
)
3314 if (SCM_UNBNDP (y
)) {
3315 if (SCM_UNBNDP (x
)) {
3317 } else if (SCM_NUMBERP (x
)) {
3320 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3324 if (SCM_INUMP (x
)) {
3325 long int xx
= SCM_INUM (x
);
3326 if (SCM_INUMP (y
)) {
3327 long int yy
= SCM_INUM (y
);
3328 long int z
= xx
+ yy
;
3329 if (SCM_FIXABLE (z
)) {
3330 return SCM_MAKINUM (z
);
3333 return scm_i_long2big (z
);
3334 #else /* SCM_BIGDIG */
3335 return scm_make_real ((double) z
);
3336 #endif /* SCM_BIGDIG */
3338 } else if (SCM_BIGP (y
)) {
3341 long int xx
= SCM_INUM (x
);
3342 #ifndef SCM_DIGSTOOBIG
3343 long z
= scm_pseudolong (xx
);
3344 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3345 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3346 #else /* SCM_DIGSTOOBIG */
3347 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3348 scm_longdigs (xx
, zdigs
);
3349 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3350 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3351 #endif /* SCM_DIGSTOOBIG */
3353 } else if (SCM_REALP (y
)) {
3354 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3355 } else if (SCM_COMPLEXP (y
)) {
3356 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3357 SCM_COMPLEX_IMAG (y
));
3359 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3361 } else if (SCM_BIGP (x
)) {
3362 if (SCM_INUMP (y
)) {
3365 } else if (SCM_BIGP (y
)) {
3366 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
)) {
3369 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3370 SCM_BIGSIGN (x
), y
, 0);
3371 } else if (SCM_REALP (y
)) {
3372 return scm_make_real (scm_i_big2dbl (x
) + SCM_REAL_VALUE (y
));
3373 } else if (SCM_COMPLEXP (y
)) {
3374 return scm_make_complex (scm_i_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3375 SCM_COMPLEX_IMAG (y
));
3377 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3379 } else if (SCM_REALP (x
)) {
3380 if (SCM_INUMP (y
)) {
3381 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3382 } else if (SCM_BIGP (y
)) {
3383 return scm_make_real (SCM_REAL_VALUE (x
) + scm_i_big2dbl (y
));
3384 } else if (SCM_REALP (y
)) {
3385 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3386 } else if (SCM_COMPLEXP (y
)) {
3387 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3388 SCM_COMPLEX_IMAG (y
));
3390 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3392 } else if (SCM_COMPLEXP (x
)) {
3393 if (SCM_INUMP (y
)) {
3394 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3395 SCM_COMPLEX_IMAG (x
));
3396 } else if (SCM_BIGP (y
)) {
3397 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_i_big2dbl (y
),
3398 SCM_COMPLEX_IMAG (x
));
3399 } else if (SCM_REALP (y
)) {
3400 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3401 SCM_COMPLEX_IMAG (x
));
3402 } else if (SCM_COMPLEXP (y
)) {
3403 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3404 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3406 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3409 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3414 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3415 /* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3416 * the sum of all but the first argument are subtracted from the first
3418 #define FUNC_NAME s_difference
3420 scm_difference (SCM x
, SCM y
)
3422 if (SCM_UNBNDP (y
)) {
3423 if (SCM_UNBNDP (x
)) {
3424 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3425 } else if (SCM_INUMP (x
)) {
3426 long xx
= -SCM_INUM (x
);
3427 if (SCM_FIXABLE (xx
)) {
3428 return SCM_MAKINUM (xx
);
3431 return scm_i_long2big (xx
);
3433 return scm_make_real ((double) xx
);
3436 } else if (SCM_BIGP (x
)) {
3437 SCM z
= scm_i_copybig (x
, !SCM_BIGSIGN (x
));
3438 unsigned int digs
= SCM_NUMDIGS (z
);
3439 unsigned int size
= digs
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
;
3440 return size
<= sizeof (SCM
) ? scm_i_big2inum (z
, digs
) : z
;
3441 } else if (SCM_REALP (x
)) {
3442 return scm_make_real (-SCM_REAL_VALUE (x
));
3443 } else if (SCM_COMPLEXP (x
)) {
3444 return scm_make_complex (-SCM_COMPLEX_REAL (x
), -SCM_COMPLEX_IMAG (x
));
3446 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3450 if (SCM_INUMP (x
)) {
3451 long int xx
= SCM_INUM (x
);
3452 if (SCM_INUMP (y
)) {
3453 long int yy
= SCM_INUM (y
);
3454 long int z
= xx
- yy
;
3455 if (SCM_FIXABLE (z
)) {
3456 return SCM_MAKINUM (z
);
3459 return scm_i_long2big (z
);
3461 return scm_make_real ((double) z
);
3464 } else if (SCM_BIGP (y
)) {
3465 #ifndef SCM_DIGSTOOBIG
3466 long z
= scm_pseudolong (xx
);
3467 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3468 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3470 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3471 scm_longdigs (xx
, zdigs
);
3472 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3473 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3475 } else if (SCM_REALP (y
)) {
3476 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
3477 } else if (SCM_COMPLEXP (y
)) {
3478 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
3479 -SCM_COMPLEX_IMAG (y
));
3481 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3483 } else if (SCM_BIGP (x
)) {
3484 if (SCM_INUMP (y
)) {
3485 long int yy
= SCM_INUM (y
);
3486 #ifndef SCM_DIGSTOOBIG
3487 long z
= scm_pseudolong (yy
);
3488 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3489 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3491 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3492 scm_longdigs (yy
, zdigs
);
3493 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3494 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3496 } else if (SCM_BIGP (y
)) {
3497 return (SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3498 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3499 SCM_BIGSIGN (x
), y
, SCM_BIGSIGNFLAG
)
3500 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3501 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
, x
, 0);
3502 } else if (SCM_REALP (y
)) {
3503 return scm_make_real (scm_i_big2dbl (x
) - SCM_REAL_VALUE (y
));
3504 } else if (SCM_COMPLEXP (y
)) {
3505 return scm_make_complex (scm_i_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3506 - SCM_COMPLEX_IMAG (y
));
3508 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3510 } else if (SCM_REALP (x
)) {
3511 if (SCM_INUMP (y
)) {
3512 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
3513 } else if (SCM_BIGP (y
)) {
3514 return scm_make_real (SCM_REAL_VALUE (x
) - scm_i_big2dbl (y
));
3515 } else if (SCM_REALP (y
)) {
3516 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3517 } else if (SCM_COMPLEXP (y
)) {
3518 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3519 -SCM_COMPLEX_IMAG (y
));
3521 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3523 } else if (SCM_COMPLEXP (x
)) {
3524 if (SCM_INUMP (y
)) {
3525 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
3526 SCM_COMPLEX_IMAG (x
));
3527 } else if (SCM_BIGP (y
)) {
3528 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_i_big2dbl (y
),
3529 SCM_COMPLEX_IMAG (x
));
3530 } else if (SCM_REALP (y
)) {
3531 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3532 SCM_COMPLEX_IMAG (x
));
3533 } else if (SCM_COMPLEXP (y
)) {
3534 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3535 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3537 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3540 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3545 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3546 /* "Return the product of all arguments. If called without arguments,\n"
3550 scm_product (SCM x
, SCM y
)
3552 if (SCM_UNBNDP (y
)) {
3553 if (SCM_UNBNDP (x
)) {
3554 return SCM_MAKINUM (1L);
3555 } else if (SCM_NUMBERP (x
)) {
3558 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3562 if (SCM_INUMP (x
)) {
3570 } else if (xx
== 1) {
3574 if (SCM_INUMP (y
)) {
3575 long yy
= SCM_INUM (y
);
3577 SCM k
= SCM_MAKINUM (kk
);
3578 if (kk
!= SCM_INUM (k
) || kk
/ xx
!= yy
) {
3580 int sgn
= (xx
< 0) ^ (yy
< 0);
3581 #ifndef SCM_DIGSTOOBIG
3582 long i
= scm_pseudolong (xx
);
3583 long j
= scm_pseudolong (yy
);
3584 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3585 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3586 #else /* SCM_DIGSTOOBIG */
3587 SCM_BIGDIG xdigs
[SCM_DIGSPERLONG
];
3588 SCM_BIGDIG ydigs
[SCM_DIGSPERLONG
];
3589 scm_longdigs (xx
, xdigs
);
3590 scm_longdigs (yy
, ydigs
);
3591 return scm_mulbig (xdigs
, SCM_DIGSPERLONG
,
3592 ydigs
, SCM_DIGSPERLONG
,
3596 return scm_make_real (((double) xx
) * ((double) yy
));
3601 } else if (SCM_BIGP (y
)) {
3602 #ifndef SCM_DIGSTOOBIG
3603 long z
= scm_pseudolong (xx
);
3604 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3605 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3606 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3608 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3609 scm_longdigs (xx
, zdigs
);
3610 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3611 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3612 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3614 } else if (SCM_REALP (y
)) {
3615 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3616 } else if (SCM_COMPLEXP (y
)) {
3617 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3618 xx
* SCM_COMPLEX_IMAG (y
));
3620 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3622 } else if (SCM_BIGP (x
)) {
3623 if (SCM_INUMP (y
)) {
3626 } else if (SCM_BIGP (y
)) {
3627 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3628 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3629 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3630 } else if (SCM_REALP (y
)) {
3631 return scm_make_real (scm_i_big2dbl (x
) * SCM_REAL_VALUE (y
));
3632 } else if (SCM_COMPLEXP (y
)) {
3633 double z
= scm_i_big2dbl (x
);
3634 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3635 z
* SCM_COMPLEX_IMAG (y
));
3637 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3639 } else if (SCM_REALP (x
)) {
3640 if (SCM_INUMP (y
)) {
3641 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3642 } else if (SCM_BIGP (y
)) {
3643 return scm_make_real (scm_i_big2dbl (y
) * SCM_REAL_VALUE (x
));
3644 } else if (SCM_REALP (y
)) {
3645 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
3646 } else if (SCM_COMPLEXP (y
)) {
3647 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
3648 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3650 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3652 } else if (SCM_COMPLEXP (x
)) {
3653 if (SCM_INUMP (y
)) {
3654 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3655 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3656 } else if (SCM_BIGP (y
)) {
3657 double z
= scm_i_big2dbl (y
);
3658 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
3659 z
* SCM_COMPLEX_IMAG (x
));
3660 } else if (SCM_REALP (y
)) {
3661 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3662 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
3663 } else if (SCM_COMPLEXP (y
)) {
3664 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
3665 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
3666 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3667 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3669 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3672 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3678 scm_num2dbl (SCM a
, const char *why
)
3679 #define FUNC_NAME why
3681 if (SCM_INUMP (a
)) {
3682 return (double) SCM_INUM (a
);
3683 } else if (SCM_BIGP (a
)) {
3684 return scm_i_big2dbl (a
);
3685 } else if (SCM_REALP (a
)) {
3686 return (SCM_REAL_VALUE (a
));
3688 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3694 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3695 /* Divide the first argument by the product of the remaining
3696 arguments. If called with one argument @var{z1}, 1/@var{z1} is
3698 #define FUNC_NAME s_divide
3700 scm_divide (SCM x
, SCM y
)
3704 if (SCM_UNBNDP (y
)) {
3705 if (SCM_UNBNDP (x
)) {
3706 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
3707 } else if (SCM_INUMP (x
)) {
3708 long xx
= SCM_INUM (x
);
3709 if (xx
== 1 || xx
== -1) {
3711 } else if (xx
== 0) {
3712 scm_num_overflow (s_divide
);
3714 return scm_make_real (1.0 / (double) xx
);
3716 } else if (SCM_BIGP (x
)) {
3717 return scm_make_real (1.0 / scm_i_big2dbl (x
));
3718 } else if (SCM_REALP (x
)) {
3719 double xx
= SCM_REAL_VALUE (x
);
3721 scm_num_overflow (s_divide
);
3723 return scm_make_real (1.0 / xx
);
3724 } else if (SCM_COMPLEXP (x
)) {
3725 double r
= SCM_COMPLEX_REAL (x
);
3726 double i
= SCM_COMPLEX_IMAG (x
);
3727 double d
= r
* r
+ i
* i
;
3728 return scm_make_complex (r
/ d
, -i
/ d
);
3730 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3734 if (SCM_INUMP (x
)) {
3735 long xx
= SCM_INUM (x
);
3736 if (SCM_INUMP (y
)) {
3737 long yy
= SCM_INUM (y
);
3739 scm_num_overflow (s_divide
);
3740 } else if (xx
% yy
!= 0) {
3741 return scm_make_real ((double) xx
/ (double) yy
);
3744 if (SCM_FIXABLE (z
)) {
3745 return SCM_MAKINUM (z
);
3748 return scm_i_long2big (z
);
3750 return scm_make_real ((double) xx
/ (double) yy
);
3754 } else if (SCM_BIGP (y
)) {
3755 return scm_make_real ((double) xx
/ scm_i_big2dbl (y
));
3756 } else if (SCM_REALP (y
)) {
3757 double yy
= SCM_REAL_VALUE (y
);
3759 scm_num_overflow (s_divide
);
3761 return scm_make_real ((double) xx
/ yy
);
3762 } else if (SCM_COMPLEXP (y
)) {
3764 complex_div
: /* y _must_ be a complex number */
3766 double r
= SCM_COMPLEX_REAL (y
);
3767 double i
= SCM_COMPLEX_IMAG (y
);
3768 double d
= r
* r
+ i
* i
;
3769 return scm_make_complex ((a
* r
) / d
, (-a
* i
) / d
);
3772 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3774 } else if (SCM_BIGP (x
)) {
3775 if (SCM_INUMP (y
)) {
3776 long int yy
= SCM_INUM (y
);
3778 scm_num_overflow (s_divide
);
3779 } else if (yy
== 1) {
3782 long z
= yy
< 0 ? -yy
: yy
;
3783 if (z
< SCM_BIGRAD
) {
3784 SCM w
= scm_i_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
3785 return scm_divbigdig (SCM_BDIGITS (w
), SCM_NUMDIGS (w
),
3787 ? scm_make_real (scm_i_big2dbl (x
) / (double) yy
)
3788 : scm_i_normbig (w
);
3791 #ifndef SCM_DIGSTOOBIG
3792 z
= scm_pseudolong (z
);
3793 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3794 (SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3795 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3797 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3798 scm_longdigs (z
, zdigs
);
3799 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3800 zdigs
, SCM_DIGSPERLONG
,
3801 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3803 return (!SCM_UNBNDP (w
))
3805 : scm_make_real (scm_i_big2dbl (x
) / (double) yy
);
3808 } else if (SCM_BIGP (y
)) {
3809 SCM w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3810 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3811 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 3);
3812 return (!SCM_UNBNDP (w
))
3814 : scm_make_real (scm_i_big2dbl (x
) / scm_i_big2dbl (y
));
3815 } else if (SCM_REALP (y
)) {
3816 double yy
= SCM_REAL_VALUE (y
);
3818 scm_num_overflow (s_divide
);
3820 return scm_make_real (scm_i_big2dbl (x
) / yy
);
3821 } else if (SCM_COMPLEXP (y
)) {
3822 a
= scm_i_big2dbl (x
);
3825 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3827 } else if (SCM_REALP (x
)) {
3828 double rx
= SCM_REAL_VALUE (x
);
3829 if (SCM_INUMP (y
)) {
3830 long int yy
= SCM_INUM (y
);
3832 scm_num_overflow (s_divide
);
3834 return scm_make_real (rx
/ (double) yy
);
3836 } else if (SCM_BIGP (y
)) {
3837 return scm_make_real (rx
/ scm_i_big2dbl (y
));
3838 } else if (SCM_REALP (y
)) {
3839 double yy
= SCM_REAL_VALUE (y
);
3841 scm_num_overflow (s_divide
);
3843 return scm_make_real (rx
/ yy
);
3844 } else if (SCM_COMPLEXP (y
)) {
3848 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3850 } else if (SCM_COMPLEXP (x
)) {
3851 double rx
= SCM_COMPLEX_REAL (x
);
3852 double ix
= SCM_COMPLEX_IMAG (x
);
3853 if (SCM_INUMP (y
)) {
3854 long int yy
= SCM_INUM (y
);
3856 scm_num_overflow (s_divide
);
3859 return scm_make_complex (rx
/ d
, ix
/ d
);
3861 } else if (SCM_BIGP (y
)) {
3862 double d
= scm_i_big2dbl (y
);
3863 return scm_make_complex (rx
/ d
, ix
/ d
);
3864 } else if (SCM_REALP (y
)) {
3865 double yy
= SCM_REAL_VALUE (y
);
3867 scm_num_overflow (s_divide
);
3869 return scm_make_complex (rx
/ yy
, ix
/ yy
);
3870 } else if (SCM_COMPLEXP (y
)) {
3871 double ry
= SCM_COMPLEX_REAL (y
);
3872 double iy
= SCM_COMPLEX_IMAG (y
);
3873 double d
= ry
* ry
+ iy
* iy
;
3874 return scm_make_complex ((rx
* ry
+ ix
* iy
) / d
,
3875 (ix
* ry
- rx
* iy
) / d
);
3877 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3880 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
3885 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
3886 /* "Return the inverse hyperbolic sine of @var{x}."
3889 scm_asinh (double x
)
3891 return log (x
+ sqrt (x
* x
+ 1));
3897 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
3898 /* "Return the inverse hyperbolic cosine of @var{x}."
3901 scm_acosh (double x
)
3903 return log (x
+ sqrt (x
* x
- 1));
3909 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
3910 /* "Return the inverse hyperbolic tangent of @var{x}."
3913 scm_atanh (double x
)
3915 return 0.5 * log ((1 + x
) / (1 - x
));
3921 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
3922 /* "Round the inexact number @var{x} towards zero."
3925 scm_truncate (double x
)
3934 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
3935 /* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
3936 * "numbers, round towards even."
3939 scm_round (double x
)
3941 double plus_half
= x
+ 0.5;
3942 double result
= floor (plus_half
);
3943 /* Adjust so that the scm_round is towards even. */
3944 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
3945 ? result
- 1 : result
;
3949 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
3950 /* "Round the number @var{x} towards minus infinity."
3952 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
3953 /* "Round the number @var{x} towards infinity."
3955 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
3956 /* "Return the square root of the real number @var{x}."
3958 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
3959 /* "Return the absolute value of the real number @var{x}."
3961 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
3962 /* "Return the @var{x}th power of e."
3964 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
3965 /* "Return the natural logarithm of the real number @var{x}."
3967 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
3968 /* "Return the sine of the real number @var{x}."
3970 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
3971 /* "Return the cosine of the real number @var{x}."
3973 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
3974 /* "Return the tangent of the real number @var{x}."
3976 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
3977 /* "Return the arc sine of the real number @var{x}."
3979 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
3980 /* "Return the arc cosine of the real number @var{x}."
3982 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
3983 /* "Return the arc tangent of the real number @var{x}."
3985 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
3986 /* "Return the hyperbolic sine of the real number @var{x}."
3988 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
3989 /* "Return the hyperbolic cosine of the real number @var{x}."
3991 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
3992 /* "Return the hyperbolic tangent of the real number @var{x}."
4000 static void scm_two_doubles (SCM x
,
4002 const char *sstring
,
4006 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
4008 if (SCM_INUMP (x
)) {
4009 xy
->x
= SCM_INUM (x
);
4010 } else if (SCM_BIGP (x
)) {
4011 xy
->x
= scm_i_big2dbl (x
);
4012 } else if (SCM_REALP (x
)) {
4013 xy
->x
= SCM_REAL_VALUE (x
);
4015 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
4018 if (SCM_INUMP (y
)) {
4019 xy
->y
= SCM_INUM (y
);
4020 } else if (SCM_BIGP (y
)) {
4021 xy
->y
= scm_i_big2dbl (y
);
4022 } else if (SCM_REALP (y
)) {
4023 xy
->y
= SCM_REAL_VALUE (y
);
4025 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
4030 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
4032 "Return @var{x} raised to the power of @var{y}. This\n"
4033 "procedure does not accept complex arguments.")
4034 #define FUNC_NAME s_scm_sys_expt
4037 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4038 return scm_make_real (pow (xy
.x
, xy
.y
));
4043 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4045 "Return the arc tangent of the two arguments @var{x} and\n"
4046 "@var{y}. This is similar to calculating the arc tangent of\n"
4047 "@var{x} / @var{y}, except that the signs of both arguments\n"
4048 "are used to determine the quadrant of the result. This\n"
4049 "procedure does not accept complex arguments.")
4050 #define FUNC_NAME s_scm_sys_atan2
4053 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4054 return scm_make_real (atan2 (xy
.x
, xy
.y
));
4059 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4060 (SCM real
, SCM imaginary
),
4061 "Return a complex number constructed of the given @var{real} and\n"
4062 "@var{imaginary} parts.")
4063 #define FUNC_NAME s_scm_make_rectangular
4066 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
4067 return scm_make_complex (xy
.x
, xy
.y
);
4073 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4075 "Return the complex number @var{x} * e^(i * @var{y}).")
4076 #define FUNC_NAME s_scm_make_polar
4079 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4080 return scm_make_complex (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
4085 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4086 /* "Return the real part of the number @var{z}."
4089 scm_real_part (SCM z
)
4091 if (SCM_INUMP (z
)) {
4093 } else if (SCM_BIGP (z
)) {
4095 } else if (SCM_REALP (z
)) {
4097 } else if (SCM_COMPLEXP (z
)) {
4098 return scm_make_real (SCM_COMPLEX_REAL (z
));
4100 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4105 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4106 /* "Return the imaginary part of the number @var{z}."
4109 scm_imag_part (SCM z
)
4111 if (SCM_INUMP (z
)) {
4113 } else if (SCM_BIGP (z
)) {
4115 } else if (SCM_REALP (z
)) {
4117 } else if (SCM_COMPLEXP (z
)) {
4118 return scm_make_real (SCM_COMPLEX_IMAG (z
));
4120 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4125 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4126 /* "Return the magnitude of the number @var{z}. This is the same as\n"
4127 * "@code{abs} for real arguments, but also allows complex numbers."
4130 scm_magnitude (SCM z
)
4132 if (SCM_INUMP (z
)) {
4133 long int zz
= SCM_INUM (z
);
4136 } else if (SCM_POSFIXABLE (-zz
)) {
4137 return SCM_MAKINUM (-zz
);
4140 return scm_i_long2big (-zz
);
4142 scm_num_overflow (s_magnitude
);
4145 } else if (SCM_BIGP (z
)) {
4146 if (!SCM_BIGSIGN (z
)) {
4149 return scm_i_copybig (z
, 0);
4151 } else if (SCM_REALP (z
)) {
4152 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
4153 } else if (SCM_COMPLEXP (z
)) {
4154 double r
= SCM_COMPLEX_REAL (z
);
4155 double i
= SCM_COMPLEX_IMAG (z
);
4156 return scm_make_real (sqrt (i
* i
+ r
* r
));
4158 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4163 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
4164 /* "Return the angle of the complex number @var{z}."
4169 if (SCM_INUMP (z
)) {
4170 if (SCM_INUM (z
) >= 0) {
4171 return scm_make_real (atan2 (0.0, 1.0));
4173 return scm_make_real (atan2 (0.0, -1.0));
4175 } else if (SCM_BIGP (z
)) {
4176 if (SCM_BIGSIGN (z
)) {
4177 return scm_make_real (atan2 (0.0, -1.0));
4179 return scm_make_real (atan2 (0.0, 1.0));
4181 } else if (SCM_REALP (z
)) {
4182 return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z
)));
4183 } else if (SCM_COMPLEXP (z
)) {
4184 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
4186 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
4191 SCM_GPROC (s_exact_to_inexact
, "exact->inexact", 1, 0, 0, scm_exact_to_inexact
, g_exact_to_inexact
);
4192 /* Convert the number @var{x} to its inexact representation.\n"
4195 scm_exact_to_inexact (SCM z
)
4198 return scm_make_real ((double) SCM_INUM (z
));
4199 else if (SCM_BIGP (z
))
4200 return scm_make_real (scm_i_big2dbl (z
));
4201 else if (SCM_INEXACTP (z
))
4204 SCM_WTA_DISPATCH_1 (g_exact_to_inexact
, z
, 1, s_exact_to_inexact
);
4208 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4210 "Return an exact number that is numerically closest to @var{z}.")
4211 #define FUNC_NAME s_scm_inexact_to_exact
4213 if (SCM_INUMP (z
)) {
4215 } else if (SCM_BIGP (z
)) {
4217 } else if (SCM_REALP (z
)) {
4218 double u
= floor (SCM_REAL_VALUE (z
) + 0.5);
4220 if (SCM_FIXABLE (lu
)) {
4221 return SCM_MAKINUM (lu
);
4223 } else if (isfinite (u
)) {
4224 return scm_i_dbl2big (u
);
4227 scm_num_overflow (s_scm_inexact_to_exact
);
4230 SCM_WRONG_TYPE_ARG (1, z
);
4237 /* d must be integer */
4240 scm_i_dbl2big (double d
)
4246 double u
= (d
< 0) ? -d
: d
;
4247 while (0 != floor (u
))
4252 ans
= scm_i_mkbig (i
, d
< 0);
4253 digits
= SCM_BDIGITS (ans
);
4261 #ifndef SCM_RECKLESS
4263 scm_num_overflow ("dbl2big");
4269 scm_i_big2dbl (SCM b
)
4272 size_t i
= SCM_NUMDIGS (b
);
4273 SCM_BIGDIG
*digits
= SCM_BDIGITS (b
);
4275 ans
= digits
[i
] + SCM_BIGRAD
* ans
;
4276 if (SCM_BIGSIGN (b
))
4283 #ifdef HAVE_LONG_LONGS
4285 # define ULLONG_MAX ((unsigned long long) (-1))
4286 # define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
4287 # define LLONG_MIN (~LLONG_MAX)
4291 /* Parameters for creating integer conversion routines.
4293 Define the following preprocessor macros before including
4294 "libguile/num2integral.i.c":
4296 NUM2INTEGRAL - the name of the function for converting from a
4297 Scheme object to the integral type. This function
4298 will be defined when including "num2integral.i.c".
4300 INTEGRAL2NUM - the name of the function for converting from the
4301 integral type to a Scheme object. This function
4304 INTEGRAL2BIG - the name of an internal function that createas a
4305 bignum from the integral type. This function will
4306 be defined. The name should start with "scm_i_".
4308 ITYPE - the name of the integral type.
4310 UNSIGNED - Define this when ITYPE is an unsigned type. Do not
4311 define it otherwise.
4314 - the name of the the unsigned variant of the
4315 integral type. If you don't define this, it defaults
4316 to "unsigned ITYPE" for signed types and simply "ITYPE"
4319 SIZEOF_ITYPE - an expression giving the size of the integral type in
4320 bytes. This expression must be computable by the
4321 preprocessor. If you don't know a value for this,
4322 don't define it. The purpose of this parameter is
4323 mainly to suppress some warnings. The generated
4324 code will work correctly without it.
4327 #define NUM2INTEGRAL scm_num2short
4328 #define INTEGRAL2NUM scm_short2num
4329 #define INTEGRAL2BIG scm_i_short2big
4331 #define SIZEOF_ITYPE SIZEOF_SHORT
4332 #include "libguile/num2integral.i.c"
4334 #define NUM2INTEGRAL scm_num2ushort
4335 #define INTEGRAL2NUM scm_ushort2num
4336 #define INTEGRAL2BIG scm_i_ushort2big
4338 #define ITYPE unsigned short
4339 #define SIZEOF_ITYPE SIZEOF_SHORT
4340 #include "libguile/num2integral.i.c"
4342 #define NUM2INTEGRAL scm_num2int
4343 #define INTEGRAL2NUM scm_int2num
4344 #define INTEGRAL2BIG scm_i_int2big
4346 #define SIZEOF_ITYPE SIZEOF_INT
4347 #include "libguile/num2integral.i.c"
4349 #define NUM2INTEGRAL scm_num2uint
4350 #define INTEGRAL2NUM scm_uint2num
4351 #define INTEGRAL2BIG scm_i_uint2big
4353 #define ITYPE unsigned int
4354 #define SIZEOF_ITYPE SIZEOF_INT
4355 #include "libguile/num2integral.i.c"
4357 #define NUM2INTEGRAL scm_num2long
4358 #define INTEGRAL2NUM scm_long2num
4359 #define INTEGRAL2BIG scm_i_long2big
4361 #define SIZEOF_ITYPE SIZEOF_LONG
4362 #include "libguile/num2integral.i.c"
4364 #define NUM2INTEGRAL scm_num2ulong
4365 #define INTEGRAL2NUM scm_ulong2num
4366 #define INTEGRAL2BIG scm_i_ulong2big
4368 #define ITYPE unsigned long
4369 #define SIZEOF_ITYPE SIZEOF_LONG
4370 #include "libguile/num2integral.i.c"
4372 #define NUM2INTEGRAL scm_num2ptrdiff
4373 #define INTEGRAL2NUM scm_ptrdiff2num
4374 #define INTEGRAL2BIG scm_i_ptrdiff2big
4375 #define ITYPE ptrdiff_t
4376 #define UNSIGNED_ITYPE size_t
4377 #define SIZEOF_ITYPE SIZEOF_PTRDIFF_T
4378 #include "libguile/num2integral.i.c"
4380 #define NUM2INTEGRAL scm_num2size
4381 #define INTEGRAL2NUM scm_size2num
4382 #define INTEGRAL2BIG scm_i_size2big
4384 #define ITYPE size_t
4385 #define SIZEOF_ITYPE SIZEOF_SIZE_T
4386 #include "libguile/num2integral.i.c"
4388 #ifdef HAVE_LONG_LONGS
4390 #ifndef ULONG_LONG_MAX
4391 #define ULONG_LONG_MAX (~0ULL)
4394 #define NUM2INTEGRAL scm_num2long_long
4395 #define INTEGRAL2NUM scm_long_long2num
4396 #define INTEGRAL2BIG scm_i_long_long2big
4397 #define ITYPE long long
4398 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
4399 #include "libguile/num2integral.i.c"
4401 #define NUM2INTEGRAL scm_num2ulong_long
4402 #define INTEGRAL2NUM scm_ulong_long2num
4403 #define INTEGRAL2BIG scm_i_ulong_long2big
4405 #define ITYPE unsigned long long
4406 #define SIZEOF_ITYPE SIZEOF_LONG_LONG
4407 #include "libguile/num2integral.i.c"
4409 #endif /* HAVE_LONG_LONGS */
4411 #define NUM2FLOAT scm_num2float
4412 #define FLOAT2NUM scm_float2num
4414 #include "libguile/num2float.i.c"
4416 #define NUM2FLOAT scm_num2double
4417 #define FLOAT2NUM scm_double2num
4418 #define FTYPE double
4419 #include "libguile/num2float.i.c"
4424 #define SIZE_MAX ((size_t) (-1))
4427 #define PTRDIFF_MIN \
4428 ((ptrdiff_t) ((ptrdiff_t) 1 << (sizeof (ptrdiff_t) * 8 - 1)))
4431 #define PTRDIFF_MAX (~ PTRDIFF_MIN)
4434 #define CHECK(type, v) \
4436 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
4455 CHECK (ptrdiff
, -1);
4457 CHECK (short, SHRT_MAX
);
4458 CHECK (short, SHRT_MIN
);
4459 CHECK (ushort
, USHRT_MAX
);
4460 CHECK (int, INT_MAX
);
4461 CHECK (int, INT_MIN
);
4462 CHECK (uint
, UINT_MAX
);
4463 CHECK (long, LONG_MAX
);
4464 CHECK (long, LONG_MIN
);
4465 CHECK (ulong
, ULONG_MAX
);
4466 CHECK (size
, SIZE_MAX
);
4467 CHECK (ptrdiff
, PTRDIFF_MAX
);
4468 CHECK (ptrdiff
, PTRDIFF_MIN
);
4470 #ifdef HAVE_LONG_LONGS
4471 CHECK (long_long
, 0LL);
4472 CHECK (ulong_long
, 0ULL);
4473 CHECK (long_long
, -1LL);
4474 CHECK (long_long
, LLONG_MAX
);
4475 CHECK (long_long
, LLONG_MIN
);
4476 CHECK (ulong_long
, ULLONG_MAX
);
4483 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
4484 if (!SCM_FALSEP (data)) abort();
4487 check_body (void *data
)
4489 SCM num
= *(SCM
*) data
;
4490 scm_num2ulong (num
, 1, NULL
);
4492 return SCM_UNSPECIFIED
;
4496 check_handler (void *data
, SCM tag
, SCM throw_args
)
4498 SCM
*num
= (SCM
*) data
;
4501 return SCM_UNSPECIFIED
;
4504 SCM_DEFINE (scm_sys_check_number_conversions
, "%check-number-conversions", 0, 0, 0,
4506 "Number conversion sanity checking.")
4507 #define FUNC_NAME s_scm_sys_check_number_conversions
4509 SCM data
= SCM_MAKINUM (-1);
4511 data
= scm_int2num (INT_MIN
);
4513 data
= scm_ulong2num (ULONG_MAX
);
4514 data
= scm_difference (SCM_INUM0
, data
);
4516 data
= scm_ulong2num (ULONG_MAX
);
4517 data
= scm_sum (SCM_MAKINUM (1), data
); data
= scm_difference (SCM_INUM0
, data
);
4519 data
= scm_int2num (-10000); data
= scm_product (data
, data
); data
= scm_product (data
, data
);
4522 return SCM_UNSPECIFIED
;
4531 abs_most_negative_fixnum
= scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM
);
4532 scm_permanent_object (abs_most_negative_fixnum
);
4534 /* It may be possible to tune the performance of some algorithms by using
4535 * the following constants to avoid the creation of bignums. Please, before
4536 * using these values, remember the two rules of program optimization:
4537 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
4538 scm_c_define ("most-positive-fixnum",
4539 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
4540 scm_c_define ("most-negative-fixnum",
4541 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
4543 scm_add_feature ("complex");
4544 scm_add_feature ("inexact");
4545 scm_flo0
= scm_make_real (0.0);
4547 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4549 { /* determine floating point precision */
4551 double fsum
= 1.0 + f
;
4552 while (fsum
!= 1.0) {
4553 if (++scm_dblprec
> 20) {
4560 scm_dblprec
= scm_dblprec
- 1;
4562 #endif /* DBL_DIG */
4568 #ifndef SCM_MAGIC_SNARFER
4569 #include "libguile/numbers.x"