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_must_malloc (nlen
* sizeof (SCM_BIGDIG
), s_bignum
);
1394 SCM_SET_BIGNUM_BASE (v
, base
);
1395 SCM_SETNUMDIGS (v
, nlen
, sign
);
1400 scm_i_big2inum (SCM b
, size_t l
)
1402 unsigned long num
= 0;
1403 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1405 num
= SCM_BIGUP (num
) + tmp
[l
];
1406 if (!SCM_BIGSIGN (b
))
1408 if (SCM_POSFIXABLE (num
))
1409 return SCM_MAKINUM (num
);
1411 else if (num
<= -SCM_MOST_NEGATIVE_FIXNUM
)
1412 return SCM_MAKINUM (-num
);
1416 static const char s_adjbig
[] = "scm_i_adjbig";
1419 scm_i_adjbig (SCM b
, size_t nlen
)
1422 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1423 scm_memory_error (s_adjbig
);
1429 scm_must_realloc ((char *) SCM_BDIGITS (b
),
1430 (long) (SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
)),
1431 (long) (nsiz
* sizeof (SCM_BIGDIG
)), s_bignum
));
1433 SCM_SET_BIGNUM_BASE (b
, digits
);
1434 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1441 scm_i_normbig (SCM b
)
1444 size_t nlen
= SCM_NUMDIGS (b
);
1446 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1448 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1449 while (nlen
-- && !zds
[nlen
]);
1451 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1452 if (SCM_INUMP (b
= scm_i_big2inum (b
, (size_t) nlen
)))
1454 if (SCM_NUMDIGS (b
) == nlen
)
1456 return scm_i_adjbig (b
, (size_t) nlen
);
1460 scm_i_copybig (SCM b
, int sign
)
1462 size_t i
= SCM_NUMDIGS (b
);
1463 SCM ans
= scm_i_mkbig (i
, sign
);
1464 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1471 scm_bigcomp (SCM x
, SCM y
)
1473 int xsign
= SCM_BIGSIGN (x
);
1474 int ysign
= SCM_BIGSIGN (y
);
1477 /* Look at the signs, first. */
1483 /* They're the same sign, so see which one has more digits. Note
1484 that, if they are negative, the longer number is the lesser. */
1485 ylen
= SCM_NUMDIGS (y
);
1486 xlen
= SCM_NUMDIGS (x
);
1488 return (xsign
) ? -1 : 1;
1490 return (xsign
) ? 1 : -1;
1492 /* They have the same number of digits, so find the most significant
1493 digit where they differ. */
1497 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1498 /* Make the discrimination based on the digit that differs. */
1499 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1501 : (xsign
? 1 : -1));
1504 /* The numbers are identical. */
1508 #ifndef SCM_DIGSTOOBIG
1512 scm_pseudolong (long x
)
1517 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1523 while (i
< SCM_DIGSPERLONG
)
1525 p
.bd
[i
++] = SCM_BIGLO (x
);
1528 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1536 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1541 while (i
< SCM_DIGSPERLONG
)
1543 digs
[i
++] = SCM_BIGLO (x
);
1552 scm_addbig (SCM_BIGDIG
*x
, size_t nx
, int xsgn
, SCM bigy
, int sgny
)
1554 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1555 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1557 size_t i
= 0, ny
= SCM_NUMDIGS (bigy
);
1558 SCM z
= scm_i_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1559 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1560 if (xsgn
^ SCM_BIGSIGN (z
))
1564 num
+= (long) zds
[i
] - x
[i
];
1567 zds
[i
] = num
+ SCM_BIGRAD
;
1572 zds
[i
] = SCM_BIGLO (num
);
1577 if (num
&& nx
== ny
)
1581 SCM_SET_CELL_WORD_0 (z
, SCM_CELL_WORD_0 (z
) ^ SCM_BIGSIGNFLAG
);
1584 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1585 zds
[i
++] = SCM_BIGLO (num
);
1586 num
= SCM_BIGDN (num
);
1596 zds
[i
++] = num
+ SCM_BIGRAD
;
1601 zds
[i
++] = SCM_BIGLO (num
);
1610 num
+= (long) zds
[i
] + x
[i
];
1611 zds
[i
++] = SCM_BIGLO (num
);
1612 num
= SCM_BIGDN (num
);
1620 zds
[i
++] = SCM_BIGLO (num
);
1621 num
= SCM_BIGDN (num
);
1627 z
= scm_i_adjbig (z
, ny
+ 1);
1628 SCM_BDIGITS (z
)[ny
] = num
;
1632 return scm_i_normbig (z
);
1637 scm_mulbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
)
1639 size_t i
= 0, j
= nx
+ ny
;
1640 unsigned long n
= 0;
1641 SCM z
= scm_i_mkbig (j
, sgn
);
1642 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1652 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1653 zds
[i
+ j
++] = SCM_BIGLO (n
);
1665 return scm_i_normbig (z
);
1670 scm_divbigdig (SCM_BIGDIG
* ds
, size_t h
, SCM_BIGDIG div
)
1672 register unsigned long t2
= 0;
1675 t2
= SCM_BIGUP (t2
) + ds
[h
];
1685 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1691 register unsigned long t2
= 0;
1692 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1693 size_t nd
= SCM_NUMDIGS (x
);
1695 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1698 return SCM_MAKINUM (sgn
? -t2
: t2
);
1701 #ifndef SCM_DIGSTOOBIG
1702 unsigned long t2
= scm_pseudolong (z
);
1703 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1704 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1707 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1708 scm_longdigs (z
, t2
);
1709 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1710 t2
, SCM_DIGSPERLONG
,
1718 scm_divbigbig (SCM_BIGDIG
*x
, size_t nx
, SCM_BIGDIG
*y
, size_t ny
, int sgn
, int modes
)
1720 /* modes description
1724 3 quotient but returns SCM_UNDEFINED if division is not exact. */
1725 size_t i
= 0, j
= 0;
1727 unsigned long t2
= 0;
1729 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1730 /* algorithm requires nx >= ny */
1734 case 0: /* remainder -- just return x */
1735 z
= scm_i_mkbig (nx
, sgn
);
1736 zds
= SCM_BDIGITS (z
);
1743 case 1: /* scm_modulo -- return y-x */
1744 z
= scm_i_mkbig (ny
, sgn
);
1745 zds
= SCM_BDIGITS (z
);
1748 num
+= (long) y
[i
] - x
[i
];
1751 zds
[i
] = num
+ SCM_BIGRAD
;
1766 zds
[i
++] = num
+ SCM_BIGRAD
;
1777 return SCM_INUM0
; /* quotient is zero */
1779 return SCM_UNDEFINED
; /* the division is not exact */
1782 z
= scm_i_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1783 zds
= SCM_BDIGITS (z
);
1787 ny
--; /* in case y came in as a psuedolong */
1788 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1789 { /* normalize operands */
1790 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1791 newy
= scm_i_mkbig (ny
, 0);
1792 yds
= SCM_BDIGITS (newy
);
1795 t2
+= (unsigned long) y
[j
] * d
;
1796 yds
[j
++] = SCM_BIGLO (t2
);
1797 t2
= SCM_BIGDN (t2
);
1804 t2
+= (unsigned long) x
[j
] * d
;
1805 zds
[j
++] = SCM_BIGLO (t2
);
1806 t2
= SCM_BIGDN (t2
);
1816 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1818 { /* loop over digits of quotient */
1819 if (zds
[j
] == y
[ny
- 1])
1820 qhat
= SCM_BIGRAD
- 1;
1822 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1829 { /* multiply and subtract */
1830 t2
+= (unsigned long) y
[i
] * qhat
;
1831 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1834 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1839 zds
[j
- ny
+ i
] = num
;
1842 t2
= SCM_BIGDN (t2
);
1845 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1847 { /* "add back" required */
1853 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1854 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1855 num
= SCM_BIGDN (num
);
1866 case 3: /* check that remainder==0 */
1867 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1869 return SCM_UNDEFINED
;
1870 case 2: /* move quotient down in z */
1871 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
1872 for (i
= 0; i
< j
; i
++)
1873 zds
[i
] = zds
[i
+ ny
];
1876 case 1: /* subtract for scm_modulo */
1882 num
+= y
[i
] - zds
[i
];
1886 zds
[i
] = num
+ SCM_BIGRAD
;
1898 case 0: /* just normalize remainder */
1900 scm_divbigdig (zds
, ny
, d
);
1903 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1904 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
1905 if (SCM_INUMP (z
= scm_i_big2inum (z
, j
)))
1907 return scm_i_adjbig (z
, j
);
1915 /*** NUMBERS -> STRINGS ***/
1917 static const double fx
[] =
1918 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1919 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1920 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1921 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1927 idbl2str (double f
, char *a
)
1929 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1934 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1953 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1954 make-uniform-vector, from causing infinite loops. */
1958 if (exp
-- < DBL_MIN_10_EXP
)
1964 if (exp
++ > DBL_MAX_10_EXP
)
1979 if (f
+ fx
[wp
] >= 10.0)
1986 dpt
= (exp
+ 9999) % 3;
1990 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2015 if (f
+ fx
[wp
] >= 1.0)
2029 if ((dpt
> 4) && (exp
> 6))
2031 d
= (a
[0] == '-' ? 2 : 1);
2032 for (i
= ch
++; i
> d
; i
--)
2045 if (a
[ch
- 1] == '.')
2046 a
[ch
++] = '0'; /* trailing zero */
2055 for (i
= 10; i
<= exp
; i
*= 10);
2056 for (i
/= 10; i
; i
/= 10)
2058 a
[ch
++] = exp
/ i
+ '0';
2067 iflo2str (SCM flt
, char *str
)
2070 if (SCM_REALP (flt
))
2071 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2074 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2075 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2077 if (0 <= SCM_COMPLEX_IMAG (flt
))
2079 i
+= idbl2str (SCM_COMPLEX_IMAG (flt
), &str
[i
]);
2086 /* convert a long to a string (unterminated). returns the number of
2087 characters in the result.
2089 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2091 scm_iint2str (long num
, int rad
, char *p
)
2095 unsigned long n
= (num
< 0) ? -num
: num
;
2097 for (n
/= rad
; n
> 0; n
/= rad
)
2114 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2123 big2str (SCM b
, unsigned int radix
)
2125 SCM t
= scm_i_copybig (b
, 0); /* sign of temp doesn't matter */
2126 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2127 size_t i
= SCM_NUMDIGS (t
);
2128 size_t j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2129 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2130 : (SCM_BITSPERDIG
* i
) + 2;
2133 SCM_BIGDIG radpow
= 1, radmod
= 0;
2134 SCM ss
= scm_allocate_string (j
);
2135 char *s
= SCM_STRING_CHARS (ss
), c
;
2136 while ((long) radpow
* radix
< SCM_BIGRAD
)
2141 while ((i
|| radmod
) && j
)
2145 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2153 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2156 if (SCM_BIGSIGN (b
))
2161 /* The pre-reserved string length was too large. */
2162 unsigned long int length
= SCM_STRING_LENGTH (ss
);
2163 ss
= scm_substring (ss
, SCM_MAKINUM (j
), SCM_MAKINUM (length
));
2166 return scm_return_first (ss
, t
);
2171 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2173 "Return a string holding the external representation of the\n"
2174 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2175 "inexact, a radix of 10 will be used.")
2176 #define FUNC_NAME s_scm_number_to_string
2180 if (SCM_UNBNDP (radix
)) {
2183 SCM_VALIDATE_INUM (2, radix
);
2184 base
= SCM_INUM (radix
);
2185 SCM_ASSERT_RANGE (2, radix
, base
>= 2);
2188 if (SCM_INUMP (n
)) {
2189 char num_buf
[SCM_INTBUFLEN
];
2190 size_t length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2191 return scm_mem2string (num_buf
, length
);
2192 } else if (SCM_BIGP (n
)) {
2193 return big2str (n
, (unsigned int) base
);
2194 } else if (SCM_INEXACTP (n
)) {
2195 char num_buf
[FLOBUFLEN
];
2196 return scm_mem2string (num_buf
, iflo2str (n
, num_buf
));
2198 SCM_WRONG_TYPE_ARG (1, n
);
2204 /* These print routines are stubbed here so that scm_repl.c doesn't need
2205 SCM_BIGDIG conditionals */
2208 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2210 char num_buf
[FLOBUFLEN
];
2211 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2216 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2218 char num_buf
[FLOBUFLEN
];
2219 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2224 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
2227 exp
= big2str (exp
, (unsigned int) 10);
2228 scm_lfwrite (SCM_STRING_CHARS (exp
), (size_t) SCM_STRING_LENGTH (exp
), port
);
2230 scm_ipruk ("bignum", exp
, port
);
2234 /*** END nums->strs ***/
2237 /*** STRINGS -> NUMBERS ***/
2239 /* The following functions implement the conversion from strings to numbers.
2240 * The implementation somehow follows the grammar for numbers as it is given
2241 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
2242 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
2243 * points should be noted about the implementation:
2244 * * Each function keeps a local index variable 'idx' that points at the
2245 * current position within the parsed string. The global index is only
2246 * updated if the function could parse the corresponding syntactic unit
2248 * * Similarly, the functions keep track of indicators of inexactness ('#',
2249 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
2250 * global exactness information is only updated after each part has been
2251 * successfully parsed.
2252 * * Sequences of digits are parsed into temporary variables holding fixnums.
2253 * Only if these fixnums would overflow, the result variables are updated
2254 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
2255 * the temporary variables holding the fixnums are cleared, and the process
2256 * starts over again. If for example fixnums were able to store five decimal
2257 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
2258 * and the result was computed as 12345 * 100000 + 67890. In other words,
2259 * only every five digits two bignum operations were performed.
2262 enum t_exactness
{NO_EXACTNESS
, INEXACT
, EXACT
};
2264 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
2266 /* In non ASCII-style encodings the following macro might not work. */
2267 #define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
2270 mem2uinteger (const char* mem
, size_t len
, unsigned int *p_idx
,
2271 unsigned int radix
, enum t_exactness
*p_exactness
)
2273 unsigned int idx
= *p_idx
;
2274 unsigned int hash_seen
= 0;
2275 scm_t_bits shift
= 1;
2277 unsigned int digit_value
;
2287 digit_value
= XDIGIT2UINT (c
);
2288 if (digit_value
>= radix
)
2292 result
= SCM_MAKINUM (digit_value
);
2300 digit_value
= XDIGIT2UINT (c
);
2301 if (digit_value
>= radix
)
2313 if (SCM_MOST_POSITIVE_FIXNUM
/ radix
< shift
)
2315 result
= scm_product (result
, SCM_MAKINUM (shift
));
2317 result
= scm_sum (result
, SCM_MAKINUM (add
));
2324 shift
= shift
* radix
;
2325 add
= add
* radix
+ digit_value
;
2330 result
= scm_product (result
, SCM_MAKINUM (shift
));
2332 result
= scm_sum (result
, SCM_MAKINUM (add
));
2336 *p_exactness
= INEXACT
;
2342 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2343 * covers the parts of the rules that start at a potential point. The value
2344 * of the digits up to the point have been parsed by the caller and are given
2345 * in variable result. The content of *p_exactness indicates, whether a hash
2346 * has already been seen in the digits before the point.
2349 /* In non ASCII-style encodings the following macro might not work. */
2350 #define DIGIT2UINT(d) ((d) - '0')
2353 mem2decimal_from_point (SCM result
, const char* mem
, size_t len
,
2354 unsigned int *p_idx
, enum t_exactness
*p_exactness
)
2356 unsigned int idx
= *p_idx
;
2357 enum t_exactness x
= *p_exactness
;
2362 if (mem
[idx
] == '.')
2364 scm_t_bits shift
= 1;
2366 unsigned int digit_value
;
2367 SCM big_shift
= SCM_MAKINUM (1);
2378 digit_value
= DIGIT2UINT (c
);
2389 if (SCM_MOST_POSITIVE_FIXNUM
/ 10 < shift
)
2391 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2392 result
= scm_product (result
, SCM_MAKINUM (shift
));
2394 result
= scm_sum (result
, SCM_MAKINUM (add
));
2402 add
= add
* 10 + digit_value
;
2408 big_shift
= scm_product (big_shift
, SCM_MAKINUM (shift
));
2409 result
= scm_product (result
, SCM_MAKINUM (shift
));
2410 result
= scm_sum (result
, SCM_MAKINUM (add
));
2413 result
= scm_divide (result
, big_shift
);
2415 /* We've seen a decimal point, thus the value is implicitly inexact. */
2427 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2458 exponent
= DIGIT2UINT (c
);
2465 if (exponent
<= SCM_MAXEXP
)
2466 exponent
= exponent
* 10 + DIGIT2UINT (c
);
2472 if (exponent
> SCM_MAXEXP
)
2474 size_t exp_len
= idx
- start
;
2475 SCM exp_string
= scm_mem2string (&mem
[start
], exp_len
);
2476 SCM exp_num
= scm_string_to_number (exp_string
, SCM_UNDEFINED
);
2477 scm_out_of_range ("string->number", exp_num
);
2480 e
= scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent
));
2482 result
= scm_product (result
, e
);
2484 result
= scm_divide (result
, e
);
2486 /* We've seen an exponent, thus the value is implicitly inexact. */
2504 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2507 mem2ureal (const char* mem
, size_t len
, unsigned int *p_idx
,
2508 unsigned int radix
, enum t_exactness
*p_exactness
)
2510 unsigned int idx
= *p_idx
;
2515 if (mem
[idx
] == '.')
2519 else if (idx
+ 1 == len
)
2521 else if (!isdigit (mem
[idx
+ 1]))
2524 return mem2decimal_from_point (SCM_MAKINUM (0), mem
, len
,
2525 p_idx
, p_exactness
);
2529 enum t_exactness x
= EXACT
;
2533 uinteger
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2534 if (SCM_FALSEP (uinteger
))
2539 else if (mem
[idx
] == '/')
2545 divisor
= mem2uinteger (mem
, len
, &idx
, radix
, &x
);
2546 if (SCM_FALSEP (divisor
))
2549 result
= scm_divide (uinteger
, divisor
);
2551 else if (radix
== 10)
2553 result
= mem2decimal_from_point (uinteger
, mem
, len
, &idx
, &x
);
2554 if (SCM_FALSEP (result
))
2569 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2572 mem2complex (const char* mem
, size_t len
, unsigned int idx
,
2573 unsigned int radix
, enum t_exactness
*p_exactness
)
2597 ureal
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2598 if (SCM_FALSEP (ureal
))
2600 /* input must be either +i or -i */
2605 if (mem
[idx
] == 'i' || mem
[idx
] == 'I')
2611 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign
));
2619 ureal
= scm_difference (ureal
, SCM_UNDEFINED
);
2628 /* either +<ureal>i or -<ureal>i */
2635 return scm_make_rectangular (SCM_MAKINUM (0), ureal
);
2638 /* polar input: <real>@<real>. */
2663 angle
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2664 if (SCM_FALSEP (angle
))
2670 angle
= scm_difference (angle
, SCM_UNDEFINED
);
2672 result
= scm_make_polar (ureal
, angle
);
2677 /* expecting input matching <real>[+-]<ureal>?i */
2684 int sign
= (c
== '+') ? 1 : -1;
2685 SCM imag
= mem2ureal (mem
, len
, &idx
, radix
, p_exactness
);
2687 if (SCM_FALSEP (imag
))
2688 imag
= SCM_MAKINUM (sign
);
2689 else if (sign
== -1)
2690 imag
= scm_difference (imag
, SCM_UNDEFINED
);
2694 if (mem
[idx
] != 'i' && mem
[idx
] != 'I')
2701 return scm_make_rectangular (ureal
, imag
);
2710 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2712 enum t_radix
{NO_RADIX
=0, DUAL
=2, OCT
=8, DEC
=10, HEX
=16};
2715 scm_i_mem2number (const char* mem
, size_t len
, unsigned int default_radix
)
2717 unsigned int idx
= 0;
2718 unsigned int radix
= NO_RADIX
;
2719 enum t_exactness forced_x
= NO_EXACTNESS
;
2720 enum t_exactness implicit_x
= EXACT
;
2723 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2724 while (idx
+ 2 < len
&& mem
[idx
] == '#')
2726 switch (mem
[idx
+ 1])
2729 if (radix
!= NO_RADIX
)
2734 if (radix
!= NO_RADIX
)
2739 if (forced_x
!= NO_EXACTNESS
)
2744 if (forced_x
!= NO_EXACTNESS
)
2749 if (radix
!= NO_RADIX
)
2754 if (radix
!= NO_RADIX
)
2764 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2765 if (radix
== NO_RADIX
)
2766 result
= mem2complex (mem
, len
, idx
, default_radix
, &implicit_x
);
2768 result
= mem2complex (mem
, len
, idx
, (unsigned int) radix
, &implicit_x
);
2770 if (SCM_FALSEP (result
))
2776 if (SCM_INEXACTP (result
))
2777 /* FIXME: This may change the value. */
2778 return scm_inexact_to_exact (result
);
2782 if (SCM_INEXACTP (result
))
2785 return scm_exact_to_inexact (result
);
2788 if (implicit_x
== INEXACT
)
2790 if (SCM_INEXACTP (result
))
2793 return scm_exact_to_inexact (result
);
2801 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2802 (SCM string
, SCM radix
),
2803 "Return a number of the maximally precise representation\n"
2804 "expressed by the given @var{string}. @var{radix} must be an\n"
2805 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2806 "is a default radix that may be overridden by an explicit radix\n"
2807 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2808 "supplied, then the default radix is 10. If string is not a\n"
2809 "syntactically valid notation for a number, then\n"
2810 "@code{string->number} returns @code{#f}.")
2811 #define FUNC_NAME s_scm_string_to_number
2815 SCM_VALIDATE_STRING (1, string
);
2816 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2817 answer
= scm_i_mem2number (SCM_STRING_CHARS (string
),
2818 SCM_STRING_LENGTH (string
),
2820 return scm_return_first (answer
, string
);
2825 /*** END strs->nums ***/
2829 scm_make_real (double x
)
2833 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
2834 SCM_REAL_VALUE (z
) = x
;
2840 scm_make_complex (double x
, double y
)
2843 return scm_make_real (x
);
2846 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_must_malloc (2L * sizeof (double), "complex"));
2847 SCM_COMPLEX_REAL (z
) = x
;
2848 SCM_COMPLEX_IMAG (z
) = y
;
2855 scm_bigequal (SCM x
, SCM y
)
2858 if (0 == scm_bigcomp (x
, y
))
2865 scm_real_equalp (SCM x
, SCM y
)
2867 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2871 scm_complex_equalp (SCM x
, SCM y
)
2873 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2874 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2879 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2880 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2881 * "else. Note that the sets of complex, real, rational and\n"
2882 * "integer values form subsets of the set of numbers, i. e. the\n"
2883 * "predicate will be fulfilled for any number."
2885 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2887 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2888 "else. Note that the sets of real, rational and integer\n"
2889 "values form subsets of the set of complex numbers, i. e. the\n"
2890 "predicate will also be fulfilled if @var{x} is a real,\n"
2891 "rational or integer number.")
2892 #define FUNC_NAME s_scm_number_p
2894 return SCM_BOOL (SCM_NUMBERP (x
));
2899 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2900 /* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
2901 * "Note that the sets of integer and rational values form a subset\n"
2902 * "of the set of real numbers, i. e. the predicate will also\n"
2903 * "be fulfilled if @var{x} is an integer or a rational number."
2905 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2907 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
2908 "else. Note that the set of integer values forms a subset of\n"
2909 "the set of rational numbers, i. e. the predicate will also be\n"
2910 "fulfilled if @var{x} is an integer number. Real numbers\n"
2911 "will also satisfy this predicate, because of their limited\n"
2913 #define FUNC_NAME s_scm_real_p
2915 if (SCM_INUMP (x
)) {
2917 } else if (SCM_IMP (x
)) {
2919 } else if (SCM_REALP (x
)) {
2921 } else if (SCM_BIGP (x
)) {
2930 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2932 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2934 #define FUNC_NAME s_scm_integer_p
2943 if (!SCM_INEXACTP (x
))
2945 if (SCM_COMPLEXP (x
))
2947 r
= SCM_REAL_VALUE (x
);
2955 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
2957 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
2959 #define FUNC_NAME s_scm_inexact_p
2961 return SCM_BOOL (SCM_INEXACTP (x
));
2966 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
2967 /* "Return @code{#t} if all parameters are numerically equal." */
2969 scm_num_eq_p (SCM x
, SCM y
)
2971 if (SCM_INUMP (x
)) {
2972 long xx
= SCM_INUM (x
);
2973 if (SCM_INUMP (y
)) {
2974 long yy
= SCM_INUM (y
);
2975 return SCM_BOOL (xx
== yy
);
2976 } else if (SCM_BIGP (y
)) {
2978 } else if (SCM_REALP (y
)) {
2979 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
2980 } else if (SCM_COMPLEXP (y
)) {
2981 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
2982 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2984 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2986 } else if (SCM_BIGP (x
)) {
2987 if (SCM_INUMP (y
)) {
2989 } else if (SCM_BIGP (y
)) {
2990 return SCM_BOOL (0 == scm_bigcomp (x
, y
));
2991 } else if (SCM_REALP (y
)) {
2992 return SCM_BOOL (scm_i_big2dbl (x
) == SCM_REAL_VALUE (y
));
2993 } else if (SCM_COMPLEXP (y
)) {
2994 return SCM_BOOL ((scm_i_big2dbl (x
) == SCM_COMPLEX_REAL (y
))
2995 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2997 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2999 } else if (SCM_REALP (x
)) {
3000 if (SCM_INUMP (y
)) {
3001 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3002 } else if (SCM_BIGP (y
)) {
3003 return SCM_BOOL (SCM_REAL_VALUE (x
) == scm_i_big2dbl (y
));
3004 } else if (SCM_REALP (y
)) {
3005 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3006 } else if (SCM_COMPLEXP (y
)) {
3007 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3008 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3010 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3012 } else if (SCM_COMPLEXP (x
)) {
3013 if (SCM_INUMP (y
)) {
3014 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3015 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3016 } else if (SCM_BIGP (y
)) {
3017 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == scm_i_big2dbl (y
))
3018 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3019 } else if (SCM_REALP (y
)) {
3020 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3021 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3022 } else if (SCM_COMPLEXP (y
)) {
3023 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3024 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3026 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3029 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3034 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3035 /* "Return @code{#t} if the list of parameters is monotonically\n"
3039 scm_less_p (SCM x
, SCM y
)
3041 if (SCM_INUMP (x
)) {
3042 long xx
= SCM_INUM (x
);
3043 if (SCM_INUMP (y
)) {
3044 long yy
= SCM_INUM (y
);
3045 return SCM_BOOL (xx
< yy
);
3046 } else if (SCM_BIGP (y
)) {
3047 return SCM_BOOL (!SCM_BIGSIGN (y
));
3048 } else if (SCM_REALP (y
)) {
3049 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3051 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3053 } else if (SCM_BIGP (x
)) {
3054 if (SCM_INUMP (y
)) {
3055 return SCM_BOOL (SCM_BIGSIGN (x
));
3056 } else if (SCM_BIGP (y
)) {
3057 return SCM_BOOL (1 == scm_bigcomp (x
, y
));
3058 } else if (SCM_REALP (y
)) {
3059 return SCM_BOOL (scm_i_big2dbl (x
) < SCM_REAL_VALUE (y
));
3061 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3063 } else if (SCM_REALP (x
)) {
3064 if (SCM_INUMP (y
)) {
3065 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3066 } else if (SCM_BIGP (y
)) {
3067 return SCM_BOOL (SCM_REAL_VALUE (x
) < scm_i_big2dbl (y
));
3068 } else if (SCM_REALP (y
)) {
3069 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3071 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3074 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3079 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3080 /* "Return @code{#t} if the list of parameters is monotonically\n"
3083 #define FUNC_NAME s_scm_gr_p
3085 scm_gr_p (SCM x
, SCM y
)
3087 if (!SCM_NUMBERP (x
))
3088 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3089 else if (!SCM_NUMBERP (y
))
3090 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3092 return scm_less_p (y
, x
);
3097 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3098 /* "Return @code{#t} if the list of parameters is monotonically\n"
3101 #define FUNC_NAME s_scm_leq_p
3103 scm_leq_p (SCM x
, SCM y
)
3105 if (!SCM_NUMBERP (x
))
3106 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3107 else if (!SCM_NUMBERP (y
))
3108 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3110 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3115 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3116 /* "Return @code{#t} if the list of parameters is monotonically\n"
3119 #define FUNC_NAME s_scm_geq_p
3121 scm_geq_p (SCM x
, SCM y
)
3123 if (!SCM_NUMBERP (x
))
3124 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3125 else if (!SCM_NUMBERP (y
))
3126 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3128 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3133 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3134 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3140 if (SCM_INUMP (z
)) {
3141 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3142 } else if (SCM_BIGP (z
)) {
3144 } else if (SCM_REALP (z
)) {
3145 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3146 } else if (SCM_COMPLEXP (z
)) {
3147 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3148 && SCM_COMPLEX_IMAG (z
) == 0.0);
3150 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3155 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3156 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3160 scm_positive_p (SCM x
)
3162 if (SCM_INUMP (x
)) {
3163 return SCM_BOOL (SCM_INUM (x
) > 0);
3164 } else if (SCM_BIGP (x
)) {
3165 return SCM_BOOL (!SCM_BIGSIGN (x
));
3166 } else if (SCM_REALP (x
)) {
3167 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3169 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3174 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3175 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3179 scm_negative_p (SCM x
)
3181 if (SCM_INUMP (x
)) {
3182 return SCM_BOOL (SCM_INUM (x
) < 0);
3183 } else if (SCM_BIGP (x
)) {
3184 return SCM_BOOL (SCM_BIGSIGN (x
));
3185 } else if (SCM_REALP (x
)) {
3186 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3188 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3193 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3194 /* "Return the maximum of all parameter values."
3197 scm_max (SCM x
, SCM y
)
3199 if (SCM_UNBNDP (y
)) {
3200 if (SCM_UNBNDP (x
)) {
3201 SCM_WTA_DISPATCH_0 (g_max
, s_max
);
3202 } else if (SCM_NUMBERP (x
)) {
3205 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3209 if (SCM_INUMP (x
)) {
3210 long xx
= SCM_INUM (x
);
3211 if (SCM_INUMP (y
)) {
3212 long yy
= SCM_INUM (y
);
3213 return (xx
< yy
) ? y
: x
;
3214 } else if (SCM_BIGP (y
)) {
3215 return SCM_BIGSIGN (y
) ? x
: y
;
3216 } else if (SCM_REALP (y
)) {
3218 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3220 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3222 } else if (SCM_BIGP (x
)) {
3223 if (SCM_INUMP (y
)) {
3224 return SCM_BIGSIGN (x
) ? y
: x
;
3225 } else if (SCM_BIGP (y
)) {
3226 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3227 } else if (SCM_REALP (y
)) {
3228 double z
= scm_i_big2dbl (x
);
3229 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3231 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3233 } else if (SCM_REALP (x
)) {
3234 if (SCM_INUMP (y
)) {
3235 double z
= SCM_INUM (y
);
3236 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3237 } else if (SCM_BIGP (y
)) {
3238 double z
= scm_i_big2dbl (y
);
3239 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3240 } else if (SCM_REALP (y
)) {
3241 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? y
: x
;
3243 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3246 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3251 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3252 /* "Return the minium of all parameter values."
3255 scm_min (SCM x
, SCM y
)
3257 if (SCM_UNBNDP (y
)) {
3258 if (SCM_UNBNDP (x
)) {
3259 SCM_WTA_DISPATCH_0 (g_min
, s_min
);
3260 } else if (SCM_NUMBERP (x
)) {
3263 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3267 if (SCM_INUMP (x
)) {
3268 long xx
= SCM_INUM (x
);
3269 if (SCM_INUMP (y
)) {
3270 long yy
= SCM_INUM (y
);
3271 return (xx
< yy
) ? x
: y
;
3272 } else if (SCM_BIGP (y
)) {
3273 return SCM_BIGSIGN (y
) ? y
: x
;
3274 } else if (SCM_REALP (y
)) {
3276 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3278 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3280 } else if (SCM_BIGP (x
)) {
3281 if (SCM_INUMP (y
)) {
3282 return SCM_BIGSIGN (x
) ? x
: y
;
3283 } else if (SCM_BIGP (y
)) {
3284 return (-1 == scm_bigcomp (x
, y
)) ? y
: x
;
3285 } else if (SCM_REALP (y
)) {
3286 double z
= scm_i_big2dbl (x
);
3287 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3289 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3291 } else if (SCM_REALP (x
)) {
3292 if (SCM_INUMP (y
)) {
3293 double z
= SCM_INUM (y
);
3294 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3295 } else if (SCM_BIGP (y
)) {
3296 double z
= scm_i_big2dbl (y
);
3297 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3298 } else if (SCM_REALP (y
)) {
3299 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? x
: y
;
3301 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3304 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3309 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3310 /* "Return the sum of all parameter values. Return 0 if called without\n"
3314 scm_sum (SCM x
, SCM y
)
3316 if (SCM_UNBNDP (y
)) {
3317 if (SCM_UNBNDP (x
)) {
3319 } else if (SCM_NUMBERP (x
)) {
3322 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3326 if (SCM_INUMP (x
)) {
3327 long int xx
= SCM_INUM (x
);
3328 if (SCM_INUMP (y
)) {
3329 long int yy
= SCM_INUM (y
);
3330 long int z
= xx
+ yy
;
3331 if (SCM_FIXABLE (z
)) {
3332 return SCM_MAKINUM (z
);
3335 return scm_i_long2big (z
);
3336 #else /* SCM_BIGDIG */
3337 return scm_make_real ((double) z
);
3338 #endif /* SCM_BIGDIG */
3340 } else if (SCM_BIGP (y
)) {
3343 long int xx
= SCM_INUM (x
);
3344 #ifndef SCM_DIGSTOOBIG
3345 long z
= scm_pseudolong (xx
);
3346 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3347 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3348 #else /* SCM_DIGSTOOBIG */
3349 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3350 scm_longdigs (xx
, zdigs
);
3351 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3352 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3353 #endif /* SCM_DIGSTOOBIG */
3355 } else if (SCM_REALP (y
)) {
3356 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3357 } else if (SCM_COMPLEXP (y
)) {
3358 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3359 SCM_COMPLEX_IMAG (y
));
3361 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3363 } else if (SCM_BIGP (x
)) {
3364 if (SCM_INUMP (y
)) {
3367 } else if (SCM_BIGP (y
)) {
3368 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
)) {
3371 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3372 SCM_BIGSIGN (x
), y
, 0);
3373 } else if (SCM_REALP (y
)) {
3374 return scm_make_real (scm_i_big2dbl (x
) + SCM_REAL_VALUE (y
));
3375 } else if (SCM_COMPLEXP (y
)) {
3376 return scm_make_complex (scm_i_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3377 SCM_COMPLEX_IMAG (y
));
3379 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3381 } else if (SCM_REALP (x
)) {
3382 if (SCM_INUMP (y
)) {
3383 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3384 } else if (SCM_BIGP (y
)) {
3385 return scm_make_real (SCM_REAL_VALUE (x
) + scm_i_big2dbl (y
));
3386 } else if (SCM_REALP (y
)) {
3387 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3388 } else if (SCM_COMPLEXP (y
)) {
3389 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3390 SCM_COMPLEX_IMAG (y
));
3392 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3394 } else if (SCM_COMPLEXP (x
)) {
3395 if (SCM_INUMP (y
)) {
3396 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3397 SCM_COMPLEX_IMAG (x
));
3398 } else if (SCM_BIGP (y
)) {
3399 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_i_big2dbl (y
),
3400 SCM_COMPLEX_IMAG (x
));
3401 } else if (SCM_REALP (y
)) {
3402 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3403 SCM_COMPLEX_IMAG (x
));
3404 } else if (SCM_COMPLEXP (y
)) {
3405 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3406 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3408 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3411 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3416 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3417 /* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3418 * the sum of all but the first argument are subtracted from the first
3420 #define FUNC_NAME s_difference
3422 scm_difference (SCM x
, SCM y
)
3424 if (SCM_UNBNDP (y
)) {
3425 if (SCM_UNBNDP (x
)) {
3426 SCM_WTA_DISPATCH_0 (g_difference
, s_difference
);
3427 } else if (SCM_INUMP (x
)) {
3428 long xx
= -SCM_INUM (x
);
3429 if (SCM_FIXABLE (xx
)) {
3430 return SCM_MAKINUM (xx
);
3433 return scm_i_long2big (xx
);
3435 return scm_make_real ((double) xx
);
3438 } else if (SCM_BIGP (x
)) {
3439 SCM z
= scm_i_copybig (x
, !SCM_BIGSIGN (x
));
3440 unsigned int digs
= SCM_NUMDIGS (z
);
3441 unsigned int size
= digs
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
;
3442 return size
<= sizeof (SCM
) ? scm_i_big2inum (z
, digs
) : z
;
3443 } else if (SCM_REALP (x
)) {
3444 return scm_make_real (-SCM_REAL_VALUE (x
));
3445 } else if (SCM_COMPLEXP (x
)) {
3446 return scm_make_complex (-SCM_COMPLEX_REAL (x
), -SCM_COMPLEX_IMAG (x
));
3448 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3452 if (SCM_INUMP (x
)) {
3453 long int xx
= SCM_INUM (x
);
3454 if (SCM_INUMP (y
)) {
3455 long int yy
= SCM_INUM (y
);
3456 long int z
= xx
- yy
;
3457 if (SCM_FIXABLE (z
)) {
3458 return SCM_MAKINUM (z
);
3461 return scm_i_long2big (z
);
3463 return scm_make_real ((double) z
);
3466 } else if (SCM_BIGP (y
)) {
3467 #ifndef SCM_DIGSTOOBIG
3468 long z
= scm_pseudolong (xx
);
3469 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3470 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3472 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3473 scm_longdigs (xx
, zdigs
);
3474 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3475 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3477 } else if (SCM_REALP (y
)) {
3478 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
3479 } else if (SCM_COMPLEXP (y
)) {
3480 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
3481 -SCM_COMPLEX_IMAG (y
));
3483 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3485 } else if (SCM_BIGP (x
)) {
3486 if (SCM_INUMP (y
)) {
3487 long int yy
= SCM_INUM (y
);
3488 #ifndef SCM_DIGSTOOBIG
3489 long z
= scm_pseudolong (yy
);
3490 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3491 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3493 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3494 scm_longdigs (yy
, zdigs
);
3495 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3496 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3498 } else if (SCM_BIGP (y
)) {
3499 return (SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3500 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3501 SCM_BIGSIGN (x
), y
, SCM_BIGSIGNFLAG
)
3502 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3503 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
, x
, 0);
3504 } else if (SCM_REALP (y
)) {
3505 return scm_make_real (scm_i_big2dbl (x
) - SCM_REAL_VALUE (y
));
3506 } else if (SCM_COMPLEXP (y
)) {
3507 return scm_make_complex (scm_i_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3508 - SCM_COMPLEX_IMAG (y
));
3510 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3512 } else if (SCM_REALP (x
)) {
3513 if (SCM_INUMP (y
)) {
3514 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
3515 } else if (SCM_BIGP (y
)) {
3516 return scm_make_real (SCM_REAL_VALUE (x
) - scm_i_big2dbl (y
));
3517 } else if (SCM_REALP (y
)) {
3518 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3519 } else if (SCM_COMPLEXP (y
)) {
3520 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3521 -SCM_COMPLEX_IMAG (y
));
3523 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3525 } else if (SCM_COMPLEXP (x
)) {
3526 if (SCM_INUMP (y
)) {
3527 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
3528 SCM_COMPLEX_IMAG (x
));
3529 } else if (SCM_BIGP (y
)) {
3530 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_i_big2dbl (y
),
3531 SCM_COMPLEX_IMAG (x
));
3532 } else if (SCM_REALP (y
)) {
3533 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3534 SCM_COMPLEX_IMAG (x
));
3535 } else if (SCM_COMPLEXP (y
)) {
3536 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3537 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3539 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3542 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3547 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3548 /* "Return the product of all arguments. If called without arguments,\n"
3552 scm_product (SCM x
, SCM y
)
3554 if (SCM_UNBNDP (y
)) {
3555 if (SCM_UNBNDP (x
)) {
3556 return SCM_MAKINUM (1L);
3557 } else if (SCM_NUMBERP (x
)) {
3560 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3564 if (SCM_INUMP (x
)) {
3572 } else if (xx
== 1) {
3576 if (SCM_INUMP (y
)) {
3577 long yy
= SCM_INUM (y
);
3579 SCM k
= SCM_MAKINUM (kk
);
3580 if (kk
!= SCM_INUM (k
) || kk
/ xx
!= yy
) {
3582 int sgn
= (xx
< 0) ^ (yy
< 0);
3583 #ifndef SCM_DIGSTOOBIG
3584 long i
= scm_pseudolong (xx
);
3585 long j
= scm_pseudolong (yy
);
3586 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3587 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3588 #else /* SCM_DIGSTOOBIG */
3589 SCM_BIGDIG xdigs
[SCM_DIGSPERLONG
];
3590 SCM_BIGDIG ydigs
[SCM_DIGSPERLONG
];
3591 scm_longdigs (xx
, xdigs
);
3592 scm_longdigs (yy
, ydigs
);
3593 return scm_mulbig (xdigs
, SCM_DIGSPERLONG
,
3594 ydigs
, SCM_DIGSPERLONG
,
3598 return scm_make_real (((double) xx
) * ((double) yy
));
3603 } else if (SCM_BIGP (y
)) {
3604 #ifndef SCM_DIGSTOOBIG
3605 long z
= scm_pseudolong (xx
);
3606 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3607 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3608 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3610 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3611 scm_longdigs (xx
, zdigs
);
3612 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3613 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3614 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3616 } else if (SCM_REALP (y
)) {
3617 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3618 } else if (SCM_COMPLEXP (y
)) {
3619 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3620 xx
* SCM_COMPLEX_IMAG (y
));
3622 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3624 } else if (SCM_BIGP (x
)) {
3625 if (SCM_INUMP (y
)) {
3628 } else if (SCM_BIGP (y
)) {
3629 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3630 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3631 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3632 } else if (SCM_REALP (y
)) {
3633 return scm_make_real (scm_i_big2dbl (x
) * SCM_REAL_VALUE (y
));
3634 } else if (SCM_COMPLEXP (y
)) {
3635 double z
= scm_i_big2dbl (x
);
3636 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3637 z
* SCM_COMPLEX_IMAG (y
));
3639 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3641 } else if (SCM_REALP (x
)) {
3642 if (SCM_INUMP (y
)) {
3643 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3644 } else if (SCM_BIGP (y
)) {
3645 return scm_make_real (scm_i_big2dbl (y
) * SCM_REAL_VALUE (x
));
3646 } else if (SCM_REALP (y
)) {
3647 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
3648 } else if (SCM_COMPLEXP (y
)) {
3649 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
3650 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3652 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3654 } else if (SCM_COMPLEXP (x
)) {
3655 if (SCM_INUMP (y
)) {
3656 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3657 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3658 } else if (SCM_BIGP (y
)) {
3659 double z
= scm_i_big2dbl (y
);
3660 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
3661 z
* SCM_COMPLEX_IMAG (x
));
3662 } else if (SCM_REALP (y
)) {
3663 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3664 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
3665 } else if (SCM_COMPLEXP (y
)) {
3666 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
3667 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
3668 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3669 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3671 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3674 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3680 scm_num2dbl (SCM a
, const char *why
)
3681 #define FUNC_NAME why
3683 if (SCM_INUMP (a
)) {
3684 return (double) SCM_INUM (a
);
3685 } else if (SCM_BIGP (a
)) {
3686 return scm_i_big2dbl (a
);
3687 } else if (SCM_REALP (a
)) {
3688 return (SCM_REAL_VALUE (a
));
3690 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3696 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3697 /* Divide the first argument by the product of the remaining
3698 arguments. If called with one argument @var{z1}, 1/@var{z1} is
3700 #define FUNC_NAME s_divide
3702 scm_divide (SCM x
, SCM y
)
3706 if (SCM_UNBNDP (y
)) {
3707 if (SCM_UNBNDP (x
)) {
3708 SCM_WTA_DISPATCH_0 (g_divide
, s_divide
);
3709 } else if (SCM_INUMP (x
)) {
3710 if (SCM_EQ_P (x
, SCM_MAKINUM (1L)) || SCM_EQ_P (x
, SCM_MAKINUM (-1L))) {
3713 return scm_make_real (1.0 / (double) SCM_INUM (x
));
3715 } else if (SCM_BIGP (x
)) {
3716 return scm_make_real (1.0 / scm_i_big2dbl (x
));
3717 } else if (SCM_REALP (x
)) {
3718 return scm_make_real (1.0 / SCM_REAL_VALUE (x
));
3719 } else if (SCM_COMPLEXP (x
)) {
3720 double r
= SCM_COMPLEX_REAL (x
);
3721 double i
= SCM_COMPLEX_IMAG (x
);
3722 double d
= r
* r
+ i
* i
;
3723 return scm_make_complex (r
/ d
, -i
/ d
);
3725 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3729 if (SCM_INUMP (x
)) {
3730 long xx
= SCM_INUM (x
);
3731 if (SCM_INUMP (y
)) {
3732 long yy
= SCM_INUM (y
);
3734 scm_num_overflow (s_divide
);
3735 } else if (xx
% yy
!= 0) {
3736 return scm_make_real ((double) xx
/ (double) yy
);
3739 if (SCM_FIXABLE (z
)) {
3740 return SCM_MAKINUM (z
);
3743 return scm_i_long2big (z
);
3745 return scm_make_real ((double) xx
/ (double) yy
);
3749 } else if (SCM_BIGP (y
)) {
3750 return scm_make_real ((double) xx
/ scm_i_big2dbl (y
));
3751 } else if (SCM_REALP (y
)) {
3752 return scm_make_real ((double) xx
/ SCM_REAL_VALUE (y
));
3753 } else if (SCM_COMPLEXP (y
)) {
3755 complex_div
: /* y _must_ be a complex number */
3757 double r
= SCM_COMPLEX_REAL (y
);
3758 double i
= SCM_COMPLEX_IMAG (y
);
3759 double d
= r
* r
+ i
* i
;
3760 return scm_make_complex ((a
* r
) / d
, (-a
* i
) / d
);
3763 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3765 } else if (SCM_BIGP (x
)) {
3766 if (SCM_INUMP (y
)) {
3767 long int yy
= SCM_INUM (y
);
3769 scm_num_overflow (s_divide
);
3770 } else if (yy
== 1) {
3773 long z
= yy
< 0 ? -yy
: yy
;
3774 if (z
< SCM_BIGRAD
) {
3775 SCM w
= scm_i_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
3776 return scm_divbigdig (SCM_BDIGITS (w
), SCM_NUMDIGS (w
),
3778 ? scm_make_real (scm_i_big2dbl (x
) / (double) yy
)
3779 : scm_i_normbig (w
);
3782 #ifndef SCM_DIGSTOOBIG
3783 z
= scm_pseudolong (z
);
3784 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3785 (SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3786 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3788 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3789 scm_longdigs (z
, zdigs
);
3790 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3791 zdigs
, SCM_DIGSPERLONG
,
3792 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3794 return (!SCM_UNBNDP (w
))
3796 : scm_make_real (scm_i_big2dbl (x
) / (double) yy
);
3799 } else if (SCM_BIGP (y
)) {
3800 SCM w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3801 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3802 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 3);
3803 return (!SCM_UNBNDP (w
))
3805 : scm_make_real (scm_i_big2dbl (x
) / scm_i_big2dbl (y
));
3806 } else if (SCM_REALP (y
)) {
3807 return scm_make_real (scm_i_big2dbl (x
) / SCM_REAL_VALUE (y
));
3808 } else if (SCM_COMPLEXP (y
)) {
3809 a
= scm_i_big2dbl (x
);
3812 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3814 } else if (SCM_REALP (x
)) {
3815 double rx
= SCM_REAL_VALUE (x
);
3816 if (SCM_INUMP (y
)) {
3817 return scm_make_real (rx
/ (double) SCM_INUM (y
));
3818 } else if (SCM_BIGP (y
)) {
3819 return scm_make_real (rx
/ scm_i_big2dbl (y
));
3820 } else if (SCM_REALP (y
)) {
3821 return scm_make_real (rx
/ SCM_REAL_VALUE (y
));
3822 } else if (SCM_COMPLEXP (y
)) {
3826 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3828 } else if (SCM_COMPLEXP (x
)) {
3829 double rx
= SCM_COMPLEX_REAL (x
);
3830 double ix
= SCM_COMPLEX_IMAG (x
);
3831 if (SCM_INUMP (y
)) {
3832 double d
= SCM_INUM (y
);
3833 return scm_make_complex (rx
/ d
, ix
/ d
);
3834 } else if (SCM_BIGP (y
)) {
3835 double d
= scm_i_big2dbl (y
);
3836 return scm_make_complex (rx
/ d
, ix
/ d
);
3837 } else if (SCM_REALP (y
)) {
3838 double d
= SCM_REAL_VALUE (y
);
3839 return scm_make_complex (rx
/ d
, ix
/ d
);
3840 } else if (SCM_COMPLEXP (y
)) {
3841 double ry
= SCM_COMPLEX_REAL (y
);
3842 double iy
= SCM_COMPLEX_IMAG (y
);
3843 double d
= ry
* ry
+ iy
* iy
;
3844 return scm_make_complex ((rx
* ry
+ ix
* iy
) / d
,
3845 (ix
* ry
- rx
* iy
) / d
);
3847 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3850 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
3855 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
3856 /* "Return the inverse hyperbolic sine of @var{x}."
3859 scm_asinh (double x
)
3861 return log (x
+ sqrt (x
* x
+ 1));
3867 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
3868 /* "Return the inverse hyperbolic cosine of @var{x}."
3871 scm_acosh (double x
)
3873 return log (x
+ sqrt (x
* x
- 1));
3879 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
3880 /* "Return the inverse hyperbolic tangent of @var{x}."
3883 scm_atanh (double x
)
3885 return 0.5 * log ((1 + x
) / (1 - x
));
3891 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
3892 /* "Round the inexact number @var{x} towards zero."
3895 scm_truncate (double x
)
3904 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
3905 /* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
3906 * "numbers, round towards even."
3909 scm_round (double x
)
3911 double plus_half
= x
+ 0.5;
3912 double result
= floor (plus_half
);
3913 /* Adjust so that the scm_round is towards even. */
3914 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
3915 ? result
- 1 : result
;
3919 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
3920 /* "Round the number @var{x} towards minus infinity."
3922 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
3923 /* "Round the number @var{x} towards infinity."
3925 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
3926 /* "Return the square root of the real number @var{x}."
3928 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
3929 /* "Return the absolute value of the real number @var{x}."
3931 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
3932 /* "Return the @var{x}th power of e."
3934 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
3935 /* "Return the natural logarithm of the real number @var{x}."
3937 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
3938 /* "Return the sine of the real number @var{x}."
3940 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
3941 /* "Return the cosine of the real number @var{x}."
3943 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
3944 /* "Return the tangent of the real number @var{x}."
3946 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
3947 /* "Return the arc sine of the real number @var{x}."
3949 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
3950 /* "Return the arc cosine of the real number @var{x}."
3952 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
3953 /* "Return the arc tangent of the real number @var{x}."
3955 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
3956 /* "Return the hyperbolic sine of the real number @var{x}."
3958 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
3959 /* "Return the hyperbolic cosine of the real number @var{x}."
3961 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
3962 /* "Return the hyperbolic tangent of the real number @var{x}."
3970 static void scm_two_doubles (SCM x
,
3972 const char *sstring
,
3976 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
3978 if (SCM_INUMP (x
)) {
3979 xy
->x
= SCM_INUM (x
);
3980 } else if (SCM_BIGP (x
)) {
3981 xy
->x
= scm_i_big2dbl (x
);
3982 } else if (SCM_REALP (x
)) {
3983 xy
->x
= SCM_REAL_VALUE (x
);
3985 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
3988 if (SCM_INUMP (y
)) {
3989 xy
->y
= SCM_INUM (y
);
3990 } else if (SCM_BIGP (y
)) {
3991 xy
->y
= scm_i_big2dbl (y
);
3992 } else if (SCM_REALP (y
)) {
3993 xy
->y
= SCM_REAL_VALUE (y
);
3995 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
4000 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
4002 "Return @var{x} raised to the power of @var{y}. This\n"
4003 "procedure does not accept complex arguments.")
4004 #define FUNC_NAME s_scm_sys_expt
4007 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4008 return scm_make_real (pow (xy
.x
, xy
.y
));
4013 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4015 "Return the arc tangent of the two arguments @var{x} and\n"
4016 "@var{y}. This is similar to calculating the arc tangent of\n"
4017 "@var{x} / @var{y}, except that the signs of both arguments\n"
4018 "are used to determine the quadrant of the result. This\n"
4019 "procedure does not accept complex arguments.")
4020 #define FUNC_NAME s_scm_sys_atan2
4023 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4024 return scm_make_real (atan2 (xy
.x
, xy
.y
));
4029 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4030 (SCM real
, SCM imaginary
),
4031 "Return a complex number constructed of the given @var{real} and\n"
4032 "@var{imaginary} parts.")
4033 #define FUNC_NAME s_scm_make_rectangular
4036 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
4037 return scm_make_complex (xy
.x
, xy
.y
);
4043 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4045 "Return the complex number @var{x} * e^(i * @var{y}).")
4046 #define FUNC_NAME s_scm_make_polar
4049 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4050 return scm_make_complex (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
4055 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4056 /* "Return the real part of the number @var{z}."
4059 scm_real_part (SCM z
)
4061 if (SCM_INUMP (z
)) {
4063 } else if (SCM_BIGP (z
)) {
4065 } else if (SCM_REALP (z
)) {
4067 } else if (SCM_COMPLEXP (z
)) {
4068 return scm_make_real (SCM_COMPLEX_REAL (z
));
4070 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4075 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4076 /* "Return the imaginary part of the number @var{z}."
4079 scm_imag_part (SCM z
)
4081 if (SCM_INUMP (z
)) {
4083 } else if (SCM_BIGP (z
)) {
4085 } else if (SCM_REALP (z
)) {
4087 } else if (SCM_COMPLEXP (z
)) {
4088 return scm_make_real (SCM_COMPLEX_IMAG (z
));
4090 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4095 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4096 /* "Return the magnitude of the number @var{z}. This is the same as\n"
4097 * "@code{abs} for real arguments, but also allows complex numbers."
4100 scm_magnitude (SCM z
)
4102 if (SCM_INUMP (z
)) {
4103 long int zz
= SCM_INUM (z
);
4106 } else if (SCM_POSFIXABLE (-zz
)) {
4107 return SCM_MAKINUM (-zz
);
4110 return scm_i_long2big (-zz
);
4112 scm_num_overflow (s_magnitude
);
4115 } else if (SCM_BIGP (z
)) {
4116 if (!SCM_BIGSIGN (z
)) {
4119 return scm_i_copybig (z
, 0);
4121 } else if (SCM_REALP (z
)) {
4122 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
4123 } else if (SCM_COMPLEXP (z
)) {
4124 double r
= SCM_COMPLEX_REAL (z
);
4125 double i
= SCM_COMPLEX_IMAG (z
);
4126 return scm_make_real (sqrt (i
* i
+ r
* r
));
4128 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4133 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
4134 /* "Return the angle of the complex number @var{z}."
4139 if (SCM_INUMP (z
)) {
4140 if (SCM_INUM (z
) >= 0) {
4141 return scm_make_real (atan2 (0.0, 1.0));
4143 return scm_make_real (atan2 (0.0, -1.0));
4145 } else if (SCM_BIGP (z
)) {
4146 if (SCM_BIGSIGN (z
)) {
4147 return scm_make_real (atan2 (0.0, -1.0));
4149 return scm_make_real (atan2 (0.0, 1.0));
4151 } else if (SCM_REALP (z
)) {
4152 return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z
)));
4153 } else if (SCM_COMPLEXP (z
)) {
4154 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
4156 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
4161 SCM_GPROC (s_exact_to_inexact
, "exact->inexact", 1, 0, 0, scm_exact_to_inexact
, g_exact_to_inexact
);
4162 /* Convert the number @var{x} to its inexact representation.\n"
4165 scm_exact_to_inexact (SCM z
)
4168 return scm_make_real ((double) SCM_INUM (z
));
4169 else if (SCM_BIGP (z
))
4170 return scm_make_real (scm_i_big2dbl (z
));
4171 else if (SCM_INEXACTP (z
))
4174 SCM_WTA_DISPATCH_1 (g_exact_to_inexact
, z
, 1, s_exact_to_inexact
);
4178 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4180 "Return an exact number that is numerically closest to @var{z}.")
4181 #define FUNC_NAME s_scm_inexact_to_exact
4183 if (SCM_INUMP (z
)) {
4185 } else if (SCM_BIGP (z
)) {
4187 } else if (SCM_REALP (z
)) {
4188 double u
= floor (SCM_REAL_VALUE (z
) + 0.5);
4190 if (SCM_FIXABLE (lu
)) {
4191 return SCM_MAKINUM (lu
);
4193 } else if (isfinite (u
)) {
4194 return scm_i_dbl2big (u
);
4197 scm_num_overflow (s_scm_inexact_to_exact
);
4200 SCM_WRONG_TYPE_ARG (1, z
);
4207 /* d must be integer */
4210 scm_i_dbl2big (double d
)
4216 double u
= (d
< 0) ? -d
: d
;
4217 while (0 != floor (u
))
4222 ans
= scm_i_mkbig (i
, d
< 0);
4223 digits
= SCM_BDIGITS (ans
);
4231 #ifndef SCM_RECKLESS
4233 scm_num_overflow ("dbl2big");
4239 scm_i_big2dbl (SCM b
)
4242 size_t i
= SCM_NUMDIGS (b
);
4243 SCM_BIGDIG
*digits
= SCM_BDIGITS (b
);
4245 ans
= digits
[i
] + SCM_BIGRAD
* ans
;
4246 if (SCM_BIGSIGN (b
))
4253 #ifdef HAVE_LONG_LONGS
4255 # define ULLONG_MAX ((unsigned long long) (-1))
4256 # define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
4257 # define LLONG_MIN (~LLONG_MAX)
4262 #define SIZE_MAX ((size_t) (-1))
4266 /* the below is not really guaranteed to work (I think), but probably does: */
4267 #define PTRDIFF_MIN ((ptrdiff_t) ((ptrdiff_t)1 << (sizeof (ptrdiff_t)*8 - 1)))
4268 /* this prevents num2integral.c.i from using PTRDIFF_MIN in
4269 preprocessor expressions. */
4270 #define NO_PREPRO_MAGIC
4274 #define PTRDIFF_MAX (~ PTRDIFF_MIN)
4277 #define NUM2INTEGRAL scm_num2short
4278 #define INTEGRAL2NUM scm_short2num
4279 #define INTEGRAL2BIG scm_i_short2big
4281 #define MIN_VALUE SHRT_MIN
4282 #define MAX_VALUE SHRT_MAX
4283 #include "libguile/num2integral.i.c"
4285 #define NUM2INTEGRAL scm_num2ushort
4286 #define INTEGRAL2NUM scm_ushort2num
4287 #define INTEGRAL2BIG scm_i_ushort2big
4289 #define ITYPE unsigned short
4290 #define MAX_VALUE USHRT_MAX
4291 #include "libguile/num2integral.i.c"
4293 #define NUM2INTEGRAL scm_num2int
4294 #define INTEGRAL2NUM scm_int2num
4295 #define INTEGRAL2BIG scm_i_int2big
4297 #define MIN_VALUE INT_MIN
4298 #define MAX_VALUE INT_MAX
4299 #include "libguile/num2integral.i.c"
4301 #define NUM2INTEGRAL scm_num2uint
4302 #define INTEGRAL2NUM scm_uint2num
4303 #define INTEGRAL2BIG scm_i_uint2big
4305 #define ITYPE unsigned int
4306 #define MAX_VALUE UINT_MAX
4307 #include "libguile/num2integral.i.c"
4309 #define NUM2INTEGRAL scm_num2long
4310 #define INTEGRAL2NUM scm_long2num
4311 #define INTEGRAL2BIG scm_i_long2big
4313 #define MIN_VALUE LONG_MIN
4314 #define MAX_VALUE LONG_MAX
4315 #include "libguile/num2integral.i.c"
4317 #define NUM2INTEGRAL scm_num2ulong
4318 #define INTEGRAL2NUM scm_ulong2num
4319 #define INTEGRAL2BIG scm_i_ulong2big
4321 #define ITYPE unsigned long
4322 #define MAX_VALUE ULONG_MAX
4323 #include "libguile/num2integral.i.c"
4325 #define NUM2INTEGRAL scm_num2ptrdiff
4326 #define INTEGRAL2NUM scm_ptrdiff2num
4327 #define INTEGRAL2BIG scm_i_ptrdiff2big
4328 #define ITYPE ptrdiff_t
4329 #define MIN_VALUE PTRDIFF_MIN
4330 #define MAX_VALUE PTRDIFF_MAX
4331 #include "libguile/num2integral.i.c"
4333 #define NUM2INTEGRAL scm_num2size
4334 #define INTEGRAL2NUM scm_size2num
4335 #define INTEGRAL2BIG scm_i_size2big
4337 #define ITYPE size_t
4338 #define MAX_VALUE SIZE_MAX
4339 #include "libguile/num2integral.i.c"
4341 #ifdef HAVE_LONG_LONGS
4343 #ifndef ULONG_LONG_MAX
4344 #define ULONG_LONG_MAX (~0ULL)
4347 #define NUM2INTEGRAL scm_num2long_long
4348 #define INTEGRAL2NUM scm_long_long2num
4349 #define INTEGRAL2BIG scm_i_long_long2big
4350 #define ITYPE long long
4351 #define MIN_VALUE LLONG_MIN
4352 #define MAX_VALUE LLONG_MAX
4353 #define NO_PREPRO_MAGIC
4354 #include "libguile/num2integral.i.c"
4356 #define NUM2INTEGRAL scm_num2ulong_long
4357 #define INTEGRAL2NUM scm_ulong_long2num
4358 #define INTEGRAL2BIG scm_i_ulong_long2big
4360 #define ITYPE unsigned long long
4361 #define MAX_VALUE ULLONG_MAX
4362 #define NO_PREPRO_MAGIC
4363 #include "libguile/num2integral.i.c"
4365 #endif /* HAVE_LONG_LONGS */
4367 #define NUM2FLOAT scm_num2float
4368 #define FLOAT2NUM scm_float2num
4370 #include "libguile/num2float.i.c"
4372 #define NUM2FLOAT scm_num2double
4373 #define FLOAT2NUM scm_double2num
4374 #define FTYPE double
4375 #include "libguile/num2float.i.c"
4379 #define CHECK(type, v) \
4381 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
4400 CHECK (ptrdiff
, -1);
4402 CHECK (short, SHRT_MAX
);
4403 CHECK (short, SHRT_MIN
);
4404 CHECK (ushort
, USHRT_MAX
);
4405 CHECK (int, INT_MAX
);
4406 CHECK (int, INT_MIN
);
4407 CHECK (uint
, UINT_MAX
);
4408 CHECK (long, LONG_MAX
);
4409 CHECK (long, LONG_MIN
);
4410 CHECK (ulong
, ULONG_MAX
);
4411 CHECK (size
, SIZE_MAX
);
4412 CHECK (ptrdiff
, PTRDIFF_MAX
);
4413 CHECK (ptrdiff
, PTRDIFF_MIN
);
4415 #ifdef HAVE_LONG_LONGS
4416 CHECK (long_long
, 0LL);
4417 CHECK (ulong_long
, 0ULL);
4418 CHECK (long_long
, -1LL);
4419 CHECK (long_long
, LLONG_MAX
);
4420 CHECK (long_long
, LLONG_MIN
);
4421 CHECK (ulong_long
, ULLONG_MAX
);
4428 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
4429 if (!SCM_FALSEP (data)) abort();
4432 check_body (void *data
)
4434 SCM num
= *(SCM
*) data
;
4435 scm_num2ulong (num
, 1, NULL
);
4437 return SCM_UNSPECIFIED
;
4441 check_handler (void *data
, SCM tag
, SCM throw_args
)
4443 SCM
*num
= (SCM
*) data
;
4446 return SCM_UNSPECIFIED
;
4449 SCM_DEFINE (scm_sys_check_number_conversions
, "%check-number-conversions", 0, 0, 0,
4451 "Number conversion sanity checking.")
4452 #define FUNC_NAME s_scm_sys_check_number_conversions
4454 SCM data
= SCM_MAKINUM (-1);
4456 data
= scm_int2num (INT_MIN
);
4458 data
= scm_ulong2num (ULONG_MAX
);
4459 data
= scm_difference (SCM_INUM0
, data
);
4461 data
= scm_ulong2num (ULONG_MAX
);
4462 data
= scm_sum (SCM_MAKINUM (1), data
); data
= scm_difference (SCM_INUM0
, data
);
4464 data
= scm_int2num (-10000); data
= scm_product (data
, data
); data
= scm_product (data
, data
);
4467 return SCM_UNSPECIFIED
;
4476 abs_most_negative_fixnum
= scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM
);
4477 scm_permanent_object (abs_most_negative_fixnum
);
4479 /* It may be possible to tune the performance of some algorithms by using
4480 * the following constants to avoid the creation of bignums. Please, before
4481 * using these values, remember the two rules of program optimization:
4482 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
4483 scm_c_define ("most-positive-fixnum",
4484 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
4485 scm_c_define ("most-negative-fixnum",
4486 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
4488 scm_add_feature ("complex");
4489 scm_add_feature ("inexact");
4490 scm_flo0
= scm_make_real (0.0);
4492 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4494 { /* determine floating point precision */
4496 double fsum
= 1.0 + f
;
4497 while (fsum
!= 1.0) {
4498 if (++scm_dblprec
> 20) {
4505 scm_dblprec
= scm_dblprec
- 1;
4507 #endif /* DBL_DIG */
4513 #ifndef SCM_MAGIC_SNARFER
4514 #include "libguile/numbers.x"