1 /* Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
48 #include "libguile/_scm.h"
49 #include "libguile/feature.h"
50 #include "libguile/ports.h"
51 #include "libguile/root.h"
52 #include "libguile/smob.h"
53 #include "libguile/strings.h"
55 #include "libguile/validate.h"
56 #include "libguile/numbers.h"
60 static SCM
scm_divbigbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
);
61 static SCM
scm_divbigint (SCM x
, long z
, int sgn
, int mode
);
64 #define DIGITS '0':case '1':case '2':case '3':case '4':\
65 case '5':case '6':case '7':case '8':case '9'
68 #define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0)
71 #if (SCM_DEBUG_DEPRECATED == 1) /* not defined in header yet? */
73 /* SCM_FLOBUFLEN is the maximum number of characters neccessary for the
74 * printed or scm_string representation of an inexact number.
76 #define SCM_FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
78 #endif /* SCM_DEBUG_DEPRECATED == 1 */
81 /* IS_INF tests its floating point number for infiniteness
82 Dirk:FIXME:: This test does not work if x == 0
85 #define IS_INF(x) ((x) == (x) / 2)
89 /* Return true if X is not infinite and is not a NaN
90 Dirk:FIXME:: Since IS_INF is broken, this test does not work if x == 0
93 #define isfinite(x) (!IS_INF (x) && (x) == (x))
98 static SCM abs_most_negative_fixnum
;
103 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
105 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
107 #define FUNC_NAME s_scm_exact_p
111 } else if (SCM_BIGP (x
)) {
120 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
122 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
124 #define FUNC_NAME s_scm_odd_p
127 return SCM_BOOL ((4 & SCM_UNPACK (n
)) != 0);
128 } else if (SCM_BIGP (n
)) {
129 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) != 0);
131 SCM_WRONG_TYPE_ARG (1, n
);
137 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
139 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
141 #define FUNC_NAME s_scm_even_p
144 return SCM_BOOL ((4 & SCM_UNPACK (n
)) == 0);
145 } else if (SCM_BIGP (n
)) {
146 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) == 0);
148 SCM_WRONG_TYPE_ARG (1, n
);
154 SCM_GPROC (s_abs
, "abs", 1, 0, 0, scm_abs
, g_abs
);
155 /* "Return the absolute value of @var{x}."
161 long int xx
= SCM_INUM (x
);
164 } else if (SCM_POSFIXABLE (-xx
)) {
165 return SCM_MAKINUM (-xx
);
168 return scm_long2big (-xx
);
170 scm_num_overflow (s_abs
);
173 } else if (SCM_BIGP (x
)) {
174 if (!SCM_BIGSIGN (x
)) {
177 return scm_copybig (x
, 0);
179 } else if (SCM_REALP (x
)) {
180 return scm_make_real (fabs (SCM_REAL_VALUE (x
)));
182 SCM_WTA_DISPATCH_1 (g_abs
, x
, 1, s_abs
);
187 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
188 /* "Return the quotient of the numbers @var{x} and @var{y}."
191 scm_quotient (SCM x
, SCM y
)
194 long xx
= SCM_INUM (x
);
196 long yy
= SCM_INUM (y
);
198 scm_num_overflow (s_quotient
);
201 if (SCM_FIXABLE (z
)) {
202 return SCM_MAKINUM (z
);
205 return scm_long2big (z
);
207 scm_num_overflow (s_quotient
);
211 } else if (SCM_BIGP (y
)) {
212 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
213 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
215 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
216 return SCM_MAKINUM (-1);
219 return SCM_MAKINUM (0);
221 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
223 } else if (SCM_BIGP (x
)) {
225 long yy
= SCM_INUM (y
);
227 scm_num_overflow (s_quotient
);
228 } else if (yy
== 1) {
231 long z
= yy
< 0 ? -yy
: yy
;
233 if (z
< SCM_BIGRAD
) {
234 SCM sw
= scm_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
235 scm_divbigdig (SCM_BDIGITS (sw
), SCM_NUMDIGS (sw
), (SCM_BIGDIG
) z
);
236 return scm_normbig (sw
);
238 #ifndef SCM_DIGSTOOBIG
239 long w
= scm_pseudolong (z
);
240 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
241 (SCM_BIGDIG
*) & w
, SCM_DIGSPERLONG
,
242 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
244 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
245 scm_longdigs (z
, zdigs
);
246 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
247 zdigs
, SCM_DIGSPERLONG
,
248 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
252 } else if (SCM_BIGP (y
)) {
253 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
254 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
255 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 2);
257 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
260 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
265 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
266 /* "Return the remainder of the numbers @var{x} and @var{y}.\n"
268 * "(remainder 13 4) @result{} 1\n"
269 * "(remainder -13 4) @result{} -1\n"
273 scm_remainder (SCM x
, SCM y
)
277 long yy
= SCM_INUM (y
);
279 scm_num_overflow (s_remainder
);
281 long z
= SCM_INUM (x
) % yy
;
282 return SCM_MAKINUM (z
);
284 } else if (SCM_BIGP (y
)) {
285 if (SCM_INUM (x
) == SCM_MOST_NEGATIVE_FIXNUM
286 && scm_bigcomp (abs_most_negative_fixnum
, y
) == 0)
288 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
289 return SCM_MAKINUM (0);
294 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
296 } else if (SCM_BIGP (x
)) {
298 long yy
= SCM_INUM (y
);
300 scm_num_overflow (s_remainder
);
302 return scm_divbigint (x
, yy
, SCM_BIGSIGN (x
), 0);
304 } else if (SCM_BIGP (y
)) {
305 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
306 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
309 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
312 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
317 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
318 /* "Return the modulo of the numbers @var{x} and @var{y}.\n"
320 * "(modulo 13 4) @result{} 1\n"
321 * "(modulo -13 4) @result{} 3\n"
325 scm_modulo (SCM x
, SCM y
)
328 long xx
= SCM_INUM (x
);
330 long yy
= SCM_INUM (y
);
332 scm_num_overflow (s_modulo
);
335 return SCM_MAKINUM (((yy
< 0) ? (z
> 0) : (z
< 0)) ? z
+ yy
: z
);
337 } else if (SCM_BIGP (y
)) {
338 return (SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0)) ? scm_sum (x
, y
) : x
;
340 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
342 } else if (SCM_BIGP (x
)) {
344 long yy
= SCM_INUM (y
);
346 scm_num_overflow (s_modulo
);
348 return scm_divbigint (x
, yy
, yy
< 0,
349 (SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0)) ? 1 : 0);
351 } else if (SCM_BIGP (y
)) {
352 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
353 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
355 (SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
)) ? 1 : 0);
357 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
360 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
365 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
366 /* "Return the greatest common divisor of all arguments.\n"
367 * "If called without arguments, 0 is returned."
370 scm_gcd (SCM x
, SCM y
)
372 if (SCM_UNBNDP (y
)) {
373 if (SCM_UNBNDP (x
)) {
383 long xx
= SCM_INUM (x
);
384 long yy
= SCM_INUM (y
);
385 long u
= xx
< 0 ? -xx
: xx
;
386 long v
= yy
< 0 ? -yy
: yy
;
391 } else if (yy
== 0) {
397 /* Determine a common factor 2^k */
398 while (!(1 & (u
| v
))) {
404 /* Now, any factor 2^n can be eliminated */
424 if (SCM_POSFIXABLE (result
)) {
425 return SCM_MAKINUM (result
);
428 return scm_long2big (result
);
430 scm_num_overflow (s_gcd
);
433 } else if (SCM_BIGP (y
)) {
437 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
439 } else if (SCM_BIGP (x
)) {
442 x
= scm_copybig (x
, 0);
445 if (SCM_EQ_P (y
, SCM_INUM0
)) {
450 } else if (SCM_BIGP (y
)) {
452 y
= scm_copybig (y
, 0);
453 switch (scm_bigcomp (x
, y
))
458 SCM t
= scm_remainder (x
, y
);
464 y
= scm_remainder (y
, x
);
466 default: /* x == y */
469 /* instead of the switch, we could just
470 return scm_gcd (y, scm_modulo (x, y)); */
472 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
475 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
480 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
481 /* "Return the least common multiple of the arguments.\n"
482 * "If called without arguments, 1 is returned."
485 scm_lcm (SCM n1
, SCM n2
)
487 if (SCM_UNBNDP (n2
)) {
488 if (SCM_UNBNDP (n1
)) {
489 return SCM_MAKINUM (1L);
491 n2
= SCM_MAKINUM (1L);
496 SCM_GASSERT2 (SCM_INUMP (n1
), g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
497 SCM_GASSERT2 (SCM_INUMP (n2
), g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
499 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
500 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
501 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
502 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
506 SCM d
= scm_gcd (n1
, n2
);
507 if (SCM_EQ_P (d
, SCM_INUM0
)) {
510 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
517 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
519 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
523 /* Emulating 2's complement bignums with sign magnitude arithmetic:
528 + + + x (map digit:logand X Y)
529 + - + x (map digit:logand X (lognot (+ -1 Y)))
530 - + + y (map digit:logand (lognot (+ -1 X)) Y)
531 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
536 + + + (map digit:logior X Y)
537 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
538 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
539 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
544 + + + (map digit:logxor X Y)
545 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
546 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
547 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
552 + + (any digit:logand X Y)
553 + - (any digit:logand X (lognot (+ -1 Y)))
554 - + (any digit:logand (lognot (+ -1 X)) Y)
561 SCM
scm_copy_big_dec(SCM b
, int sign
);
562 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
);
563 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
564 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
565 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
);
566 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
568 SCM
scm_copy_big_dec(SCM b
, int sign
)
571 scm_sizet nx
= SCM_NUMDIGS(b
);
573 SCM ans
= scm_mkbig(nx
, sign
);
574 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
575 if SCM_BIGSIGN(b
) do {
577 if (num
< 0) {dst
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
578 else {dst
[i
] = SCM_BIGLO(num
); num
= 0;}
581 while (nx
--) dst
[nx
] = src
[nx
];
585 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
)
589 SCM z
= scm_mkbig(nx
, zsgn
);
590 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
593 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
594 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
596 else do zds
[i
] = x
[i
]; while (++i
< nx
);
600 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
601 /* Assumes nx <= SCM_NUMDIGS(bigy) */
602 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
605 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
606 SCM z
= scm_copy_big_dec (bigy
, xsgn
& SCM_BIGSIGN (bigy
));
607 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
611 if (num
< 0) {zds
[i
] |= num
+ SCM_BIGRAD
; num
= -1;}
612 else {zds
[i
] |= SCM_BIGLO(num
); num
= 0;}
614 /* ========= Need to increment zds now =========== */
618 zds
[i
++] = SCM_BIGLO(num
);
619 num
= SCM_BIGDN(num
);
622 scm_adjbig(z
, 1 + ny
); /* OOPS, overflowed into next digit. */
623 SCM_BDIGITS(z
)[ny
] = 1;
626 else do zds
[i
] = zds
[i
] | x
[i
]; while (++i
< nx
);
630 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
631 /* Assumes nx <= SCM_NUMDIGS(bigy) */
632 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
635 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
636 SCM z
= scm_copy_big_dec(bigy
, xsgn
^ SCM_BIGSIGN(bigy
));
637 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
640 if (num
< 0) {zds
[i
] ^= num
+ SCM_BIGRAD
; num
= -1;}
641 else {zds
[i
] ^= SCM_BIGLO(num
); num
= 0;}
644 zds
[i
] = zds
[i
] ^ x
[i
];
647 if (xsgn
^ SCM_BIGSIGN(bigy
)) {
648 /* ========= Need to increment zds now =========== */
652 zds
[i
++] = SCM_BIGLO(num
);
653 num
= SCM_BIGDN(num
);
654 if (!num
) return scm_normbig(z
);
657 return scm_normbig(z
);
660 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
)
661 /* Assumes nx <= SCM_NUMDIGS(bigy) */
662 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
663 /* return sign equals either 0 or SCM_BIGSIGNFLAG */
670 z
= scm_copy_smaller(x
, nx
, zsgn
);
671 x
= SCM_BDIGITS(bigy
);
672 xsgn
= SCM_BIGSIGN(bigy
);
674 else z
= scm_copy_big_dec(bigy
, zsgn
);
675 zds
= SCM_BDIGITS(z
);
680 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
681 else {zds
[i
] &= SCM_BIGLO(num
); num
= 0;}
683 else do zds
[i
] = zds
[i
] & ~x
[i
]; while (++i
< nx
);
684 /* ========= need to increment zds now =========== */
688 zds
[i
++] = SCM_BIGLO(num
);
689 num
= SCM_BIGDN(num
);
690 if (!num
) return scm_normbig(z
);
694 unsigned long int carry
= 1;
696 unsigned long int mask
= (SCM_BIGDIG
) ~x
[i
] + carry
;
697 zds
[i
] = zds
[i
] & (SCM_BIGDIG
) mask
;
698 carry
= (mask
>= SCM_BIGRAD
) ? 1 : 0;
700 } else do zds
[i
] = zds
[i
] & x
[i
]; while (++i
< nx
);
701 return scm_normbig(z
);
704 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
705 /* Assumes nx <= SCM_NUMDIGS(bigy) */
706 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
711 if (SCM_BIGSIGN(bigy
) & xsgn
) return SCM_BOOL_T
;
712 if (SCM_NUMDIGS(bigy
) != nx
&& xsgn
) return SCM_BOOL_T
;
713 y
= SCM_BDIGITS(bigy
);
718 if (y
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
722 if (y
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
726 else if SCM_BIGSIGN(bigy
)
730 if (x
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
734 if (x
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
739 do if (x
[i
] & y
[i
]) return SCM_BOOL_T
;
747 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
749 "Returns the integer which is the bit-wise AND of the two integer\n"
753 "(number->string (logand #b1100 #b1010) 2)\n"
754 " @result{} \"1000\"\n"
756 #define FUNC_NAME s_scm_logand
760 if (SCM_UNBNDP (n2
)) {
761 if (SCM_UNBNDP (n1
)) {
762 return SCM_MAKINUM (-1);
763 } else if (!SCM_NUMBERP (n1
)) {
764 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
766 } else if (SCM_NUMBERP (n1
)) {
769 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
777 if (SCM_INUMP (n1
)) {
779 if (SCM_INUMP (n2
)) {
780 long nn2
= SCM_INUM (n2
);
781 return SCM_MAKINUM (nn1
& nn2
);
782 } else if SCM_BIGP (n2
) {
785 # ifndef SCM_DIGSTOOBIG
786 long z
= scm_pseudolong (nn1
);
787 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
788 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
789 SCM_BIGSIGNFLAG
, n2
);
791 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
792 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
795 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
796 scm_longdigs (nn1
, zdigs
);
797 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
798 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
800 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
801 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
806 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
808 } else if (SCM_BIGP (n1
)) {
809 if (SCM_INUMP (n2
)) {
813 } else if (SCM_BIGP (n2
)) {
814 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
817 if ((SCM_BIGSIGN (n1
)) && SCM_BIGSIGN (n2
)) {
818 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
819 SCM_BIGSIGNFLAG
, n2
);
821 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
822 SCM_BIGSIGN (n1
), n2
, 0);
825 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
828 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
834 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
836 "Returns the integer which is the bit-wise OR of the two integer\n"
840 "(number->string (logior #b1100 #b1010) 2)\n"
841 " @result{} \"1110\"\n"
843 #define FUNC_NAME s_scm_logior
847 if (SCM_UNBNDP (n2
)) {
848 if (SCM_UNBNDP (n1
)) {
851 } else if (SCM_NUMBERP (n1
)) {
854 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
862 if (SCM_INUMP (n1
)) {
864 if (SCM_INUMP (n2
)) {
865 long nn2
= SCM_INUM (n2
);
866 return SCM_MAKINUM (nn1
| nn2
);
867 } else if (SCM_BIGP (n2
)) {
870 # ifndef SCM_DIGSTOOBIG
871 long z
= scm_pseudolong (nn1
);
872 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
873 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
874 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
876 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
877 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
880 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
881 scm_longdigs (nn1
, zdigs
);
882 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
883 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
,
884 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
886 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
887 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
892 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
894 } else if (SCM_BIGP (n1
)) {
895 if (SCM_INUMP (n2
)) {
899 } else if (SCM_BIGP (n2
)) {
900 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
903 if ((!SCM_BIGSIGN (n1
)) && !SCM_BIGSIGN (n2
)) {
904 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
905 SCM_BIGSIGN (n1
), n2
);
907 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
908 SCM_BIGSIGN (n1
), n2
, SCM_BIGSIGNFLAG
);
911 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
914 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
920 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
922 "Returns the integer which is the bit-wise XOR of the two integer\n"
926 "(number->string (logxor #b1100 #b1010) 2)\n"
927 " @result{} \"110\"\n"
929 #define FUNC_NAME s_scm_logxor
933 if (SCM_UNBNDP (n2
)) {
934 if (SCM_UNBNDP (n1
)) {
937 } else if (SCM_NUMBERP (n1
)) {
940 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
948 if (SCM_INUMP (n1
)) {
950 if (SCM_INUMP (n2
)) {
951 long nn2
= SCM_INUM (n2
);
952 return SCM_MAKINUM (nn1
^ nn2
);
953 } else if (SCM_BIGP (n2
)) {
956 # ifndef SCM_DIGSTOOBIG
957 long z
= scm_pseudolong (nn1
);
958 return scm_big_xor ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
959 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
961 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
962 scm_longdigs (nn1
, zdigs
);
963 return scm_big_xor (zdigs
, SCM_DIGSPERLONG
,
964 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
968 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
970 } else if (SCM_BIGP (n1
)) {
971 if (SCM_INUMP (n2
)) {
975 } else if (SCM_BIGP (n2
)) {
976 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {
979 return scm_big_xor (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
980 SCM_BIGSIGN (n1
), n2
);
982 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
985 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
991 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
994 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
995 "(logtest #b0100 #b1011) @result{} #f\n"
996 "(logtest #b0100 #b0111) @result{} #t\n"
998 #define FUNC_NAME s_scm_logtest
1002 if (SCM_INUMP (n1
)) {
1003 nn1
= SCM_INUM (n1
);
1004 if (SCM_INUMP (n2
)) {
1005 long nn2
= SCM_INUM (n2
);
1006 return SCM_BOOL (nn1
& nn2
);
1007 } else if (SCM_BIGP (n2
)) {
1010 # ifndef SCM_DIGSTOOBIG
1011 long z
= scm_pseudolong (nn1
);
1012 return scm_big_test ((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
1013 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
1015 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
1016 scm_longdigs (nn1
, zdigs
);
1017 return scm_big_test (zdigs
, SCM_DIGSPERLONG
,
1018 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
1022 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1024 } else if (SCM_BIGP (n1
)) {
1025 if (SCM_INUMP (n2
)) {
1027 nn1
= SCM_INUM (n1
);
1029 } else if (SCM_BIGP (n2
)) {
1030 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
1033 return scm_big_test (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
1034 SCM_BIGSIGN (n1
), n2
);
1036 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
1039 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
1045 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
1048 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1049 "(logbit? 0 #b1101) @result{} #t\n"
1050 "(logbit? 1 #b1101) @result{} #f\n"
1051 "(logbit? 2 #b1101) @result{} #t\n"
1052 "(logbit? 3 #b1101) @result{} #t\n"
1053 "(logbit? 4 #b1101) @result{} #f\n"
1055 #define FUNC_NAME s_scm_logbit_p
1057 unsigned long int iindex
;
1059 SCM_VALIDATE_INUM_MIN (SCM_ARG1
, index
, 0);
1060 iindex
= (unsigned long int) SCM_INUM (index
);
1062 if (SCM_INUMP (j
)) {
1063 return SCM_BOOL ((1L << iindex
) & SCM_INUM (j
));
1064 } else if (SCM_BIGP (j
)) {
1065 if (SCM_NUMDIGS (j
) * SCM_BITSPERDIG
< iindex
) {
1067 } else if (SCM_BIGSIGN (j
)) {
1070 SCM_BIGDIG
* x
= SCM_BDIGITS (j
);
1071 scm_sizet nx
= iindex
/ SCM_BITSPERDIG
;
1075 return SCM_BOOL (((1L << (iindex
% SCM_BITSPERDIG
)) & num
) == 0);
1076 } else if (num
< 0) {
1083 return SCM_BOOL (SCM_BDIGITS (j
) [iindex
/ SCM_BITSPERDIG
]
1084 & (1L << (iindex
% SCM_BITSPERDIG
)));
1087 SCM_WRONG_TYPE_ARG (SCM_ARG2
, j
);
1093 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1095 "Returns the integer which is the 2s-complement of the integer argument.\n\n"
1098 "(number->string (lognot #b10000000) 2)\n"
1099 " @result{} \"-10000001\"\n"
1100 "(number->string (lognot #b0) 2)\n"
1101 " @result{} \"-1\"\n"
1103 #define FUNC_NAME s_scm_lognot
1105 return scm_difference (SCM_MAKINUM (-1L), n
);
1109 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1111 "Returns @var{n} raised to the non-negative integer exponent @var{k}.\n\n"
1114 "(integer-expt 2 5)\n"
1116 "(integer-expt -3 3)\n"
1119 #define FUNC_NAME s_scm_integer_expt
1121 SCM acc
= SCM_MAKINUM (1L);
1124 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1126 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1127 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1129 SCM_VALIDATE_ULONG_COPY (2,k
,i2
);
1133 n
= scm_divide (n
, SCM_UNDEFINED
);
1140 return scm_product (acc
, n
);
1142 acc
= scm_product (acc
, n
);
1143 n
= scm_product (n
, n
);
1149 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1151 "The function ash performs an arithmetic shift left by @var{CNT}\n"
1152 "bits (or shift right, if @var{cnt} is negative).\n"
1153 "'Arithmetic' means, that the function does not guarantee to\n"
1154 "keep the bit structure of @var{n}, but rather guarantees that\n"
1155 "the result will always be rounded towards minus infinity.\n"
1156 "Therefore, the results of ash and a corresponding bitwise\n"
1157 "shift will differ if N is negative.\n\n"
1158 "Formally, the function returns an integer equivalent to\n"
1159 "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n\n"
1162 "(number->string (ash #b1 3) 2)\n"
1163 " @result{} \"1000\"\n"
1164 "(number->string (ash #b1010 -1) 2)\n"
1165 " @result{} \"101\"\n"
1167 #define FUNC_NAME s_scm_ash
1172 SCM_VALIDATE_INUM (1, n
)
1174 SCM_VALIDATE_INUM (2, cnt
);
1176 bits_to_shift
= SCM_INUM (cnt
);
1178 if (bits_to_shift
< 0) {
1179 /* Shift right by abs(cnt) bits. This is realized as a division by
1180 div:=2^abs(cnt). However, to guarantee the floor rounding, negative
1181 values require some special treatment.
1183 SCM div
= scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift
));
1184 if (SCM_FALSEP (scm_negative_p (n
)))
1185 return scm_quotient (n
, div
);
1187 return scm_sum (SCM_MAKINUM (-1L),
1188 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1190 /* Shift left is done by multiplication with 2^CNT */
1191 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1193 if (bits_to_shift
< 0)
1194 /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */
1195 return SCM_MAKINUM (SCM_SRS (SCM_INUM (n
), -bits_to_shift
));
1197 /* Shift left, but make sure not to leave the range of inums */
1198 SCM res
= SCM_MAKINUM (SCM_INUM (n
) << cnt
);
1199 if (SCM_INUM (res
) >> cnt
!= SCM_INUM (n
))
1200 scm_num_overflow (FUNC_NAME
);
1208 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1209 (SCM n
, SCM start
, SCM end
),
1210 "Returns the integer composed of the @var{start} (inclusive) through\n"
1211 "@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes\n"
1212 "the 0-th bit in the result.@refill\n\n"
1215 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1216 " @result{} \"1010\"\n"
1217 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1218 " @result{} \"10110\"\n"
1220 #define FUNC_NAME s_scm_bit_extract
1222 unsigned long int istart
, iend
;
1223 SCM_VALIDATE_INUM_MIN_COPY (2,start
,0,istart
);
1224 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1225 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1227 if (SCM_INUMP (n
)) {
1228 long int in
= SCM_INUM (n
);
1229 unsigned long int bits
= iend
- istart
;
1231 if (in
< 0 && bits
>= SCM_FIXNUM_BIT
)
1233 /* Since we emulate two's complement encoded numbers, this special
1234 * case requires us to produce a result that has more bits than can be
1235 * stored in a fixnum. Thus, we fall back to the more general
1236 * algorithm that is used for bignums.
1241 if (istart
< SCM_FIXNUM_BIT
)
1244 if (bits
< SCM_FIXNUM_BIT
)
1245 return SCM_MAKINUM (in
& ((1L << bits
) - 1));
1246 else /* we know: in >= 0 */
1247 return SCM_MAKINUM (in
);
1251 return SCM_MAKINUM (-1L & ((1L << bits
) - 1));
1255 return SCM_MAKINUM (0);
1257 } else if (SCM_BIGP (n
)) {
1260 SCM num1
= SCM_MAKINUM (1L);
1261 SCM num2
= SCM_MAKINUM (2L);
1262 SCM bits
= SCM_MAKINUM (iend
- istart
);
1263 SCM mask
= scm_difference (scm_integer_expt (num2
, bits
), num1
);
1264 return scm_logand (mask
, scm_ash (n
, SCM_MAKINUM (-istart
)));
1267 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1273 static const char scm_logtab
[] = {
1274 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1277 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1279 "Returns the number of bits in integer @var{n}. If integer is positive,\n"
1280 "the 1-bits in its binary representation are counted. If negative, the\n"
1281 "0-bits in its two's-complement binary representation are counted. If 0,\n"
1282 "0 is returned.\n\n"
1285 "(logcount #b10101010)\n"
1292 #define FUNC_NAME s_scm_logcount
1294 if (SCM_INUMP (n
)) {
1295 unsigned long int c
= 0;
1296 long int nn
= SCM_INUM (n
);
1301 c
+= scm_logtab
[15 & nn
];
1304 return SCM_MAKINUM (c
);
1305 } else if (SCM_BIGP (n
)) {
1306 if (SCM_BIGSIGN (n
)) {
1307 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n
));
1309 unsigned long int c
= 0;
1310 scm_sizet i
= SCM_NUMDIGS (n
);
1311 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1314 for (d
= ds
[i
]; d
; d
>>= 4) {
1315 c
+= scm_logtab
[15 & d
];
1318 return SCM_MAKINUM (c
);
1321 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1327 static const char scm_ilentab
[] = {
1328 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1331 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1333 "Returns the number of bits neccessary to represent @var{n}.\n\n"
1336 "(integer-length #b10101010)\n"
1338 "(integer-length 0)\n"
1340 "(integer-length #b1111)\n"
1343 #define FUNC_NAME s_scm_integer_length
1345 if (SCM_INUMP (n
)) {
1346 unsigned long int c
= 0;
1348 long int nn
= SCM_INUM (n
);
1354 l
= scm_ilentab
[15 & nn
];
1357 return SCM_MAKINUM (c
- 4 + l
);
1358 } else if (SCM_BIGP (n
)) {
1359 if (SCM_BIGSIGN (n
)) {
1360 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n
));
1362 unsigned long int digs
= SCM_NUMDIGS (n
) - 1;
1363 unsigned long int c
= digs
* SCM_BITSPERDIG
;
1365 SCM_BIGDIG
* ds
= SCM_BDIGITS (n
);
1366 SCM_BIGDIG d
= ds
[digs
];
1369 l
= scm_ilentab
[15 & d
];
1372 return SCM_MAKINUM (c
- 4 + l
);
1375 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n
);
1382 static const char s_bignum
[] = "bignum";
1385 scm_mkbig (scm_sizet nlen
, int sign
)
1388 /* Cast to long int to avoid signed/unsigned comparison warnings. */
1389 if ((( ((long int) nlen
) << SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
)
1391 scm_memory_error (s_bignum
);
1395 SCM_SET_BIGNUM_BASE (v
, scm_must_malloc (nlen
* sizeof (SCM_BIGDIG
), s_bignum
));
1396 SCM_SETNUMDIGS (v
, nlen
, sign
);
1403 scm_big2inum (SCM b
, scm_sizet l
)
1405 unsigned long num
= 0;
1406 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1408 num
= SCM_BIGUP (num
) + tmp
[l
];
1409 if (!SCM_BIGSIGN (b
))
1411 if (SCM_POSFIXABLE (num
))
1412 return SCM_MAKINUM (num
);
1414 else if (num
<= -SCM_MOST_NEGATIVE_FIXNUM
)
1415 return SCM_MAKINUM (-num
);
1420 static const char s_adjbig
[] = "scm_adjbig";
1423 scm_adjbig (SCM b
, scm_sizet nlen
)
1425 scm_sizet nsiz
= nlen
;
1426 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1427 scm_memory_error (s_adjbig
);
1433 scm_must_realloc ((char *) SCM_BDIGITS (b
),
1434 (long) (SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
)),
1435 (long) (nsiz
* sizeof (SCM_BIGDIG
)), s_bignum
));
1437 SCM_SET_BIGNUM_BASE (b
, digits
);
1438 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1450 scm_sizet nlen
= SCM_NUMDIGS (b
);
1452 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1454 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1455 while (nlen
-- && !zds
[nlen
]);
1457 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1458 if (SCM_INUMP (b
= scm_big2inum (b
, (scm_sizet
) nlen
)))
1460 if (SCM_NUMDIGS (b
) == nlen
)
1462 return scm_adjbig (b
, (scm_sizet
) nlen
);
1468 scm_copybig (SCM b
, int sign
)
1470 scm_sizet i
= SCM_NUMDIGS (b
);
1471 SCM ans
= scm_mkbig (i
, sign
);
1472 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1481 scm_long2big (long n
)
1485 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, n
< 0);
1486 digits
= SCM_BDIGITS (ans
);
1489 while (i
< SCM_DIGSPERLONG
)
1491 digits
[i
++] = SCM_BIGLO (n
);
1492 n
= SCM_BIGDN ((unsigned long) n
);
1497 #ifdef HAVE_LONG_LONGS
1500 scm_long_long2big (long_long n
)
1510 if ((long long) tn
== n
)
1511 return scm_long2big (tn
);
1517 for (tn
= n
, n_digits
= 0;
1519 ++n_digits
, tn
= SCM_BIGDN ((ulong_long
) tn
))
1524 ans
= scm_mkbig (n_digits
, n
< 0);
1525 digits
= SCM_BDIGITS (ans
);
1528 while (i
< n_digits
)
1530 digits
[i
++] = SCM_BIGLO (n
);
1531 n
= SCM_BIGDN ((ulong_long
) n
);
1535 #endif /* HAVE_LONG_LONGS */
1539 scm_2ulong2big (unsigned long *np
)
1546 ans
= scm_mkbig (2 * SCM_DIGSPERLONG
, 0);
1547 digits
= SCM_BDIGITS (ans
);
1550 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1552 digits
[i
] = SCM_BIGLO (n
);
1553 n
= SCM_BIGDN ((unsigned long) n
);
1556 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1558 digits
[i
+ SCM_DIGSPERLONG
] = SCM_BIGLO (n
);
1559 n
= SCM_BIGDN ((unsigned long) n
);
1567 scm_ulong2big (unsigned long n
)
1571 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, 0);
1572 digits
= SCM_BDIGITS (ans
);
1573 while (i
< SCM_DIGSPERLONG
)
1575 digits
[i
++] = SCM_BIGLO (n
);
1584 scm_bigcomp (SCM x
, SCM y
)
1586 int xsign
= SCM_BIGSIGN (x
);
1587 int ysign
= SCM_BIGSIGN (y
);
1588 scm_sizet xlen
, ylen
;
1590 /* Look at the signs, first. */
1596 /* They're the same sign, so see which one has more digits. Note
1597 that, if they are negative, the longer number is the lesser. */
1598 ylen
= SCM_NUMDIGS (y
);
1599 xlen
= SCM_NUMDIGS (x
);
1601 return (xsign
) ? -1 : 1;
1603 return (xsign
) ? 1 : -1;
1605 /* They have the same number of digits, so find the most significant
1606 digit where they differ. */
1610 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1611 /* Make the discrimination based on the digit that differs. */
1612 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1614 : (xsign
? 1 : -1));
1617 /* The numbers are identical. */
1621 #ifndef SCM_DIGSTOOBIG
1625 scm_pseudolong (long x
)
1630 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1636 while (i
< SCM_DIGSPERLONG
)
1638 p
.bd
[i
++] = SCM_BIGLO (x
);
1641 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1649 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1654 while (i
< SCM_DIGSPERLONG
)
1656 digs
[i
++] = SCM_BIGLO (x
);
1665 scm_addbig (SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int sgny
)
1667 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1668 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1670 scm_sizet i
= 0, ny
= SCM_NUMDIGS (bigy
);
1671 SCM z
= scm_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1672 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1673 if (xsgn
^ SCM_BIGSIGN (z
))
1677 num
+= (long) zds
[i
] - x
[i
];
1680 zds
[i
] = num
+ SCM_BIGRAD
;
1685 zds
[i
] = SCM_BIGLO (num
);
1690 if (num
&& nx
== ny
)
1694 SCM_SET_CELL_WORD_0 (z
, SCM_CELL_WORD_0 (z
) ^ SCM_BIGSIGNFLAG
);
1697 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1698 zds
[i
++] = SCM_BIGLO (num
);
1699 num
= SCM_BIGDN (num
);
1709 zds
[i
++] = num
+ SCM_BIGRAD
;
1714 zds
[i
++] = SCM_BIGLO (num
);
1723 num
+= (long) zds
[i
] + x
[i
];
1724 zds
[i
++] = SCM_BIGLO (num
);
1725 num
= SCM_BIGDN (num
);
1733 zds
[i
++] = SCM_BIGLO (num
);
1734 num
= SCM_BIGDN (num
);
1740 z
= scm_adjbig (z
, ny
+ 1);
1741 SCM_BDIGITS (z
)[ny
] = num
;
1745 return scm_normbig (z
);
1750 scm_mulbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
)
1752 scm_sizet i
= 0, j
= nx
+ ny
;
1753 unsigned long n
= 0;
1754 SCM z
= scm_mkbig (j
, sgn
);
1755 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1765 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1766 zds
[i
+ j
++] = SCM_BIGLO (n
);
1778 return scm_normbig (z
);
1783 scm_divbigdig (SCM_BIGDIG
* ds
, scm_sizet h
, SCM_BIGDIG div
)
1785 register unsigned long t2
= 0;
1788 t2
= SCM_BIGUP (t2
) + ds
[h
];
1798 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1804 register unsigned long t2
= 0;
1805 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1806 scm_sizet nd
= SCM_NUMDIGS (x
);
1808 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1811 return SCM_MAKINUM (sgn
? -t2
: t2
);
1814 #ifndef SCM_DIGSTOOBIG
1815 unsigned long t2
= scm_pseudolong (z
);
1816 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1817 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1820 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1821 scm_longdigs (z
, t2
);
1822 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1823 t2
, SCM_DIGSPERLONG
,
1831 scm_divbigbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
)
1833 /* modes description
1837 3 quotient but returns SCM_UNDEFINED if division is not exact. */
1838 scm_sizet i
= 0, j
= 0;
1840 unsigned long t2
= 0;
1842 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1843 /* algorithm requires nx >= ny */
1847 case 0: /* remainder -- just return x */
1848 z
= scm_mkbig (nx
, sgn
);
1849 zds
= SCM_BDIGITS (z
);
1856 case 1: /* scm_modulo -- return y-x */
1857 z
= scm_mkbig (ny
, sgn
);
1858 zds
= SCM_BDIGITS (z
);
1861 num
+= (long) y
[i
] - x
[i
];
1864 zds
[i
] = num
+ SCM_BIGRAD
;
1879 zds
[i
++] = num
+ SCM_BIGRAD
;
1890 return SCM_INUM0
; /* quotient is zero */
1892 return SCM_UNDEFINED
; /* the division is not exact */
1895 z
= scm_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1896 zds
= SCM_BDIGITS (z
);
1900 ny
--; /* in case y came in as a psuedolong */
1901 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1902 { /* normalize operands */
1903 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1904 newy
= scm_mkbig (ny
, 0);
1905 yds
= SCM_BDIGITS (newy
);
1908 t2
+= (unsigned long) y
[j
] * d
;
1909 yds
[j
++] = SCM_BIGLO (t2
);
1910 t2
= SCM_BIGDN (t2
);
1917 t2
+= (unsigned long) x
[j
] * d
;
1918 zds
[j
++] = SCM_BIGLO (t2
);
1919 t2
= SCM_BIGDN (t2
);
1929 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1931 { /* loop over digits of quotient */
1932 if (zds
[j
] == y
[ny
- 1])
1933 qhat
= SCM_BIGRAD
- 1;
1935 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1942 { /* multiply and subtract */
1943 t2
+= (unsigned long) y
[i
] * qhat
;
1944 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1947 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1952 zds
[j
- ny
+ i
] = num
;
1955 t2
= SCM_BIGDN (t2
);
1958 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1960 { /* "add back" required */
1966 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1967 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1968 num
= SCM_BIGDN (num
);
1979 case 3: /* check that remainder==0 */
1980 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1982 return SCM_UNDEFINED
;
1983 case 2: /* move quotient down in z */
1984 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
1985 for (i
= 0; i
< j
; i
++)
1986 zds
[i
] = zds
[i
+ ny
];
1989 case 1: /* subtract for scm_modulo */
1995 num
+= y
[i
] - zds
[i
];
1999 zds
[i
] = num
+ SCM_BIGRAD
;
2011 case 0: /* just normalize remainder */
2013 scm_divbigdig (zds
, ny
, d
);
2016 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
2017 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
2018 if (SCM_INUMP (z
= scm_big2inum (z
, j
)))
2020 return scm_adjbig (z
, j
);
2028 /*** NUMBERS -> STRINGS ***/
2030 static const double fx
[] =
2031 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
2032 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
2033 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
2034 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
2040 idbl2str (double f
, char *a
)
2042 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
2047 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
2066 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
2067 make-uniform-vector, from causing infinite loops. */
2071 if (exp
-- < DBL_MIN_10_EXP
)
2077 if (exp
++ > DBL_MAX_10_EXP
)
2092 if (f
+ fx
[wp
] >= 10.0)
2099 dpt
= (exp
+ 9999) % 3;
2103 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2128 if (f
+ fx
[wp
] >= 1.0)
2142 if ((dpt
> 4) && (exp
> 6))
2144 d
= (a
[0] == '-' ? 2 : 1);
2145 for (i
= ch
++; i
> d
; i
--)
2158 if (a
[ch
- 1] == '.')
2159 a
[ch
++] = '0'; /* trailing zero */
2168 for (i
= 10; i
<= exp
; i
*= 10);
2169 for (i
/= 10; i
; i
/= 10)
2171 a
[ch
++] = exp
/ i
+ '0';
2180 iflo2str (SCM flt
, char *str
)
2183 if (SCM_SLOPPY_REALP (flt
))
2184 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2187 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2188 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2190 if (0 <= SCM_COMPLEX_IMAG (flt
))
2192 i
+= idbl2str (SCM_COMPLEX_IMAG (flt
), &str
[i
]);
2199 /* convert a long to a string (unterminated). returns the number of
2200 characters in the result.
2202 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2204 scm_iint2str (long num
, int rad
, char *p
)
2208 unsigned long n
= (num
< 0) ? -num
: num
;
2210 for (n
/= rad
; n
> 0; n
/= rad
)
2227 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2236 big2str (SCM b
, unsigned int radix
)
2238 SCM t
= scm_copybig (b
, 0); /* sign of temp doesn't matter */
2239 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2240 scm_sizet i
= SCM_NUMDIGS (t
);
2241 scm_sizet j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2242 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2243 : (SCM_BITSPERDIG
* i
) + 2;
2245 scm_sizet radct
= 0;
2246 SCM_BIGDIG radpow
= 1, radmod
= 0;
2247 SCM ss
= scm_makstr ((long) j
, 0);
2248 char *s
= SCM_STRING_CHARS (ss
), c
;
2249 while ((long) radpow
* radix
< SCM_BIGRAD
)
2254 while ((i
|| radmod
) && j
)
2258 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2266 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2269 if (SCM_BIGSIGN (b
))
2274 /* The pre-reserved string length was too large. */
2275 unsigned long int length
= SCM_STRING_LENGTH (ss
);
2276 ss
= scm_substring (ss
, SCM_MAKINUM (j
), SCM_MAKINUM (length
));
2279 return scm_return_first (ss
, t
);
2284 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2286 "Return a string holding the external representation of the\n"
2287 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2288 "inexact, a radix of 10 will be used.")
2289 #define FUNC_NAME s_scm_number_to_string
2293 if (SCM_UNBNDP (radix
)) {
2296 SCM_VALIDATE_INUM (2, radix
);
2297 base
= SCM_INUM (radix
);
2298 SCM_ASSERT_RANGE (2, radix
, base
>= 2);
2301 if (SCM_INUMP (n
)) {
2302 char num_buf
[SCM_INTBUFLEN
];
2303 scm_sizet length
= scm_iint2str (SCM_INUM (n
), base
, num_buf
);
2304 return scm_makfromstr (num_buf
, length
, 0);
2305 } else if (SCM_BIGP (n
)) {
2306 return big2str (n
, (unsigned int) base
);
2307 } else if (SCM_INEXACTP (n
)) {
2308 char num_buf
[SCM_FLOBUFLEN
];
2309 return scm_makfromstr (num_buf
, iflo2str (n
, num_buf
), 0);
2311 SCM_WRONG_TYPE_ARG (1, n
);
2317 /* These print routines are stubbed here so that scm_repl.c doesn't need
2318 SCM_BIGDIG conditionals */
2321 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2323 char num_buf
[SCM_FLOBUFLEN
];
2324 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2329 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2331 char num_buf
[SCM_FLOBUFLEN
];
2332 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2337 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate
)
2340 exp
= big2str (exp
, (unsigned int) 10);
2341 scm_lfwrite (SCM_STRING_CHARS (exp
), (scm_sizet
) SCM_STRING_LENGTH (exp
), port
);
2343 scm_ipruk ("bignum", exp
, port
);
2347 /*** END nums->strs ***/
2349 /*** STRINGS -> NUMBERS ***/
2352 scm_small_istr2int (char *str
, long len
, long radix
)
2354 register long n
= 0, ln
;
2359 return SCM_BOOL_F
; /* zero scm_length */
2361 { /* leading sign */
2366 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2371 switch (c
= str
[i
++])
2393 return SCM_BOOL_F
; /* bad digit for radix */
2396 /* Negation is a workaround for HP700 cc bug */
2397 if (n
> ln
|| (-n
> -SCM_MOST_NEGATIVE_FIXNUM
))
2401 return SCM_BOOL_F
; /* not a digit */
2406 if ((n
= -n
) > SCM_MOST_POSITIVE_FIXNUM
)
2408 return SCM_MAKINUM (n
);
2409 ovfl
: /* overflow scheme integer */
2416 scm_istr2int (char *str
, long len
, long radix
)
2419 register scm_sizet k
, blen
= 1;
2423 register SCM_BIGDIG
*ds
;
2424 register unsigned long t2
;
2427 return SCM_BOOL_F
; /* zero scm_length */
2429 /* Short numbers we parse directly into an int, to avoid the overhead
2430 of creating a bignum. */
2432 return scm_small_istr2int (str
, len
, radix
);
2435 j
= 1 + (4 * len
* sizeof (char)) / (SCM_BITSPERDIG
);
2436 else if (10 <= radix
)
2437 j
= 1 + (84 * len
* sizeof (char)) / (SCM_BITSPERDIG
* 25);
2439 j
= 1 + (len
* sizeof (char)) / (SCM_BITSPERDIG
);
2441 { /* leading sign */
2444 if (++i
== (unsigned) len
)
2445 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2447 res
= scm_mkbig (j
, '-' == str
[0]);
2448 ds
= SCM_BDIGITS (res
);
2453 switch (c
= str
[i
++])
2475 return SCM_BOOL_F
; /* bad digit for radix */
2481 /* printf ("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]); */
2482 t2
+= ds
[k
] * radix
;
2483 ds
[k
++] = SCM_BIGLO (t2
);
2484 t2
= SCM_BIGDN (t2
);
2487 scm_num_overflow ("bignum");
2495 return SCM_BOOL_F
; /* not a digit */
2498 while (i
< (unsigned) len
);
2499 if (blen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
2500 if (SCM_INUMP (res
= scm_big2inum (res
, blen
)))
2504 return scm_adjbig (res
, blen
);
2508 scm_istr2flo (char *str
, long len
, long radix
)
2510 register int c
, i
= 0;
2512 double res
= 0.0, tmp
= 0.0;
2518 return SCM_BOOL_F
; /* zero scm_length */
2521 { /* leading sign */
2534 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2536 if (str
[i
] == 'i' || str
[i
] == 'I')
2537 { /* handle `+i' and `-i' */
2538 if (lead_sgn
== 0.0)
2539 return SCM_BOOL_F
; /* must have leading sign */
2541 return SCM_BOOL_F
; /* `i' not last character */
2542 return scm_make_complex (0.0, lead_sgn
);
2545 { /* check initial digits */
2555 goto out1
; /* must be exponent */
2572 return SCM_BOOL_F
; /* bad digit for radix */
2573 res
= res
* radix
+ c
;
2574 flg
= 1; /* res is valid */
2583 /* if true, then we did see a digit above, and res is valid */
2587 /* By here, must have seen a digit,
2588 or must have next char be a `.' with radix==10 */
2590 if (!(str
[i
] == '.' && radix
== 10))
2593 while (str
[i
] == '#')
2594 { /* optional sharps */
2627 tmp
= tmp
* radix
+ c
;
2635 return SCM_BOOL_F
; /* `slash zero' not allowed */
2637 while (str
[i
] == '#')
2638 { /* optional sharps */
2648 { /* decimal point notation */
2650 return SCM_BOOL_F
; /* must be radix 10 */
2657 res
= res
* 10.0 + c
- '0';
2666 return SCM_BOOL_F
; /* no digits before or after decimal point */
2669 while (str
[i
] == '#')
2670 { /* ignore remaining sharps */
2689 int expsgn
= 1, expon
= 0;
2691 return SCM_BOOL_F
; /* only in radix 10 */
2693 return SCM_BOOL_F
; /* bad exponent */
2700 return SCM_BOOL_F
; /* bad exponent */
2702 if (str
[i
] < '0' || str
[i
] > '9')
2703 return SCM_BOOL_F
; /* bad exponent */
2709 expon
= expon
* 10 + c
- '0';
2710 if (expon
> SCM_MAXEXP
)
2711 scm_out_of_range ("string->number", SCM_MAKINUM (expon
));
2719 point
+= expsgn
* expon
;
2737 /* at this point, we have a legitimate floating point result */
2738 if (lead_sgn
== -1.0)
2741 return scm_make_real (res
);
2743 if (str
[i
] == 'i' || str
[i
] == 'I')
2744 { /* pure imaginary number */
2745 if (lead_sgn
== 0.0)
2746 return SCM_BOOL_F
; /* must have leading sign */
2748 return SCM_BOOL_F
; /* `i' not last character */
2749 return scm_make_complex (0.0, res
);
2761 { /* polar input for complex number */
2762 /* get a `real' for scm_angle */
2763 second
= scm_istr2flo (&str
[i
], (long) (len
- i
), radix
);
2764 if (!SCM_SLOPPY_INEXACTP (second
))
2765 return SCM_BOOL_F
; /* not `real' */
2766 if (SCM_SLOPPY_COMPLEXP (second
))
2767 return SCM_BOOL_F
; /* not `real' */
2768 tmp
= SCM_REAL_VALUE (second
);
2769 return scm_make_complex (res
* cos (tmp
), res
* sin (tmp
));
2775 /* at this point, last char must be `i' */
2776 if (str
[len
- 1] != 'i' && str
[len
- 1] != 'I')
2778 /* handles `x+i' and `x-i' */
2780 return scm_make_complex (res
, lead_sgn
);
2781 /* get a `ureal' for complex part */
2782 second
= scm_istr2flo (&str
[i
], (long) ((len
- i
) - 1), radix
);
2783 if (!SCM_INEXACTP (second
))
2784 return SCM_BOOL_F
; /* not `ureal' */
2785 if (SCM_SLOPPY_COMPLEXP (second
))
2786 return SCM_BOOL_F
; /* not `ureal' */
2787 tmp
= SCM_REAL_VALUE (second
);
2789 return SCM_BOOL_F
; /* not `ureal' */
2790 return scm_make_complex (res
, (lead_sgn
* tmp
));
2796 scm_istring2number (char *str
, long len
, long radix
)
2800 char ex_p
= 0, rx_p
= 0; /* Only allow 1 exactness and 1 radix prefix */
2803 if (*str
== '+' || *str
== '-') /* Catches lone `+' and `-' for speed */
2806 while ((len
- i
) >= 2 && str
[i
] == '#' && ++i
)
2852 return scm_istr2int (&str
[i
], len
- i
, radix
);
2854 res
= scm_istr2int (&str
[i
], len
- i
, radix
);
2855 if (SCM_NFALSEP (res
))
2858 return scm_istr2flo (&str
[i
], len
- i
, radix
);
2864 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2865 (SCM string
, SCM radix
),
2866 "Returns a number of the maximally precise representation\n"
2867 "expressed by the given @var{string}. @var{radix} must be an\n"
2868 "exact integer, either 2, 8, 10, or 16. If supplied, @var{RADIX}\n"
2869 "is a default radix that may be overridden by an explicit\n"
2870 "radix prefix in @var{string} (e.g. \"#o177\"). If @var{radix}\n"
2871 "is not supplied, then the default radix is 10. If string is\n"
2872 "not a syntactically valid notation for a number, then\n"
2873 "@code{string->number} returns @code{#f}. (r5rs)")
2874 #define FUNC_NAME s_scm_string_to_number
2878 SCM_VALIDATE_STRING (1, string
);
2879 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2880 answer
= scm_istring2number (SCM_STRING_CHARS (string
),
2881 SCM_STRING_LENGTH (string
),
2883 return scm_return_first (answer
, string
);
2886 /*** END strs->nums ***/
2890 scm_make_real (double x
)
2894 SCM_SET_CELL_TYPE (z
, scm_tc16_real
);
2895 SCM_REAL_VALUE (z
) = x
;
2901 scm_make_complex (double x
, double y
)
2904 return scm_make_real (x
);
2907 SCM_NEWSMOB (z
, scm_tc16_complex
, scm_must_malloc (2L * sizeof (double), "complex"));
2908 SCM_COMPLEX_REAL (z
) = x
;
2909 SCM_COMPLEX_IMAG (z
) = y
;
2916 scm_bigequal (SCM x
, SCM y
)
2919 if (0 == scm_bigcomp (x
, y
))
2926 scm_real_equalp (SCM x
, SCM y
)
2928 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2932 scm_complex_equalp (SCM x
, SCM y
)
2934 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2935 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2940 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2941 /* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2942 * "else. Note that the sets of complex, real, rational and\n"
2943 * "integer values form subsets of the set of numbers, i. e. the\n"
2944 * "predicate will be fulfilled for any number."
2946 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2948 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
2949 "else. Note that the sets of real, rational and integer\n"
2950 "values form subsets of the set of complex numbers, i. e. the\n"
2951 "predicate will also be fulfilled if @var{x} is a real,\n"
2952 "rational or integer number.")
2953 #define FUNC_NAME s_scm_number_p
2955 return SCM_BOOL (SCM_NUMBERP (x
));
2960 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2961 /* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n"
2962 * "Note that the sets of integer and rational values form a subset\n"
2963 * "of the set of real numbers, i. e. the predicate will also\n"
2964 * "be fulfilled if @var{x} is an integer or a rational number."
2966 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2968 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
2969 "else. Note that the set of integer values forms a subset of\n"
2970 "the set of rational numbers, i. e. the predicate will also be\n"
2971 "fulfilled if @var{x} is an integer number. Real numbers\n"
2972 "will also satisfy this predicate, because of their limited\n"
2974 #define FUNC_NAME s_scm_real_p
2976 if (SCM_INUMP (x
)) {
2978 } else if (SCM_IMP (x
)) {
2980 } else if (SCM_SLOPPY_REALP (x
)) {
2982 } else if (SCM_BIGP (x
)) {
2991 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2993 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2995 #define FUNC_NAME s_scm_integer_p
3004 if (!SCM_SLOPPY_INEXACTP (x
))
3006 if (SCM_SLOPPY_COMPLEXP (x
))
3008 r
= SCM_REAL_VALUE (x
);
3016 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
3018 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
3020 #define FUNC_NAME s_scm_inexact_p
3022 return SCM_BOOL (SCM_INEXACTP (x
));
3027 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
3028 /* "Return @code{#t} if all parameters are numerically equal." */
3030 scm_num_eq_p (SCM x
, SCM y
)
3032 if (SCM_INUMP (x
)) {
3033 long xx
= SCM_INUM (x
);
3034 if (SCM_INUMP (y
)) {
3035 long yy
= SCM_INUM (y
);
3036 return SCM_BOOL (xx
== yy
);
3037 } else if (SCM_BIGP (y
)) {
3039 } else if (SCM_REALP (y
)) {
3040 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
3041 } else if (SCM_COMPLEXP (y
)) {
3042 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
3043 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3045 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3047 } else if (SCM_BIGP (x
)) {
3048 if (SCM_INUMP (y
)) {
3050 } else if (SCM_BIGP (y
)) {
3051 return SCM_BOOL (0 == scm_bigcomp (x
, y
));
3052 } else if (SCM_REALP (y
)) {
3053 return SCM_BOOL (scm_big2dbl (x
) == SCM_REAL_VALUE (y
));
3054 } else if (SCM_COMPLEXP (y
)) {
3055 return SCM_BOOL ((scm_big2dbl (x
) == SCM_COMPLEX_REAL (y
))
3056 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3058 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3060 } else if (SCM_REALP (x
)) {
3061 if (SCM_INUMP (y
)) {
3062 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
3063 } else if (SCM_BIGP (y
)) {
3064 return SCM_BOOL (SCM_REAL_VALUE (x
) == scm_big2dbl (y
));
3065 } else if (SCM_REALP (y
)) {
3066 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
3067 } else if (SCM_COMPLEXP (y
)) {
3068 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
3069 && (0.0 == SCM_COMPLEX_IMAG (y
)));
3071 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3073 } else if (SCM_COMPLEXP (x
)) {
3074 if (SCM_INUMP (y
)) {
3075 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
3076 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3077 } else if (SCM_BIGP (y
)) {
3078 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == scm_big2dbl (y
))
3079 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3080 } else if (SCM_REALP (y
)) {
3081 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
3082 && (SCM_COMPLEX_IMAG (x
) == 0.0));
3083 } else if (SCM_COMPLEXP (y
)) {
3084 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
3085 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
3087 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
3090 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
3095 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
3096 /* "Return @code{#t} if the list of parameters is monotonically\n"
3100 scm_less_p (SCM x
, SCM y
)
3102 if (SCM_INUMP (x
)) {
3103 long xx
= SCM_INUM (x
);
3104 if (SCM_INUMP (y
)) {
3105 long yy
= SCM_INUM (y
);
3106 return SCM_BOOL (xx
< yy
);
3107 } else if (SCM_BIGP (y
)) {
3108 return SCM_BOOL (!SCM_BIGSIGN (y
));
3109 } else if (SCM_REALP (y
)) {
3110 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
3112 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3114 } else if (SCM_BIGP (x
)) {
3115 if (SCM_INUMP (y
)) {
3116 return SCM_BOOL (SCM_BIGSIGN (x
));
3117 } else if (SCM_BIGP (y
)) {
3118 return SCM_BOOL (1 == scm_bigcomp (x
, y
));
3119 } else if (SCM_REALP (y
)) {
3120 return SCM_BOOL (scm_big2dbl (x
) < SCM_REAL_VALUE (y
));
3122 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3124 } else if (SCM_REALP (x
)) {
3125 if (SCM_INUMP (y
)) {
3126 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3127 } else if (SCM_BIGP (y
)) {
3128 return SCM_BOOL (SCM_REAL_VALUE (x
) < scm_big2dbl (y
));
3129 } else if (SCM_REALP (y
)) {
3130 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3132 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3135 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3140 SCM_GPROC1 (s_scm_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
, g_gr_p
);
3141 /* "Return @code{#t} if the list of parameters is monotonically\n"
3144 #define FUNC_NAME s_scm_gr_p
3146 scm_gr_p (SCM x
, SCM y
)
3148 if (!SCM_NUMBERP (x
))
3149 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3150 else if (!SCM_NUMBERP (y
))
3151 SCM_WTA_DISPATCH_2 (g_gr_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3153 return scm_less_p (y
, x
);
3158 SCM_GPROC1 (s_scm_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
, g_leq_p
);
3159 /* "Return @code{#t} if the list of parameters is monotonically\n"
3162 #define FUNC_NAME s_scm_leq_p
3164 scm_leq_p (SCM x
, SCM y
)
3166 if (!SCM_NUMBERP (x
))
3167 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3168 else if (!SCM_NUMBERP (y
))
3169 SCM_WTA_DISPATCH_2 (g_leq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3171 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3176 SCM_GPROC1 (s_scm_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
, g_geq_p
);
3177 /* "Return @code{#t} if the list of parameters is monotonically\n"
3180 #define FUNC_NAME s_scm_geq_p
3182 scm_geq_p (SCM x
, SCM y
)
3184 if (!SCM_NUMBERP (x
))
3185 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG1
, FUNC_NAME
);
3186 else if (!SCM_NUMBERP (y
))
3187 SCM_WTA_DISPATCH_2 (g_geq_p
, x
, y
, SCM_ARG2
, FUNC_NAME
);
3189 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3194 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3195 /* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3201 if (SCM_INUMP (z
)) {
3202 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3203 } else if (SCM_BIGP (z
)) {
3205 } else if (SCM_REALP (z
)) {
3206 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3207 } else if (SCM_COMPLEXP (z
)) {
3208 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3209 && SCM_COMPLEX_IMAG (z
) == 0.0);
3211 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3216 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3217 /* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3221 scm_positive_p (SCM x
)
3223 if (SCM_INUMP (x
)) {
3224 return SCM_BOOL (SCM_INUM (x
) > 0);
3225 } else if (SCM_BIGP (x
)) {
3226 return SCM_BOOL (!SCM_BIGSIGN (x
));
3227 } else if (SCM_REALP (x
)) {
3228 return SCM_BOOL(SCM_REAL_VALUE (x
) > 0.0);
3230 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3235 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3236 /* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3240 scm_negative_p (SCM x
)
3242 if (SCM_INUMP (x
)) {
3243 return SCM_BOOL (SCM_INUM (x
) < 0);
3244 } else if (SCM_BIGP (x
)) {
3245 return SCM_BOOL (SCM_BIGSIGN (x
));
3246 } else if (SCM_REALP (x
)) {
3247 return SCM_BOOL(SCM_REAL_VALUE (x
) < 0.0);
3249 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3254 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3255 /* "Return the maximum of all parameter values."
3258 scm_max (SCM x
, SCM y
)
3260 if (SCM_UNBNDP (y
)) {
3261 if (SCM_UNBNDP (x
)) {
3262 SCM_WTA_DISPATCH_0 (g_max
, x
, SCM_ARG1
, s_max
);
3263 } else if (SCM_NUMBERP (x
)) {
3266 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3270 if (SCM_INUMP (x
)) {
3271 long xx
= SCM_INUM (x
);
3272 if (SCM_INUMP (y
)) {
3273 long yy
= SCM_INUM (y
);
3274 return (xx
< yy
) ? y
: x
;
3275 } else if (SCM_BIGP (y
)) {
3276 return SCM_BIGSIGN (y
) ? x
: y
;
3277 } else if (SCM_REALP (y
)) {
3279 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3281 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3283 } else if (SCM_BIGP (x
)) {
3284 if (SCM_INUMP (y
)) {
3285 return SCM_BIGSIGN (x
) ? y
: x
;
3286 } else if (SCM_BIGP (y
)) {
3287 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3288 } else if (SCM_REALP (y
)) {
3289 double z
= scm_big2dbl (x
);
3290 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3292 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3294 } else if (SCM_REALP (x
)) {
3295 if (SCM_INUMP (y
)) {
3296 double z
= SCM_INUM (y
);
3297 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3298 } else if (SCM_BIGP (y
)) {
3299 double z
= scm_big2dbl (y
);
3300 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3301 } else if (SCM_REALP (y
)) {
3302 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? y
: x
;
3304 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3307 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3312 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3313 /* "Return the minium of all parameter values."
3316 scm_min (SCM x
, SCM y
)
3318 if (SCM_UNBNDP (y
)) {
3319 if (SCM_UNBNDP (x
)) {
3320 SCM_WTA_DISPATCH_0 (g_min
, x
, SCM_ARG1
, s_min
);
3321 } else if (SCM_NUMBERP (x
)) {
3324 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
3328 if (SCM_INUMP (x
)) {
3329 long xx
= SCM_INUM (x
);
3330 if (SCM_INUMP (y
)) {
3331 long yy
= SCM_INUM (y
);
3332 return (xx
< yy
) ? x
: y
;
3333 } else if (SCM_BIGP (y
)) {
3334 return SCM_BIGSIGN (y
) ? y
: x
;
3335 } else if (SCM_REALP (y
)) {
3337 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3339 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3341 } else if (SCM_BIGP (x
)) {
3342 if (SCM_INUMP (y
)) {
3343 return SCM_BIGSIGN (x
) ? x
: y
;
3344 } else if (SCM_BIGP (y
)) {
3345 return (-1 == scm_bigcomp (x
, y
)) ? y
: x
;
3346 } else if (SCM_REALP (y
)) {
3347 double z
= scm_big2dbl (x
);
3348 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3350 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3352 } else if (SCM_REALP (x
)) {
3353 if (SCM_INUMP (y
)) {
3354 double z
= SCM_INUM (y
);
3355 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3356 } else if (SCM_BIGP (y
)) {
3357 double z
= scm_big2dbl (y
);
3358 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3359 } else if (SCM_REALP (y
)) {
3360 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? x
: y
;
3362 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3365 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3370 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3371 /* "Return the sum of all parameter values. Return 0 if called without\n"
3375 scm_sum (SCM x
, SCM y
)
3377 if (SCM_UNBNDP (y
)) {
3378 if (SCM_UNBNDP (x
)) {
3380 } else if (SCM_NUMBERP (x
)) {
3383 SCM_WTA_DISPATCH_1 (g_sum
, x
, SCM_ARG1
, s_sum
);
3387 if (SCM_INUMP (x
)) {
3388 long int xx
= SCM_INUM (x
);
3389 if (SCM_INUMP (y
)) {
3390 long int yy
= SCM_INUM (y
);
3391 long int z
= xx
+ yy
;
3392 if (SCM_FIXABLE (z
)) {
3393 return SCM_MAKINUM (z
);
3396 return scm_long2big (z
);
3397 #else /* SCM_BIGDIG */
3398 return scm_make_real ((double) z
);
3399 #endif /* SCM_BIGDIG */
3401 } else if (SCM_BIGP (y
)) {
3404 long int xx
= SCM_INUM (x
);
3405 #ifndef SCM_DIGSTOOBIG
3406 long z
= scm_pseudolong (xx
);
3407 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3408 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3409 #else /* SCM_DIGSTOOBIG */
3410 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3411 scm_longdigs (xx
, zdigs
);
3412 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3413 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, 0);
3414 #endif /* SCM_DIGSTOOBIG */
3416 } else if (SCM_REALP (y
)) {
3417 return scm_make_real (xx
+ SCM_REAL_VALUE (y
));
3418 } else if (SCM_COMPLEXP (y
)) {
3419 return scm_make_complex (xx
+ SCM_COMPLEX_REAL (y
),
3420 SCM_COMPLEX_IMAG (y
));
3422 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3424 } else if (SCM_BIGP (x
)) {
3425 if (SCM_INUMP (y
)) {
3428 } else if (SCM_BIGP (y
)) {
3429 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
)) {
3432 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3433 SCM_BIGSIGN (x
), y
, 0);
3434 } else if (SCM_REALP (y
)) {
3435 return scm_make_real (scm_big2dbl (x
) + SCM_REAL_VALUE (y
));
3436 } else if (SCM_COMPLEXP (y
)) {
3437 return scm_make_complex (scm_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3438 SCM_COMPLEX_IMAG (y
));
3440 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3442 } else if (SCM_REALP (x
)) {
3443 if (SCM_INUMP (y
)) {
3444 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_INUM (y
));
3445 } else if (SCM_BIGP (y
)) {
3446 return scm_make_real (SCM_REAL_VALUE (x
) + scm_big2dbl (y
));
3447 } else if (SCM_REALP (y
)) {
3448 return scm_make_real (SCM_REAL_VALUE (x
) + SCM_REAL_VALUE (y
));
3449 } else if (SCM_COMPLEXP (y
)) {
3450 return scm_make_complex (SCM_REAL_VALUE (x
) + SCM_COMPLEX_REAL (y
),
3451 SCM_COMPLEX_IMAG (y
));
3453 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3455 } else if (SCM_COMPLEXP (x
)) {
3456 if (SCM_INUMP (y
)) {
3457 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_INUM (y
),
3458 SCM_COMPLEX_IMAG (x
));
3459 } else if (SCM_BIGP (y
)) {
3460 return scm_make_complex (SCM_COMPLEX_REAL (x
) + scm_big2dbl (y
),
3461 SCM_COMPLEX_IMAG (x
));
3462 } else if (SCM_REALP (y
)) {
3463 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_REAL_VALUE (y
),
3464 SCM_COMPLEX_IMAG (x
));
3465 } else if (SCM_COMPLEXP (y
)) {
3466 return scm_make_complex (SCM_COMPLEX_REAL (x
) + SCM_COMPLEX_REAL (y
),
3467 SCM_COMPLEX_IMAG (x
) + SCM_COMPLEX_IMAG (y
));
3469 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3472 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3477 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3478 /* "If called without arguments, 0 is returned. Otherwise the sum of\n"
3479 * "all but the first argument are subtracted from the first\n"
3483 scm_difference (SCM x
, SCM y
)
3485 if (SCM_UNBNDP (y
)) {
3486 if (SCM_INUMP (x
)) {
3487 long xx
= -SCM_INUM (x
);
3488 if (SCM_FIXABLE (xx
)) {
3489 return SCM_MAKINUM (xx
);
3492 return scm_long2big (xx
);
3494 return scm_make_real ((double) xx
);
3497 } else if (SCM_BIGP (x
)) {
3498 SCM z
= scm_copybig (x
, !SCM_BIGSIGN (x
));
3499 unsigned int digs
= SCM_NUMDIGS (z
);
3500 unsigned int size
= digs
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
;
3501 return size
<= sizeof (SCM
) ? scm_big2inum (z
, digs
) : z
;
3502 } else if (SCM_REALP (x
)) {
3503 return scm_make_real (-SCM_REAL_VALUE (x
));
3504 } else if (SCM_COMPLEXP (x
)) {
3505 return scm_make_complex (-SCM_COMPLEX_REAL (x
), -SCM_COMPLEX_IMAG (x
));
3507 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3511 if (SCM_INUMP (x
)) {
3512 long int xx
= SCM_INUM (x
);
3513 if (SCM_INUMP (y
)) {
3514 long int yy
= SCM_INUM (y
);
3515 long int z
= xx
- yy
;
3516 if (SCM_FIXABLE (z
)) {
3517 return SCM_MAKINUM (z
);
3520 return scm_long2big (z
);
3522 return scm_make_real ((double) z
);
3525 } else if (SCM_BIGP (y
)) {
3526 #ifndef SCM_DIGSTOOBIG
3527 long z
= scm_pseudolong (xx
);
3528 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3529 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3531 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3532 scm_longdigs (xx
, zdigs
);
3533 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3534 (xx
< 0) ? SCM_BIGSIGNFLAG
: 0, y
, SCM_BIGSIGNFLAG
);
3536 } else if (SCM_REALP (y
)) {
3537 return scm_make_real (xx
- SCM_REAL_VALUE (y
));
3538 } else if (SCM_COMPLEXP (y
)) {
3539 return scm_make_complex (xx
- SCM_COMPLEX_REAL (y
),
3540 -SCM_COMPLEX_IMAG (y
));
3542 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3544 } else if (SCM_BIGP (x
)) {
3545 if (SCM_INUMP (y
)) {
3546 long int yy
= SCM_INUM (y
);
3547 #ifndef SCM_DIGSTOOBIG
3548 long z
= scm_pseudolong (yy
);
3549 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3550 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3552 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3553 scm_longdigs (yy
, zdigs
);
3554 return scm_addbig (zdigs
, SCM_DIGSPERLONG
,
3555 (yy
< 0) ? 0 : SCM_BIGSIGNFLAG
, x
, 0);
3557 } else if (SCM_BIGP (y
)) {
3558 return (SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3559 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3560 SCM_BIGSIGN (x
), y
, SCM_BIGSIGNFLAG
)
3561 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3562 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
, x
, 0);
3563 } else if (SCM_REALP (y
)) {
3564 return scm_make_real (scm_big2dbl (x
) - SCM_REAL_VALUE (y
));
3565 } else if (SCM_COMPLEXP (y
)) {
3566 return scm_make_complex (scm_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3567 - SCM_COMPLEX_IMAG (y
));
3569 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3571 } else if (SCM_REALP (x
)) {
3572 if (SCM_INUMP (y
)) {
3573 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_INUM (y
));
3574 } else if (SCM_BIGP (y
)) {
3575 return scm_make_real (SCM_REAL_VALUE (x
) - scm_big2dbl (y
));
3576 } else if (SCM_REALP (y
)) {
3577 return scm_make_real (SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3578 } else if (SCM_COMPLEXP (y
)) {
3579 return scm_make_complex (SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3580 -SCM_COMPLEX_IMAG (y
));
3582 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3584 } else if (SCM_COMPLEXP (x
)) {
3585 if (SCM_INUMP (y
)) {
3586 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_INUM (y
),
3587 SCM_COMPLEX_IMAG (x
));
3588 } else if (SCM_BIGP (y
)) {
3589 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_big2dbl (y
),
3590 SCM_COMPLEX_IMAG (x
));
3591 } else if (SCM_REALP (y
)) {
3592 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3593 SCM_COMPLEX_IMAG (x
));
3594 } else if (SCM_COMPLEXP (y
)) {
3595 return scm_make_complex (SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3596 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3598 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3601 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3606 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3607 /* "Return the product of all arguments. If called without arguments,\n"
3611 scm_product (SCM x
, SCM y
)
3613 if (SCM_UNBNDP (y
)) {
3614 if (SCM_UNBNDP (x
)) {
3615 return SCM_MAKINUM (1L);
3616 } else if (SCM_NUMBERP (x
)) {
3619 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3623 if (SCM_INUMP (x
)) {
3631 } else if (xx
== 1) {
3635 if (SCM_INUMP (y
)) {
3636 long yy
= SCM_INUM (y
);
3638 SCM k
= SCM_MAKINUM (kk
);
3639 if (kk
!= SCM_INUM (k
) || kk
/ xx
!= yy
) {
3641 int sgn
= (xx
< 0) ^ (yy
< 0);
3642 #ifndef SCM_DIGSTOOBIG
3643 long i
= scm_pseudolong (xx
);
3644 long j
= scm_pseudolong (yy
);
3645 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3646 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3647 #else /* SCM_DIGSTOOBIG */
3648 SCM_BIGDIG xdigs
[SCM_DIGSPERLONG
];
3649 SCM_BIGDIG ydigs
[SCM_DIGSPERLONG
];
3650 scm_longdigs (xx
, xdigs
);
3651 scm_longdigs (yy
, ydigs
);
3652 return scm_mulbig (xdigs
, SCM_DIGSPERLONG
,
3653 ydigs
, SCM_DIGSPERLONG
,
3657 return scm_make_real (((double) xx
) * ((double) yy
));
3662 } else if (SCM_BIGP (y
)) {
3663 #ifndef SCM_DIGSTOOBIG
3664 long z
= scm_pseudolong (xx
);
3665 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3666 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3667 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3669 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3670 scm_longdigs (xx
, zdigs
);
3671 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3672 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3673 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3675 } else if (SCM_REALP (y
)) {
3676 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3677 } else if (SCM_COMPLEXP (y
)) {
3678 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3679 xx
* SCM_COMPLEX_IMAG (y
));
3681 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3683 } else if (SCM_BIGP (x
)) {
3684 if (SCM_INUMP (y
)) {
3687 } else if (SCM_BIGP (y
)) {
3688 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3689 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3690 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3691 } else if (SCM_REALP (y
)) {
3692 return scm_make_real (scm_big2dbl (x
) * SCM_REAL_VALUE (y
));
3693 } else if (SCM_COMPLEXP (y
)) {
3694 double z
= scm_big2dbl (x
);
3695 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3696 z
* SCM_COMPLEX_IMAG (y
));
3698 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3700 } else if (SCM_REALP (x
)) {
3701 if (SCM_INUMP (y
)) {
3702 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3703 } else if (SCM_BIGP (y
)) {
3704 return scm_make_real (scm_big2dbl (y
) * SCM_REAL_VALUE (x
));
3705 } else if (SCM_REALP (y
)) {
3706 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
3707 } else if (SCM_COMPLEXP (y
)) {
3708 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
3709 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3711 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3713 } else if (SCM_COMPLEXP (x
)) {
3714 if (SCM_INUMP (y
)) {
3715 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3716 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3717 } else if (SCM_BIGP (y
)) {
3718 double z
= scm_big2dbl (y
);
3719 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
3720 z
* SCM_COMPLEX_IMAG (x
));
3721 } else if (SCM_REALP (y
)) {
3722 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3723 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
3724 } else if (SCM_COMPLEXP (y
)) {
3725 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
3726 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
3727 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3728 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3730 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3733 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3739 scm_num2dbl (SCM a
, const char *why
)
3740 #define FUNC_NAME why
3742 if (SCM_INUMP (a
)) {
3743 return (double) SCM_INUM (a
);
3744 } else if (SCM_BIGP (a
)) {
3745 return scm_big2dbl (a
);
3746 } else if (SCM_REALP (a
)) {
3747 return (SCM_REAL_VALUE (a
));
3749 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3755 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3756 /* "Divide the first argument by the product of the remaining arguments."
3759 scm_divide (SCM x
, SCM y
)
3763 if (SCM_UNBNDP (y
)) {
3764 if (SCM_UNBNDP (x
)) {
3765 SCM_WTA_DISPATCH_0 (g_divide
, x
, SCM_ARG1
, s_divide
);
3766 } else if (SCM_INUMP (x
)) {
3767 if (SCM_EQ_P (x
, SCM_MAKINUM (1L)) || SCM_EQ_P (x
, SCM_MAKINUM (-1L))) {
3770 return scm_make_real (1.0 / (double) SCM_INUM (x
));
3772 } else if (SCM_BIGP (x
)) {
3773 return scm_make_real (1.0 / scm_big2dbl (x
));
3774 } else if (SCM_REALP (x
)) {
3775 return scm_make_real (1.0 / SCM_REAL_VALUE (x
));
3776 } else if (SCM_COMPLEXP (x
)) {
3777 double r
= SCM_COMPLEX_REAL (x
);
3778 double i
= SCM_COMPLEX_IMAG (x
);
3779 double d
= r
* r
+ i
* i
;
3780 return scm_make_complex (r
/ d
, -i
/ d
);
3782 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3786 if (SCM_INUMP (x
)) {
3787 long xx
= SCM_INUM (x
);
3788 if (SCM_INUMP (y
)) {
3789 long yy
= SCM_INUM (y
);
3791 scm_num_overflow (s_divide
);
3792 } else if (xx
% yy
!= 0) {
3793 return scm_make_real ((double) xx
/ (double) yy
);
3796 if (SCM_FIXABLE (z
)) {
3797 return SCM_MAKINUM (z
);
3800 return scm_long2big (z
);
3802 return scm_make_real ((double) xx
/ (double) yy
);
3806 } else if (SCM_BIGP (y
)) {
3807 return scm_make_real ((double) xx
/ scm_big2dbl (y
));
3808 } else if (SCM_REALP (y
)) {
3809 return scm_make_real ((double) xx
/ SCM_REAL_VALUE (y
));
3810 } else if (SCM_COMPLEXP (y
)) {
3812 complex_div
: /* y _must_ be a complex number */
3814 double r
= SCM_COMPLEX_REAL (y
);
3815 double i
= SCM_COMPLEX_IMAG (y
);
3816 double d
= r
* r
+ i
* i
;
3817 return scm_make_complex ((a
* r
) / d
, (-a
* i
) / d
);
3820 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3822 } else if (SCM_BIGP (x
)) {
3823 if (SCM_INUMP (y
)) {
3824 long int yy
= SCM_INUM (y
);
3826 scm_num_overflow (s_divide
);
3827 } else if (yy
== 1) {
3830 long z
= yy
< 0 ? -yy
: yy
;
3831 if (z
< SCM_BIGRAD
) {
3832 SCM w
= scm_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
3833 return scm_divbigdig (SCM_BDIGITS (w
), SCM_NUMDIGS (w
),
3835 ? scm_make_real (scm_big2dbl (x
) / (double) yy
)
3839 #ifndef SCM_DIGSTOOBIG
3840 z
= scm_pseudolong (z
);
3841 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3842 (SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3843 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3845 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3846 scm_longdigs (z
, zdigs
);
3847 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3848 zdigs
, SCM_DIGSPERLONG
,
3849 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3851 return (!SCM_UNBNDP (w
))
3853 : scm_make_real (scm_big2dbl (x
) / (double) yy
);
3856 } else if (SCM_BIGP (y
)) {
3857 SCM w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3858 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3859 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 3);
3860 return (!SCM_UNBNDP (w
))
3862 : scm_make_real (scm_big2dbl (x
) / scm_big2dbl (y
));
3863 } else if (SCM_REALP (y
)) {
3864 return scm_make_real (scm_big2dbl (x
) / SCM_REAL_VALUE (y
));
3865 } else if (SCM_COMPLEXP (y
)) {
3866 a
= scm_big2dbl (x
);
3869 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3871 } else if (SCM_REALP (x
)) {
3872 double rx
= SCM_REAL_VALUE (x
);
3873 if (SCM_INUMP (y
)) {
3874 return scm_make_real (rx
/ (double) SCM_INUM (y
));
3875 } else if (SCM_BIGP (y
)) {
3876 return scm_make_real (rx
/ scm_big2dbl (y
));
3877 } else if (SCM_REALP (y
)) {
3878 return scm_make_real (rx
/ SCM_REAL_VALUE (y
));
3879 } else if (SCM_COMPLEXP (y
)) {
3883 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3885 } else if (SCM_COMPLEXP (x
)) {
3886 double rx
= SCM_COMPLEX_REAL (x
);
3887 double ix
= SCM_COMPLEX_IMAG (x
);
3888 if (SCM_INUMP (y
)) {
3889 double d
= SCM_INUM (y
);
3890 return scm_make_complex (rx
/ d
, ix
/ d
);
3891 } else if (SCM_BIGP (y
)) {
3892 double d
= scm_big2dbl (y
);
3893 return scm_make_complex (rx
/ d
, ix
/ d
);
3894 } else if (SCM_REALP (y
)) {
3895 double d
= SCM_REAL_VALUE (y
);
3896 return scm_make_complex (rx
/ d
, ix
/ d
);
3897 } else if (SCM_COMPLEXP (y
)) {
3898 double ry
= SCM_COMPLEX_REAL (y
);
3899 double iy
= SCM_COMPLEX_IMAG (y
);
3900 double d
= ry
* ry
+ iy
* iy
;
3901 return scm_make_complex ((rx
* ry
+ ix
* iy
) / d
,
3902 (ix
* ry
- rx
* iy
) / d
);
3904 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3907 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
3912 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
3913 /* "Return the inverse hyperbolic sine of @var{x}."
3916 scm_asinh (double x
)
3918 return log (x
+ sqrt (x
* x
+ 1));
3924 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
3925 /* "Return the inverse hyperbolic cosine of @var{x}."
3928 scm_acosh (double x
)
3930 return log (x
+ sqrt (x
* x
- 1));
3936 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
3937 /* "Return the inverse hyperbolic tangent of @var{x}."
3940 scm_atanh (double x
)
3942 return 0.5 * log ((1 + x
) / (1 - x
));
3948 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
3949 /* "Round the inexact number @var{x} towards zero."
3952 scm_truncate (double x
)
3961 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
3962 /* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
3963 * "numbers, round towards even."
3966 scm_round (double x
)
3968 double plus_half
= x
+ 0.5;
3969 double result
= floor (plus_half
);
3970 /* Adjust so that the scm_round is towards even. */
3971 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
3972 ? result
- 1 : result
;
3977 SCM_GPROC1 (s_exact_to_inexact
, "exact->inexact", scm_tc7_cxr
, (SCM (*)()) scm_exact_to_inexact
, g_exact_to_inexact
);
3978 /* Convert the number @var{x} to its inexact representation.\n"
3981 scm_exact_to_inexact (double z
)
3987 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
3988 /* "Round the number @var{x} towards minus infinity."
3990 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
3991 /* "Round the number @var{x} towards infinity."
3993 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
3994 /* "Return the square root of the real number @var{x}."
3996 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
3997 /* "Return the absolute value of the real number @var{x}."
3999 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
4000 /* "Return the @var{x}th power of e."
4002 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
4003 /* "Return the natural logarithm of the real number@var{x}."
4005 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
4006 /* "Return the sine of the real number @var{x}."
4008 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
4009 /* "Return the cosine of the real number @var{x}."
4011 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
4012 /* "Return the tangent of the real number @var{x}."
4014 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
4015 /* "Return the arc sine of the real number @var{x}."
4017 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
4018 /* "Return the arc cosine of the real number @var{x}."
4020 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
4021 /* "Return the arc tangent of the real number @var{x}."
4023 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
4024 /* "Return the hyperbolic sine of the real number @var{x}."
4026 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
4027 /* "Return the hyperbolic cosine of the real number @var{x}."
4029 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
4030 /* "Return the hyperbolic tangent of the real number @var{x}."
4038 static void scm_two_doubles (SCM x
,
4040 const char *sstring
,
4044 scm_two_doubles (SCM x
, SCM y
, const char *sstring
, struct dpair
*xy
)
4046 if (SCM_INUMP (x
)) {
4047 xy
->x
= SCM_INUM (x
);
4048 } else if (SCM_BIGP (x
)) {
4049 xy
->x
= scm_big2dbl (x
);
4050 } else if (SCM_REALP (x
)) {
4051 xy
->x
= SCM_REAL_VALUE (x
);
4053 scm_wrong_type_arg (sstring
, SCM_ARG1
, x
);
4056 if (SCM_INUMP (y
)) {
4057 xy
->y
= SCM_INUM (y
);
4058 } else if (SCM_BIGP (y
)) {
4059 xy
->y
= scm_big2dbl (y
);
4060 } else if (SCM_REALP (y
)) {
4061 xy
->y
= SCM_REAL_VALUE (y
);
4063 scm_wrong_type_arg (sstring
, SCM_ARG2
, y
);
4068 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
4070 "Return @var{x} raised to the power of @var{y}. This\n"
4071 "procedure does not accept complex arguments.")
4072 #define FUNC_NAME s_scm_sys_expt
4075 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4076 return scm_make_real (pow (xy
.x
, xy
.y
));
4081 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4083 "Return the arc tangent of the two arguments @var{x} and\n"
4084 "@var{y}. This is similar to calculating the arc tangent of\n"
4085 "@var{x} / @var{y}, except that the signs of both arguments\n"
4086 "are used to determine the quadrant of the result. This\n"
4087 "procedure does not accept complex arguments.")
4088 #define FUNC_NAME s_scm_sys_atan2
4091 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4092 return scm_make_real (atan2 (xy
.x
, xy
.y
));
4097 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4098 (SCM real
, SCM imaginary
),
4099 "Return a complex number constructed of the given @var{real} and\n"
4100 "@var{imaginary} parts.")
4101 #define FUNC_NAME s_scm_make_rectangular
4104 scm_two_doubles (real
, imaginary
, FUNC_NAME
, &xy
);
4105 return scm_make_complex (xy
.x
, xy
.y
);
4111 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4113 "Return the complex number @var{x} * e^(i * @var{y}).")
4114 #define FUNC_NAME s_scm_make_polar
4117 scm_two_doubles (x
, y
, FUNC_NAME
, &xy
);
4118 return scm_make_complex (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
4123 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4124 /* "Return the real part of the number @var{z}."
4127 scm_real_part (SCM z
)
4129 if (SCM_INUMP (z
)) {
4131 } else if (SCM_BIGP (z
)) {
4133 } else if (SCM_REALP (z
)) {
4135 } else if (SCM_COMPLEXP (z
)) {
4136 return scm_make_real (SCM_COMPLEX_REAL (z
));
4138 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4143 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4144 /* "Return the imaginary part of the number @var{z}."
4147 scm_imag_part (SCM z
)
4149 if (SCM_INUMP (z
)) {
4151 } else if (SCM_BIGP (z
)) {
4153 } else if (SCM_REALP (z
)) {
4155 } else if (SCM_COMPLEXP (z
)) {
4156 return scm_make_real (SCM_COMPLEX_IMAG (z
));
4158 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4163 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4164 /* "Return the magnitude of the number @var{z}. This is the same as\n"
4165 * "@code{abs} for real arguments, but also allows complex numbers."
4168 scm_magnitude (SCM z
)
4170 if (SCM_INUMP (z
)) {
4171 long int zz
= SCM_INUM (z
);
4174 } else if (SCM_POSFIXABLE (-zz
)) {
4175 return SCM_MAKINUM (-zz
);
4178 return scm_long2big (-zz
);
4180 scm_num_overflow (s_magnitude
);
4183 } else if (SCM_BIGP (z
)) {
4184 if (!SCM_BIGSIGN (z
)) {
4187 return scm_copybig (z
, 0);
4189 } else if (SCM_REALP (z
)) {
4190 return scm_make_real (fabs (SCM_REAL_VALUE (z
)));
4191 } else if (SCM_COMPLEXP (z
)) {
4192 double r
= SCM_COMPLEX_REAL (z
);
4193 double i
= SCM_COMPLEX_IMAG (z
);
4194 return scm_make_real (sqrt (i
* i
+ r
* r
));
4196 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4201 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
4202 /* "Return the angle of the complex number @var{z}."
4207 if (SCM_INUMP (z
)) {
4208 if (SCM_INUM (z
) >= 0) {
4209 return scm_make_real (atan2 (0.0, 1.0));
4211 return scm_make_real (atan2 (0.0, -1.0));
4213 } else if (SCM_BIGP (z
)) {
4214 if (SCM_BIGSIGN (z
)) {
4215 return scm_make_real (atan2 (0.0, -1.0));
4217 return scm_make_real (atan2 (0.0, 1.0));
4219 } else if (SCM_REALP (z
)) {
4220 return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z
)));
4221 } else if (SCM_COMPLEXP (z
)) {
4222 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z
), SCM_COMPLEX_REAL (z
)));
4224 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
4229 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4231 "Returns an exact number that is numerically closest to @var{z}.")
4232 #define FUNC_NAME s_scm_inexact_to_exact
4234 if (SCM_INUMP (z
)) {
4236 } else if (SCM_BIGP (z
)) {
4238 } else if (SCM_REALP (z
)) {
4239 double u
= floor (SCM_REAL_VALUE (z
) + 0.5);
4241 if (SCM_FIXABLE (lu
)) {
4242 return SCM_MAKINUM (lu
);
4244 } else if (isfinite (u
)) {
4245 return scm_dbl2big (u
);
4248 scm_num_overflow (s_scm_inexact_to_exact
);
4251 SCM_WRONG_TYPE_ARG (1, z
);
4258 /* d must be integer */
4261 scm_dbl2big (double d
)
4267 double u
= (d
< 0) ? -d
: d
;
4268 while (0 != floor (u
))
4273 ans
= scm_mkbig (i
, d
< 0);
4274 digits
= SCM_BDIGITS (ans
);
4282 #ifndef SCM_RECKLESS
4284 scm_num_overflow ("dbl2big");
4295 scm_sizet i
= SCM_NUMDIGS (b
);
4296 SCM_BIGDIG
*digits
= SCM_BDIGITS (b
);
4298 ans
= digits
[i
] + SCM_BIGRAD
* ans
;
4299 if (SCM_BIGSIGN (b
))
4307 scm_long2num (long sl
)
4309 if (!SCM_FIXABLE (sl
))
4312 return scm_long2big (sl
);
4314 return scm_make_real ((double) sl
);
4317 return SCM_MAKINUM (sl
);
4321 #ifdef HAVE_LONG_LONGS
4324 scm_long_long2num (long_long sl
)
4326 if (!SCM_FIXABLE (sl
))
4329 return scm_long_long2big (sl
);
4331 return scm_make_real ((double) sl
);
4336 /* we know that sl fits into an inum */
4337 return SCM_MAKINUM ((scm_bits_t
) sl
);
4341 #endif /* HAVE_LONG_LONGS */
4345 scm_ulong2num (unsigned long sl
)
4347 if (!SCM_POSFIXABLE (sl
))
4350 return scm_ulong2big (sl
);
4352 return scm_make_real ((double) sl
);
4355 return SCM_MAKINUM (sl
);
4360 scm_num2long (SCM num
, char *pos
, const char *s_caller
)
4362 if (SCM_INUMP (num
)) {
4363 return SCM_INUM (num
);
4364 } else if (SCM_BIGP (num
)) {
4366 /* can't use res directly in case num is -2^31. */
4367 unsigned long int pos_res
= 0;
4368 unsigned long int old_res
= 0;
4371 for (l
= SCM_NUMDIGS (num
); l
--;) {
4372 pos_res
= SCM_BIGUP (pos_res
) + SCM_BDIGITS (num
)[l
];
4373 if (pos_res
>= old_res
) {
4377 scm_out_of_range (s_caller
, num
);
4380 if (SCM_BIGSIGN (num
)) {
4385 scm_out_of_range (s_caller
, num
);
4392 scm_out_of_range (s_caller
, num
);
4395 } else if (SCM_REALP (num
)) {
4396 double u
= SCM_REAL_VALUE (num
);
4398 if ((double) res
== u
) {
4401 scm_out_of_range (s_caller
, num
);
4404 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4409 #ifdef HAVE_LONG_LONGS
4412 scm_num2long_long (SCM num
, char *pos
, const char *s_caller
)
4414 if (SCM_INUMP (num
)) {
4415 return SCM_INUM (num
);
4416 } else if (SCM_BIGP (num
)) {
4418 /* can't use res directly in case num is -2^63. */
4419 unsigned long long int pos_res
= 0;
4420 unsigned long long int old_res
= 0;
4423 for (l
= SCM_NUMDIGS (num
); l
--;) {
4424 pos_res
= SCM_LONGLONGBIGUP (pos_res
) + SCM_BDIGITS (num
)[l
];
4425 if (pos_res
>= old_res
) {
4429 scm_out_of_range (s_caller
, num
);
4432 if (SCM_BIGSIGN (num
)) {
4437 scm_out_of_range (s_caller
, num
);
4444 scm_out_of_range (s_caller
, num
);
4447 } else if (SCM_REALP (num
)) {
4448 double u
= SCM_REAL_VALUE (num
);
4449 long long int res
= u
;
4450 if ((double) res
== u
) {
4453 scm_out_of_range (s_caller
, num
);
4456 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4460 #endif /* HAVE_LONG_LONGS */
4464 scm_num2ulong (SCM num
, char *pos
, const char *s_caller
)
4466 if (SCM_INUMP (num
)) {
4467 long nnum
= SCM_INUM (num
);
4471 scm_out_of_range (s_caller
, num
);
4473 } else if (SCM_BIGP (num
)) {
4474 unsigned long int res
= 0;
4477 if (SCM_BIGSIGN (num
))
4478 scm_out_of_range (s_caller
, num
);
4480 for (l
= SCM_NUMDIGS (num
); l
--;) {
4481 if (res
> SCM_BIGDN(ULONG_MAX
))
4482 scm_out_of_range (s_caller
, num
);
4483 res
= SCM_BIGUP (res
) + SCM_BDIGITS (num
)[l
];
4486 } else if (SCM_REALP (num
)) {
4487 double u
= SCM_REAL_VALUE (num
);
4488 unsigned long int res
= u
;
4489 if ((double) res
== u
) {
4492 scm_out_of_range (s_caller
, num
);
4495 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4503 abs_most_negative_fixnum
= scm_long2big (- SCM_MOST_NEGATIVE_FIXNUM
);
4504 scm_permanent_object (abs_most_negative_fixnum
);
4506 /* It may be possible to tune the performance of some algorithms by using
4507 * the following constants to avoid the creation of bignums. Please, before
4508 * using these values, remember the two rules of program optimization:
4509 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
4510 scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
));
4511 scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM
));
4513 scm_add_feature ("complex");
4514 scm_add_feature ("inexact");
4515 scm_flo0
= scm_make_real (0.0);
4517 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4519 { /* determine floating point precision */
4521 double fsum
= 1.0 + f
;
4522 while (fsum
!= 1.0) {
4523 if (++scm_dblprec
> 20) {
4530 scm_dblprec
= scm_dblprec
- 1;
4532 #endif /* DBL_DIG */
4533 #ifndef SCM_MAGIC_SNARFER
4534 #include "libguile/numbers.x"