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 */
49 #include "libguile/_scm.h"
50 #include "libguile/unif.h"
51 #include "libguile/feature.h"
52 #include "libguile/ports.h"
53 #include "libguile/root.h"
54 #include "libguile/smob.h"
55 #include "libguile/strings.h"
56 #include "libguile/vectors.h"
58 #include "libguile/validate.h"
59 #include "libguile/numbers.h"
63 static SCM
scm_divbigbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
);
64 static SCM
scm_divbigint (SCM x
, long z
, int sgn
, int mode
);
67 #define DIGITS '0':case '1':case '2':case '3':case '4':\
68 case '5':case '6':case '7':case '8':case '9'
71 #define SCM_SWAP(x,y) do { SCM __t = x; x = y; y = __t; } while (0)
74 /* IS_INF tests its floating point number for infiniteness
77 #define IS_INF(x) ((x) == (x) / 2)
80 /* Return true if X is not infinite and is not a NaN
83 #define isfinite(x) (!IS_INF (x) && (x) == (x))
89 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
91 "Return #t if X is an exact number, #f otherwise.")
92 #define FUNC_NAME s_scm_exact_p
96 } else if (SCM_BIGP (x
)) {
105 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
107 "Return #t if N is an odd number, #f otherwise.")
108 #define FUNC_NAME s_scm_odd_p
111 return SCM_BOOL ((4 & SCM_UNPACK (n
)) != 0);
112 } else if (SCM_BIGP (n
)) {
113 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) != 0);
115 SCM_WRONG_TYPE_ARG (1, n
);
121 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
123 "Return #t if N is an even number, #f otherwise.")
124 #define FUNC_NAME s_scm_even_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_GPROC (s_abs
, "abs", 1, 0, 0, scm_abs
, g_abs
);
143 long int xx
= SCM_INUM (x
);
146 } else if (SCM_POSFIXABLE (-xx
)) {
147 return SCM_MAKINUM (-xx
);
150 return scm_long2big (-xx
);
152 scm_num_overflow (s_abs
);
155 } else if (SCM_BIGP (x
)) {
156 if (!SCM_BIGSIGN (x
)) {
159 return scm_copybig (x
, 0);
162 SCM_WTA_DISPATCH_1 (g_abs
, x
, 1, s_abs
);
167 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
170 scm_quotient (SCM x
, SCM y
)
173 long xx
= SCM_INUM (x
);
175 long yy
= SCM_INUM (y
);
177 scm_num_overflow (s_quotient
);
180 if (SCM_FIXABLE (z
)) {
181 return SCM_MAKINUM (z
);
184 return scm_long2big (z
);
186 scm_num_overflow (s_quotient
);
190 } else if (SCM_BIGP (y
)) {
193 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
195 } else if (SCM_BIGP (x
)) {
197 long yy
= SCM_INUM (y
);
199 scm_num_overflow (s_quotient
);
200 } else if (yy
== 1) {
203 long z
= yy
< 0 ? -yy
: yy
;
205 if (z
< SCM_BIGRAD
) {
206 SCM sw
= scm_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
207 scm_divbigdig (SCM_BDIGITS (sw
), SCM_NUMDIGS (sw
), (SCM_BIGDIG
) z
);
208 return scm_normbig (sw
);
210 #ifndef SCM_DIGSTOOBIG
211 long w
= scm_pseudolong (z
);
212 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
213 (SCM_BIGDIG
*) & w
, SCM_DIGSPERLONG
,
214 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
216 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
217 scm_longdigs (z
, zdigs
);
218 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
219 zdigs
, SCM_DIGSPERLONG
,
220 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
224 } else if (SCM_BIGP (y
)) {
225 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
226 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
227 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 2);
229 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
232 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
237 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
240 scm_remainder (SCM x
, SCM y
)
244 long yy
= SCM_INUM (y
);
246 scm_num_overflow (s_remainder
);
248 #if (__TURBOC__ == 1)
249 long z
= SCM_INUM (x
) % (yy
< 0 ? -yy
: yy
);
251 long z
= SCM_INUM (x
) % yy
;
253 return SCM_MAKINUM (z
);
255 } else if (SCM_BIGP (y
)) {
258 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
260 } else if (SCM_BIGP (x
)) {
262 long yy
= SCM_INUM (y
);
264 scm_num_overflow (s_remainder
);
266 return scm_divbigint (x
, yy
, SCM_BIGSIGN (x
), 0);
268 } else if (SCM_BIGP (y
)) {
269 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
270 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
273 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
276 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
281 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
284 scm_modulo (SCM x
, SCM y
)
287 long xx
= SCM_INUM (x
);
289 long yy
= SCM_INUM (y
);
291 scm_num_overflow (s_modulo
);
293 #if (__TURBOC__ == 1)
294 long z
= ((yy
< 0) ? -xx
: xx
) % yy
;
298 return SCM_MAKINUM (((yy
< 0) ? (z
> 0) : (z
< 0)) ? z
+ yy
: z
);
300 } else if (SCM_BIGP (y
)) {
301 return (SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0)) ? scm_sum (x
, y
) : x
;
303 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
305 } else if (SCM_BIGP (x
)) {
307 long yy
= SCM_INUM (y
);
309 scm_num_overflow (s_modulo
);
311 return scm_divbigint (x
, yy
, yy
< 0,
312 (SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0)) ? 1 : 0);
314 } else if (SCM_BIGP (y
)) {
315 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
316 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
318 (SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
)) ? 1 : 0);
320 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
323 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
328 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
331 scm_gcd (SCM x
, SCM y
)
333 if (SCM_UNBNDP (y
)) {
334 if (SCM_UNBNDP (x
)) {
344 long xx
= SCM_INUM (x
);
345 long yy
= SCM_INUM (y
);
346 long u
= xx
< 0 ? -xx
: xx
;
347 long v
= yy
< 0 ? -yy
: yy
;
352 } else if (yy
== 0) {
358 /* Determine a common factor 2^k */
359 while (!(1 & (u
| v
))) {
365 /* Now, any factor 2^n can be eliminated */
385 if (SCM_POSFIXABLE (result
)) {
386 return SCM_MAKINUM (result
);
389 return scm_long2big (result
);
391 scm_num_overflow (s_gcd
);
394 } else if (SCM_BIGP (y
)) {
398 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
400 } else if (SCM_BIGP (x
)) {
403 x
= scm_copybig (x
, 0);
406 if (SCM_EQ_P (y
, SCM_INUM0
)) {
411 } else if (SCM_BIGP (y
)) {
413 y
= scm_copybig (y
, 0);
414 switch (scm_bigcomp (x
, y
))
419 SCM t
= scm_remainder (x
, y
);
425 y
= scm_remainder (y
, x
);
427 default: /* x == y */
430 /* instead of the switch, we could just
431 return scm_gcd (y, scm_modulo (x, y)); */
433 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG2
, s_gcd
);
436 SCM_WTA_DISPATCH_2 (g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
441 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
444 scm_lcm (SCM n1
, SCM n2
)
446 if (SCM_UNBNDP (n2
)) {
447 if (SCM_UNBNDP (n1
)) {
448 return SCM_MAKINUM (1L);
450 n2
= SCM_MAKINUM (1L);
455 SCM_GASSERT2 (SCM_INUMP (n1
), g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
456 SCM_GASSERT2 (SCM_INUMP (n2
), g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
458 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_BIGP (n1
),
459 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
460 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_BIGP (n2
),
461 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
465 SCM d
= scm_gcd (n1
, n2
);
466 if (SCM_EQ_P (d
, SCM_INUM0
)) {
469 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
476 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
478 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
482 /* Emulating 2's complement bignums with sign magnitude arithmetic:
487 + + + x (map digit:logand X Y)
488 + - + x (map digit:logand X (lognot (+ -1 Y)))
489 - + + y (map digit:logand (lognot (+ -1 X)) Y)
490 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
495 + + + (map digit:logior X Y)
496 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
497 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
498 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
503 + + + (map digit:logxor X Y)
504 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
505 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
506 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
511 + + (any digit:logand X Y)
512 + - (any digit:logand X (lognot (+ -1 Y)))
513 - + (any digit:logand (lognot (+ -1 X)) Y)
520 SCM
scm_copy_big_dec(SCM b
, int sign
);
521 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
);
522 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
523 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
524 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
);
525 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
527 SCM
scm_copy_big_dec(SCM b
, int sign
)
530 scm_sizet nx
= SCM_NUMDIGS(b
);
532 SCM ans
= scm_mkbig(nx
, sign
);
533 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
534 if SCM_BIGSIGN(b
) do {
536 if (num
< 0) {dst
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
537 else {dst
[i
] = SCM_BIGLO(num
); num
= 0;}
540 while (nx
--) dst
[nx
] = src
[nx
];
544 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
)
548 SCM z
= scm_mkbig(nx
, zsgn
);
549 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
552 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
553 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
555 else do zds
[i
] = x
[i
]; while (++i
< nx
);
559 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
560 /* Assumes nx <= SCM_NUMDIGS(bigy) */
561 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
564 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
565 SCM z
= scm_copy_big_dec (bigy
, xsgn
& SCM_BIGSIGN (bigy
));
566 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
570 if (num
< 0) {zds
[i
] |= num
+ SCM_BIGRAD
; num
= -1;}
571 else {zds
[i
] |= SCM_BIGLO(num
); num
= 0;}
573 /* ========= Need to increment zds now =========== */
577 zds
[i
++] = SCM_BIGLO(num
);
578 num
= SCM_BIGDN(num
);
581 scm_adjbig(z
, 1 + ny
); /* OOPS, overflowed into next digit. */
582 SCM_BDIGITS(z
)[ny
] = 1;
585 else do zds
[i
] = zds
[i
] | x
[i
]; while (++i
< nx
);
589 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
590 /* Assumes nx <= SCM_NUMDIGS(bigy) */
591 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
594 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
595 SCM z
= scm_copy_big_dec(bigy
, xsgn
^ SCM_BIGSIGN(bigy
));
596 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
599 if (num
< 0) {zds
[i
] ^= num
+ SCM_BIGRAD
; num
= -1;}
600 else {zds
[i
] ^= SCM_BIGLO(num
); num
= 0;}
603 zds
[i
] = zds
[i
] ^ x
[i
];
606 if (xsgn
^ SCM_BIGSIGN(bigy
)) {
607 /* ========= Need to increment zds now =========== */
611 zds
[i
++] = SCM_BIGLO(num
);
612 num
= SCM_BIGDN(num
);
613 if (!num
) return scm_normbig(z
);
616 return scm_normbig(z
);
619 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
)
620 /* Assumes nx <= SCM_NUMDIGS(bigy) */
621 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
622 /* return sign equals either 0 or SCM_BIGSIGNFLAG */
629 z
= scm_copy_smaller(x
, nx
, zsgn
);
630 x
= SCM_BDIGITS(bigy
);
631 xsgn
= SCM_BIGSIGN(bigy
);
633 else z
= scm_copy_big_dec(bigy
, zsgn
);
634 zds
= SCM_BDIGITS(z
);
639 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
640 else {zds
[i
] &= SCM_BIGLO(num
); num
= 0;}
642 else do zds
[i
] = zds
[i
] & ~x
[i
]; while (++i
< nx
);
643 /* ========= need to increment zds now =========== */
647 zds
[i
++] = SCM_BIGLO(num
);
648 num
= SCM_BIGDN(num
);
649 if (!num
) return scm_normbig(z
);
654 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
655 else {zds
[i
] &= ~SCM_BIGLO(num
); num
= 0;}
657 else do zds
[i
] = zds
[i
] & x
[i
]; while (++i
< nx
);
658 return scm_normbig(z
);
661 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
662 /* Assumes nx <= SCM_NUMDIGS(bigy) */
663 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
668 if (SCM_BIGSIGN(bigy
) & xsgn
) return SCM_BOOL_T
;
669 if (SCM_NUMDIGS(bigy
) != nx
&& xsgn
) return SCM_BOOL_T
;
670 y
= SCM_BDIGITS(bigy
);
675 if (y
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
679 if (y
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
683 else if SCM_BIGSIGN(bigy
)
687 if (x
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
691 if (x
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
696 do if (x
[i
] & y
[i
]) return SCM_BOOL_T
;
704 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
706 "Returns the integer which is the bit-wise AND of the two integer\n"
710 "(number->string (logand #b1100 #b1010) 2)\n"
711 " @result{} \"1000\"")
712 #define FUNC_NAME s_scm_logand
714 if (SCM_UNBNDP (n2
)) {
715 if (SCM_UNBNDP (n1
)) {
716 return SCM_MAKINUM (-1);
717 } else if (!SCM_NUMBERP (n1
)) {
718 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
720 } else if (SCM_NUMBERP (n1
)) {
723 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
731 if (SCM_INUMP (n1
)) {
732 long nn1
= SCM_INUM (n1
);
733 if (SCM_INUMP (n2
)) {
734 long nn2
= SCM_INUM (n2
);
735 return SCM_MAKINUM (nn1
& nn2
);
736 } else if SCM_BIGP (n2
) {
739 # ifndef SCM_DIGSTOOBIG
740 long z
= scm_pseudolong (nn1
);
741 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
742 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
743 SCM_BIGSIGNFLAG
, n2
);
745 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
746 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
749 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
750 scm_longdigs (nn1
, zdigs
);
751 if ((nn1
< 0) && SCM_BIGSIGN (n2
)) {
752 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
754 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
755 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
760 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
762 } else if (SCM_BIGP (n1
)) {
763 if (SCM_INUMP (n2
)) {
766 } else if (SCM_BIGP (n2
)) {
767 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
770 if ((SCM_BIGSIGN (n1
)) && SCM_BIGSIGN (n2
)) {
771 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
772 SCM_BIGSIGNFLAG
, n2
);
774 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
775 SCM_BIGSIGN (n1
), n2
, 0);
778 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
781 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
787 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
789 "Returns the integer which is the bit-wise OR of the two integer\n"
793 "(number->string (logior #b1100 #b1010) 2)\n"
794 " @result{} \"1110\"\n"
796 #define FUNC_NAME s_scm_logior
798 if (SCM_UNBNDP (n2
)) {
799 if (SCM_UNBNDP (n1
)) {
802 } else if (SCM_NUMBERP (n1
)) {
805 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
813 if (SCM_INUMP (n1
)) {
814 long nn1
= SCM_INUM (n1
);
815 if (SCM_INUMP (n2
)) {
816 long nn2
= SCM_INUM (n2
);
817 return SCM_MAKINUM (nn1
| nn2
);
818 } else if (SCM_BIGP (n2
)) {
821 # ifndef SCM_DIGSTOOBIG
822 long z
= scm_pseudolong (nn1
);
823 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
824 return scm_big_ior ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
825 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
827 return scm_big_and ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
828 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
831 BIGDIG zdigs
[DIGSPERLONG
];
832 scm_longdigs (nn1
, zdigs
);
833 if ((!(nn1
< 0)) && !SCM_BIGSIGN (n2
)) {
834 return scm_big_ior (zdigs
, SCM_DIGSPERLONG
,
835 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
837 return scm_big_and (zdigs
, SCM_DIGSPERLONG
,
838 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
843 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
845 } else if (SCM_BIGP (n1
)) {
846 if (SCM_INUMP (n2
)) {
849 } else if (SCM_BIGP (n2
)) {
850 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
853 if ((!SCM_BIGSIGN (n1
)) && !SCM_BIGSIGN (n2
)) {
854 return scm_big_ior (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
855 SCM_BIGSIGN (n1
), n2
);
857 return scm_big_and (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
858 SCM_BIGSIGN (n1
), n2
, SCM_BIGSIGNFLAG
);
861 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
864 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
870 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
872 "Returns the integer which is the bit-wise XOR of the two integer\n"
876 "(number->string (logxor #b1100 #b1010) 2)\n"
877 " @result{} \"110\"\n"
879 #define FUNC_NAME s_scm_logxor
881 if (SCM_UNBNDP (n2
)) {
882 if (SCM_UNBNDP (n1
)) {
885 } else if (SCM_NUMBERP (n1
)) {
888 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
896 if (SCM_INUMP (n1
)) {
897 long nn1
= SCM_INUM (n1
);
898 if (SCM_INUMP (n2
)) {
899 long nn2
= SCM_INUM (n2
);
900 return SCM_MAKINUM (nn1
^ nn2
);
901 } else if (SCM_BIGP (n2
)) {
904 # ifndef SCM_DIGSTOOBIG
905 long z
= scm_pseudolong (nn1
);
906 return scm_big_xor ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
907 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
909 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
910 scm_longdigs (nn1
, zdigs
);
911 return scm_big_xor (zdigs
, SCM_DIGSPERLONG
,
912 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
916 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
918 } else if (SCM_BIGP (n1
)) {
919 if (SCM_INUMP (n2
)) {
922 } else if (SCM_BIGP (n2
)) {
923 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {
926 return scm_big_xor (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
927 SCM_BIGSIGN (n1
), n2
);
929 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
932 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
938 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
941 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
942 "(logtest #b0100 #b1011) @result{} #f\n"
943 "(logtest #b0100 #b0111) @result{} #t\n"
945 #define FUNC_NAME s_scm_logtest
947 if (SCM_INUMP (n1
)) {
948 long nn1
= SCM_INUM (n1
);
949 if (SCM_INUMP (n2
)) {
950 long nn2
= SCM_INUM (n2
);
951 return SCM_BOOL (nn1
& nn2
);
952 } else if (SCM_BIGP (n2
)) {
955 # ifndef SCM_DIGSTOOBIG
956 long z
= scm_pseudolong (nn1
);
957 return scm_big_test ((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
958 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
960 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
961 scm_longdigs (nn1
, zdigs
);
962 return scm_big_test (zdigs
, SCM_DIGSPERLONG
,
963 (nn1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
967 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
969 } else if (SCM_BIGP (n1
)) {
970 if (SCM_INUMP (n2
)) {
973 } else if (SCM_BIGP (n2
)) {
974 if (SCM_NUMDIGS (n1
) > SCM_NUMDIGS (n2
)) {
977 return scm_big_test (SCM_BDIGITS (n1
), SCM_NUMDIGS (n1
),
978 SCM_BIGSIGN (n1
), n2
);
980 SCM_WRONG_TYPE_ARG (SCM_ARG2
, n2
);
983 SCM_WRONG_TYPE_ARG (SCM_ARG1
, n1
);
989 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
992 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
993 "(logbit? 0 #b1101) @result{} #t\n"
994 "(logbit? 1 #b1101) @result{} #f\n"
995 "(logbit? 2 #b1101) @result{} #t\n"
996 "(logbit? 3 #b1101) @result{} #t\n"
997 "(logbit? 4 #b1101) @result{} #f\n"
999 #define FUNC_NAME s_scm_logbit_p
1001 SCM_ASSERT(SCM_INUMP(index
) && SCM_INUM(index
) >= 0, index
, SCM_ARG1
, FUNC_NAME
);
1004 SCM_ASSERT(SCM_BIGP (j
), j
, SCM_ARG2
, FUNC_NAME
);
1005 if (SCM_NUMDIGS(j
) * SCM_BITSPERDIG
< SCM_INUM(index
)) return SCM_BOOL_F
;
1006 else if SCM_BIGSIGN(j
) {
1009 SCM_BIGDIG
*x
= SCM_BDIGITS(j
);
1010 scm_sizet nx
= SCM_INUM(index
)/SCM_BITSPERDIG
;
1014 return ((1L << (SCM_INUM(index
)%SCM_BITSPERDIG
)) & num
) ? SCM_BOOL_F
: SCM_BOOL_T
;
1015 if (num
< 0) num
= -1;
1019 else return (SCM_BDIGITS(j
)[SCM_INUM(index
)/SCM_BITSPERDIG
] &
1020 (1L << (SCM_INUM(index
)%SCM_BITSPERDIG
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
1023 SCM_ASSERT(SCM_INUMP(j
), j
, SCM_ARG2
, FUNC_NAME
);
1025 return ((1L << SCM_INUM(index
)) & SCM_INUM(j
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
1029 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1031 "Returns the integer which is the 2s-complement of the integer argument.\n\n"
1034 "(number->string (lognot #b10000000) 2)\n"
1035 " @result{} \"-10000001\"\n"
1036 "(number->string (lognot #b0) 2)\n"
1037 " @result{} \"-1\"\n"
1040 #define FUNC_NAME s_scm_lognot
1042 return scm_difference (SCM_MAKINUM (-1L), n
);
1046 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1048 "Returns @var{n} raised to the non-negative integer exponent @var{k}.\n\n"
1051 "(integer-expt 2 5)\n"
1053 "(integer-expt -3 3)\n"
1056 #define FUNC_NAME s_scm_integer_expt
1058 SCM acc
= SCM_MAKINUM (1L);
1061 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1063 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1064 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1066 SCM_VALIDATE_ULONG_COPY (2,k
,i2
);
1070 n
= scm_divide (n
, SCM_UNDEFINED
);
1077 return scm_product (acc
, n
);
1079 acc
= scm_product (acc
, n
);
1080 n
= scm_product (n
, n
);
1086 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1088 "The function ash performs an arithmetic shift left by CNT bits\n"
1089 "(or shift right, if CNT is negative). 'Arithmetic' means, that\n"
1090 "the function does not guarantee to keep the bit structure of N,\n"
1091 "but rather guarantees that the result will always be rounded\n"
1092 "towards minus infinity. Therefore, the results of ash and a\n"
1093 "corresponding bitwise shift will differ if N is negative.\n\n"
1094 "Formally, the function returns an integer equivalent to\n"
1095 "@code{(inexact->exact (floor (* N (expt 2 CNT))))}.@refill\n\n"
1098 "(number->string (ash #b1 3) 2)\n"
1099 " @result{} \"1000\""
1100 "(number->string (ash #b1010 -1) 2)"
1101 " @result{} \"101\""
1103 #define FUNC_NAME s_scm_ash
1108 SCM_VALIDATE_INUM (1, n
)
1110 SCM_VALIDATE_INUM (2, cnt
);
1112 bits_to_shift
= SCM_INUM (cnt
);
1114 if (bits_to_shift
< 0) {
1115 /* Shift right by abs(cnt) bits. This is realized as a division by
1116 div:=2^abs(cnt). However, to guarantee the floor rounding, negative
1117 values require some special treatment.
1119 SCM div
= scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift
));
1120 if (SCM_FALSEP (scm_negative_p (n
)))
1121 return scm_quotient (n
, div
);
1123 return scm_sum (SCM_MAKINUM (-1L),
1124 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1126 /* Shift left is done by multiplication with 2^CNT */
1127 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1129 if (bits_to_shift
< 0)
1130 /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */
1131 return SCM_MAKINUM (SCM_SRS (SCM_INUM (n
), -bits_to_shift
));
1133 /* Shift left, but make sure not to leave the range of inums */
1134 SCM res
= SCM_MAKINUM (SCM_INUM (n
) << cnt
);
1135 if (SCM_INUM (res
) >> cnt
!= SCM_INUM (n
))
1136 scm_num_overflow (FUNC_NAME
);
1143 /* GJB:FIXME: do not use SCMs as integers! */
1144 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1145 (SCM n
, SCM start
, SCM end
),
1146 "Returns the integer composed of the @var{start} (inclusive) through\n"
1147 "@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes\n"
1148 "the 0-th bit in the result.@refill\n\n"
1151 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1152 " @result{} \"1010\"\n"
1153 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1154 " @result{} \"10110\"\n"
1156 #define FUNC_NAME s_scm_bit_extract
1159 SCM_VALIDATE_INUM (1,n
);
1160 SCM_VALIDATE_INUM_MIN_COPY (2,start
,0,istart
);
1161 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1162 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1166 scm_logand (scm_difference (scm_integer_expt (SCM_MAKINUM (2),
1167 SCM_MAKINUM (iend
- istart
)),
1169 scm_ash (n
, SCM_MAKINUM (-istart
)));
1171 SCM_VALIDATE_INUM (1,n
);
1173 return SCM_MAKINUM ((SCM_INUM (n
) >> istart
) & ((1L << (iend
- istart
)) - 1));
1177 static const char scm_logtab
[] = {
1178 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1181 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1183 "Returns the number of bits in integer @var{n}. If integer is positive,\n"
1184 "the 1-bits in its binary representation are counted. If negative, the\n"
1185 "0-bits in its two's-complement binary representation are counted. If 0,\n"
1186 "0 is returned.\n\n"
1189 "(logcount #b10101010)\n"
1196 #define FUNC_NAME s_scm_logcount
1198 register unsigned long c
= 0;
1205 SCM_VALIDATE_BIGINT (1,n
);
1206 if (SCM_BIGSIGN (n
))
1207 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n
));
1208 ds
= SCM_BDIGITS (n
);
1209 for (i
= SCM_NUMDIGS (n
); i
--;)
1210 for (d
= ds
[i
]; d
; d
>>= 4)
1211 c
+= scm_logtab
[15 & d
];
1212 return SCM_MAKINUM (c
);
1215 SCM_VALIDATE_INUM (1,n
);
1217 if ((nn
= SCM_INUM (n
)) < 0)
1219 for (; nn
; nn
>>= 4)
1220 c
+= scm_logtab
[15 & nn
];
1221 return SCM_MAKINUM (c
);
1226 static const char scm_ilentab
[] = {
1227 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1230 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1232 "Returns the number of bits neccessary to represent @var{n}.\n\n"
1235 "(integer-length #b10101010)\n"
1237 "(integer-length 0)\n"
1239 "(integer-length #b1111)\n"
1242 #define FUNC_NAME s_scm_integer_length
1244 register unsigned long c
= 0;
1251 SCM_VALIDATE_BIGINT (1,n
);
1252 if (SCM_BIGSIGN (n
))
1253 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n
));
1254 ds
= SCM_BDIGITS (n
);
1255 d
= ds
[c
= SCM_NUMDIGS (n
) - 1];
1256 for (c
*= SCM_BITSPERDIG
; d
; d
>>= 4)
1259 l
= scm_ilentab
[15 & d
];
1261 return SCM_MAKINUM (c
- 4 + l
);
1264 SCM_VALIDATE_INUM (1,n
);
1266 if ((nn
= SCM_INUM (n
)) < 0)
1268 for (; nn
; nn
>>= 4)
1271 l
= scm_ilentab
[15 & nn
];
1273 return SCM_MAKINUM (c
- 4 + l
);
1279 static const char s_bignum
[] = "bignum";
1282 scm_mkbig (scm_sizet nlen
, int sign
)
1285 /* Cast to long int to avoid signed/unsigned comparison warnings. */
1286 if ((( ((long int) nlen
) << SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
)
1288 scm_wta (SCM_MAKINUM (nlen
), (char *) SCM_NALLOC
, s_bignum
);
1292 SCM_SETCHARS (v
, scm_must_malloc ((long) (nlen
* sizeof (SCM_BIGDIG
)),
1294 SCM_SETNUMDIGS (v
, nlen
, sign
);
1301 scm_big2inum (SCM b
, scm_sizet l
)
1303 unsigned long num
= 0;
1304 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1306 num
= SCM_BIGUP (num
) + tmp
[l
];
1307 if (!SCM_BIGSIGN (b
))
1309 if (SCM_POSFIXABLE (num
))
1310 return SCM_MAKINUM (num
);
1312 else if (SCM_UNEGFIXABLE (num
))
1313 return SCM_MAKINUM (-num
);
1318 static const char s_adjbig
[] = "scm_adjbig";
1321 scm_adjbig (SCM b
, scm_sizet nlen
)
1323 scm_sizet nsiz
= nlen
;
1324 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1325 scm_wta (scm_ulong2num (nsiz
), (char *) SCM_NALLOC
, s_adjbig
);
1331 scm_must_realloc ((char *) SCM_CHARS (b
),
1332 (long) (SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
)),
1333 (long) (nsiz
* sizeof (SCM_BIGDIG
)), s_bignum
));
1335 SCM_SETCHARS (b
, digits
);
1336 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1348 scm_sizet nlen
= SCM_NUMDIGS (b
);
1350 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1352 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1353 while (nlen
-- && !zds
[nlen
]);
1355 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1356 if (SCM_INUMP (b
= scm_big2inum (b
, (scm_sizet
) nlen
)))
1358 if (SCM_NUMDIGS (b
) == nlen
)
1360 return scm_adjbig (b
, (scm_sizet
) nlen
);
1366 scm_copybig (SCM b
, int sign
)
1368 scm_sizet i
= SCM_NUMDIGS (b
);
1369 SCM ans
= scm_mkbig (i
, sign
);
1370 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1379 scm_long2big (long n
)
1383 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, n
< 0);
1384 digits
= SCM_BDIGITS (ans
);
1387 while (i
< SCM_DIGSPERLONG
)
1389 digits
[i
++] = SCM_BIGLO (n
);
1390 n
= SCM_BIGDN ((unsigned long) n
);
1395 #ifdef HAVE_LONG_LONGS
1398 scm_long_long2big (long_long n
)
1408 if ((long long) tn
== n
)
1409 return scm_long2big (tn
);
1415 for (tn
= n
, n_digits
= 0;
1417 ++n_digits
, tn
= SCM_BIGDN ((ulong_long
) tn
))
1422 ans
= scm_mkbig (n_digits
, n
< 0);
1423 digits
= SCM_BDIGITS (ans
);
1426 while (i
< n_digits
)
1428 digits
[i
++] = SCM_BIGLO (n
);
1429 n
= SCM_BIGDN ((ulong_long
) n
);
1437 scm_2ulong2big (unsigned long *np
)
1444 ans
= scm_mkbig (2 * SCM_DIGSPERLONG
, 0);
1445 digits
= SCM_BDIGITS (ans
);
1448 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1450 digits
[i
] = SCM_BIGLO (n
);
1451 n
= SCM_BIGDN ((unsigned long) n
);
1454 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1456 digits
[i
+ SCM_DIGSPERLONG
] = SCM_BIGLO (n
);
1457 n
= SCM_BIGDN ((unsigned long) n
);
1465 scm_ulong2big (unsigned long n
)
1469 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, 0);
1470 digits
= SCM_BDIGITS (ans
);
1471 while (i
< SCM_DIGSPERLONG
)
1473 digits
[i
++] = SCM_BIGLO (n
);
1482 scm_bigcomp (SCM x
, SCM y
)
1484 int xsign
= SCM_BIGSIGN (x
);
1485 int ysign
= SCM_BIGSIGN (y
);
1486 scm_sizet xlen
, ylen
;
1488 /* Look at the signs, first. */
1494 /* They're the same sign, so see which one has more digits. Note
1495 that, if they are negative, the longer number is the lesser. */
1496 ylen
= SCM_NUMDIGS (y
);
1497 xlen
= SCM_NUMDIGS (x
);
1499 return (xsign
) ? -1 : 1;
1501 return (xsign
) ? 1 : -1;
1503 /* They have the same number of digits, so find the most significant
1504 digit where they differ. */
1508 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1509 /* Make the discrimination based on the digit that differs. */
1510 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1512 : (xsign
? 1 : -1));
1515 /* The numbers are identical. */
1519 #ifndef SCM_DIGSTOOBIG
1523 scm_pseudolong (long x
)
1528 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1534 while (i
< SCM_DIGSPERLONG
)
1536 p
.bd
[i
++] = SCM_BIGLO (x
);
1539 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1547 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1552 while (i
< SCM_DIGSPERLONG
)
1554 digs
[i
++] = SCM_BIGLO (x
);
1563 scm_addbig (SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int sgny
)
1565 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1566 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1568 scm_sizet i
= 0, ny
= SCM_NUMDIGS (bigy
);
1569 SCM z
= scm_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1570 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1571 if (xsgn
^ SCM_BIGSIGN (z
))
1575 num
+= (long) zds
[i
] - x
[i
];
1578 zds
[i
] = num
+ SCM_BIGRAD
;
1583 zds
[i
] = SCM_BIGLO (num
);
1588 if (num
&& nx
== ny
)
1592 SCM_SET_CELL_WORD_0 (z
, SCM_CELL_WORD_0 (z
) ^ SCM_BIGSIGNFLAG
);
1595 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1596 zds
[i
++] = SCM_BIGLO (num
);
1597 num
= SCM_BIGDN (num
);
1607 zds
[i
++] = num
+ SCM_BIGRAD
;
1612 zds
[i
++] = SCM_BIGLO (num
);
1621 num
+= (long) zds
[i
] + x
[i
];
1622 zds
[i
++] = SCM_BIGLO (num
);
1623 num
= SCM_BIGDN (num
);
1631 zds
[i
++] = SCM_BIGLO (num
);
1632 num
= SCM_BIGDN (num
);
1638 z
= scm_adjbig (z
, ny
+ 1);
1639 SCM_BDIGITS (z
)[ny
] = num
;
1643 return scm_normbig (z
);
1648 scm_mulbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
)
1650 scm_sizet i
= 0, j
= nx
+ ny
;
1651 unsigned long n
= 0;
1652 SCM z
= scm_mkbig (j
, sgn
);
1653 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1663 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1664 zds
[i
+ j
++] = SCM_BIGLO (n
);
1676 return scm_normbig (z
);
1680 /* Sun's compiler complains about the fact that this function has an
1681 ANSI prototype in numbers.h, but a K&R declaration here, and the
1682 two specify different promotions for the third argument. I'm going
1683 to turn this into an ANSI declaration, and see if anyone complains
1684 about it not being K&R. */
1687 scm_divbigdig (SCM_BIGDIG
* ds
,
1691 register unsigned long t2
= 0;
1694 t2
= SCM_BIGUP (t2
) + ds
[h
];
1704 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1710 register unsigned long t2
= 0;
1711 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1712 scm_sizet nd
= SCM_NUMDIGS (x
);
1714 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1717 return SCM_MAKINUM (sgn
? -t2
: t2
);
1720 #ifndef SCM_DIGSTOOBIG
1721 unsigned long t2
= scm_pseudolong (z
);
1722 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1723 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1726 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1727 scm_longdigs (z
, t2
);
1728 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1729 t2
, SCM_DIGSPERLONG
,
1737 scm_divbigbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
)
1739 /* modes description
1743 3 quotient but returns SCM_UNDEFINED if division is not exact. */
1744 scm_sizet i
= 0, j
= 0;
1746 unsigned long t2
= 0;
1748 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1749 /* algorithm requires nx >= ny */
1753 case 0: /* remainder -- just return x */
1754 z
= scm_mkbig (nx
, sgn
);
1755 zds
= SCM_BDIGITS (z
);
1762 case 1: /* scm_modulo -- return y-x */
1763 z
= scm_mkbig (ny
, sgn
);
1764 zds
= SCM_BDIGITS (z
);
1767 num
+= (long) y
[i
] - x
[i
];
1770 zds
[i
] = num
+ SCM_BIGRAD
;
1785 zds
[i
++] = num
+ SCM_BIGRAD
;
1796 return SCM_INUM0
; /* quotient is zero */
1798 return SCM_UNDEFINED
; /* the division is not exact */
1801 z
= scm_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1802 zds
= SCM_BDIGITS (z
);
1806 ny
--; /* in case y came in as a psuedolong */
1807 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1808 { /* normalize operands */
1809 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1810 newy
= scm_mkbig (ny
, 0);
1811 yds
= SCM_BDIGITS (newy
);
1814 t2
+= (unsigned long) y
[j
] * d
;
1815 yds
[j
++] = SCM_BIGLO (t2
);
1816 t2
= SCM_BIGDN (t2
);
1823 t2
+= (unsigned long) x
[j
] * d
;
1824 zds
[j
++] = SCM_BIGLO (t2
);
1825 t2
= SCM_BIGDN (t2
);
1835 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1837 { /* loop over digits of quotient */
1838 if (zds
[j
] == y
[ny
- 1])
1839 qhat
= SCM_BIGRAD
- 1;
1841 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1848 { /* multiply and subtract */
1849 t2
+= (unsigned long) y
[i
] * qhat
;
1850 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1853 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1858 zds
[j
- ny
+ i
] = num
;
1861 t2
= SCM_BIGDN (t2
);
1864 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1866 { /* "add back" required */
1872 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1873 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1874 num
= SCM_BIGDN (num
);
1885 case 3: /* check that remainder==0 */
1886 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1888 return SCM_UNDEFINED
;
1889 case 2: /* move quotient down in z */
1890 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
1891 for (i
= 0; i
< j
; i
++)
1892 zds
[i
] = zds
[i
+ ny
];
1895 case 1: /* subtract for scm_modulo */
1901 num
+= y
[i
] - zds
[i
];
1905 zds
[i
] = num
+ SCM_BIGRAD
;
1917 case 0: /* just normalize remainder */
1919 scm_divbigdig (zds
, ny
, d
);
1922 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1923 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
1924 if (SCM_INUMP (z
= scm_big2inum (z
, j
)))
1926 return scm_adjbig (z
, j
);
1934 /*** NUMBERS -> STRINGS ***/
1936 static const double fx
[] =
1937 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1938 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1939 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1940 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1946 idbl2str (double f
, char *a
)
1948 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1953 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1972 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1973 make-uniform-vector, from causing infinite loops. */
1977 if (exp
-- < DBL_MIN_10_EXP
)
1983 if (exp
++ > DBL_MAX_10_EXP
)
1998 if (f
+ fx
[wp
] >= 10.0)
2005 dpt
= (exp
+ 9999) % 3;
2009 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2034 if (f
+ fx
[wp
] >= 1.0)
2048 if ((dpt
> 4) && (exp
> 6))
2050 d
= (a
[0] == '-' ? 2 : 1);
2051 for (i
= ch
++; i
> d
; i
--)
2064 if (a
[ch
- 1] == '.')
2065 a
[ch
++] = '0'; /* trailing zero */
2074 for (i
= 10; i
<= exp
; i
*= 10);
2075 for (i
/= 10; i
; i
/= 10)
2077 a
[ch
++] = exp
/ i
+ '0';
2086 iflo2str (SCM flt
, char *str
)
2089 if (SCM_SLOPPY_REALP (flt
))
2090 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2093 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2094 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2096 if (0 <= SCM_COMPLEX_IMAG (flt
))
2098 i
+= idbl2str (SCM_COMPLEX_IMAG (flt
), &str
[i
]);
2105 /* convert a long to a string (unterminated). returns the number of
2106 characters in the result.
2108 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2110 scm_iint2str (long num
, int rad
, char *p
)
2114 unsigned long n
= (num
< 0) ? -num
: num
;
2116 for (n
/= rad
; n
> 0; n
/= rad
)
2133 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2142 big2str (SCM b
, unsigned int radix
)
2144 SCM t
= scm_copybig (b
, 0); /* sign of temp doesn't matter */
2145 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2146 scm_sizet i
= SCM_NUMDIGS (t
);
2147 scm_sizet j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2148 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2149 : (SCM_BITSPERDIG
* i
) + 2;
2151 scm_sizet radct
= 0;
2152 scm_sizet ch
; /* jeh */
2153 SCM_BIGDIG radpow
= 1, radmod
= 0;
2154 SCM ss
= scm_makstr ((long) j
, 0);
2155 char *s
= SCM_CHARS (ss
), c
;
2156 while ((long) radpow
* radix
< SCM_BIGRAD
)
2161 s
[0] = SCM_BIGSIGN (b
) ? '-' : '+';
2162 while ((i
|| radmod
) && j
)
2166 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2174 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2176 ch
= s
[0] == '-' ? 1 : 0; /* jeh */
2179 for (i
= j
; j
< SCM_LENGTH (ss
); j
++)
2180 s
[ch
+ j
- i
] = s
[j
]; /* jeh */
2181 scm_vector_set_length_x (ss
, /* jeh */
2182 SCM_MAKINUM (ch
+ SCM_LENGTH (ss
) - i
));
2185 return scm_return_first (ss
, t
);
2190 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2193 #define FUNC_NAME s_scm_number_to_string
2196 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2199 char num_buf
[SCM_FLOBUFLEN
];
2201 SCM_ASRTGO (SCM_NIMP (x
), badx
);
2203 return big2str (x
, (unsigned int) base
);
2204 #ifndef SCM_RECKLESS
2205 if (!SCM_SLOPPY_INEXACTP (x
))
2212 SCM_ASSERT (SCM_SLOPPY_INEXACTP (x
),
2213 x
, SCM_ARG1
, s_number_to_string
);
2215 return scm_makfromstr (num_buf
, iflo2str (x
, num_buf
), 0);
2218 char num_buf
[SCM_INTBUFLEN
];
2219 return scm_makfromstr (num_buf
,
2220 scm_iint2str (SCM_INUM (x
),
2229 /* These print routines are stubbed here so that scm_repl.c doesn't need
2230 SCM_BIGDIG conditionals */
2233 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2235 char num_buf
[SCM_FLOBUFLEN
];
2236 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2241 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2243 char num_buf
[SCM_FLOBUFLEN
];
2244 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2249 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate
)
2252 exp
= big2str (exp
, (unsigned int) 10);
2253 scm_lfwrite (SCM_CHARS (exp
), (scm_sizet
) SCM_LENGTH (exp
), port
);
2255 scm_ipruk ("bignum", exp
, port
);
2259 /*** END nums->strs ***/
2261 /*** STRINGS -> NUMBERS ***/
2264 scm_small_istr2int (char *str
, long len
, long radix
)
2266 register long n
= 0, ln
;
2271 return SCM_BOOL_F
; /* zero scm_length */
2273 { /* leading sign */
2278 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2283 switch (c
= str
[i
++])
2305 return SCM_BOOL_F
; /* bad digit for radix */
2308 /* Negation is a workaround for HP700 cc bug */
2309 if (n
> ln
|| (-n
> -SCM_MOST_NEGATIVE_FIXNUM
))
2313 return SCM_BOOL_F
; /* not a digit */
2318 if ((n
= -n
) > SCM_MOST_POSITIVE_FIXNUM
)
2320 return SCM_MAKINUM (n
);
2321 ovfl
: /* overflow scheme integer */
2328 scm_istr2int (char *str
, long len
, long radix
)
2331 register scm_sizet k
, blen
= 1;
2335 register SCM_BIGDIG
*ds
;
2336 register unsigned long t2
;
2339 return SCM_BOOL_F
; /* zero scm_length */
2341 /* Short numbers we parse directly into an int, to avoid the overhead
2342 of creating a bignum. */
2344 return scm_small_istr2int (str
, len
, radix
);
2347 j
= 1 + (4 * len
* sizeof (char)) / (SCM_BITSPERDIG
);
2348 else if (10 <= radix
)
2349 j
= 1 + (84 * len
* sizeof (char)) / (SCM_BITSPERDIG
* 25);
2351 j
= 1 + (len
* sizeof (char)) / (SCM_BITSPERDIG
);
2353 { /* leading sign */
2356 if (++i
== (unsigned) len
)
2357 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2359 res
= scm_mkbig (j
, '-' == str
[0]);
2360 ds
= SCM_BDIGITS (res
);
2365 switch (c
= str
[i
++])
2387 return SCM_BOOL_F
; /* bad digit for radix */
2393 /* printf ("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]); */
2394 t2
+= ds
[k
] * radix
;
2395 ds
[k
++] = SCM_BIGLO (t2
);
2396 t2
= SCM_BIGDN (t2
);
2399 scm_num_overflow ("bignum");
2407 return SCM_BOOL_F
; /* not a digit */
2410 while (i
< (unsigned) len
);
2411 if (blen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
2412 if (SCM_INUMP (res
= scm_big2inum (res
, blen
)))
2416 return scm_adjbig (res
, blen
);
2420 scm_istr2flo (char *str
, long len
, long radix
)
2422 register int c
, i
= 0;
2424 double res
= 0.0, tmp
= 0.0;
2430 return SCM_BOOL_F
; /* zero scm_length */
2433 { /* leading sign */
2446 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2448 if (str
[i
] == 'i' || str
[i
] == 'I')
2449 { /* handle `+i' and `-i' */
2450 if (lead_sgn
== 0.0)
2451 return SCM_BOOL_F
; /* must have leading sign */
2453 return SCM_BOOL_F
; /* `i' not last character */
2454 return scm_make_complex (0.0, lead_sgn
);
2457 { /* check initial digits */
2467 goto out1
; /* must be exponent */
2484 return SCM_BOOL_F
; /* bad digit for radix */
2485 res
= res
* radix
+ c
;
2486 flg
= 1; /* res is valid */
2495 /* if true, then we did see a digit above, and res is valid */
2499 /* By here, must have seen a digit,
2500 or must have next char be a `.' with radix==10 */
2502 if (!(str
[i
] == '.' && radix
== 10))
2505 while (str
[i
] == '#')
2506 { /* optional sharps */
2539 tmp
= tmp
* radix
+ c
;
2547 return SCM_BOOL_F
; /* `slash zero' not allowed */
2549 while (str
[i
] == '#')
2550 { /* optional sharps */
2560 { /* decimal point notation */
2562 return SCM_BOOL_F
; /* must be radix 10 */
2569 res
= res
* 10.0 + c
- '0';
2578 return SCM_BOOL_F
; /* no digits before or after decimal point */
2581 while (str
[i
] == '#')
2582 { /* ignore remaining sharps */
2601 int expsgn
= 1, expon
= 0;
2603 return SCM_BOOL_F
; /* only in radix 10 */
2605 return SCM_BOOL_F
; /* bad exponent */
2612 return SCM_BOOL_F
; /* bad exponent */
2614 if (str
[i
] < '0' || str
[i
] > '9')
2615 return SCM_BOOL_F
; /* bad exponent */
2621 expon
= expon
* 10 + c
- '0';
2622 if (expon
> SCM_MAXEXP
)
2623 return SCM_BOOL_F
; /* exponent too large */
2631 point
+= expsgn
* expon
;
2649 /* at this point, we have a legitimate floating point result */
2650 if (lead_sgn
== -1.0)
2653 return scm_make_real (res
);
2655 if (str
[i
] == 'i' || str
[i
] == 'I')
2656 { /* pure imaginary number */
2657 if (lead_sgn
== 0.0)
2658 return SCM_BOOL_F
; /* must have leading sign */
2660 return SCM_BOOL_F
; /* `i' not last character */
2661 return scm_make_complex (0.0, res
);
2673 { /* polar input for complex number */
2674 /* get a `real' for scm_angle */
2675 second
= scm_istr2flo (&str
[i
], (long) (len
- i
), radix
);
2676 if (!SCM_SLOPPY_INEXACTP (second
))
2677 return SCM_BOOL_F
; /* not `real' */
2678 if (SCM_SLOPPY_COMPLEXP (second
))
2679 return SCM_BOOL_F
; /* not `real' */
2680 tmp
= SCM_REALPART (second
);
2681 return scm_make_complex (res
* cos (tmp
), res
* sin (tmp
));
2687 /* at this point, last char must be `i' */
2688 if (str
[len
- 1] != 'i' && str
[len
- 1] != 'I')
2690 /* handles `x+i' and `x-i' */
2692 return scm_make_complex (res
, lead_sgn
);
2693 /* get a `ureal' for complex part */
2694 second
= scm_istr2flo (&str
[i
], (long) ((len
- i
) - 1), radix
);
2695 if (!SCM_INEXACTP (second
))
2696 return SCM_BOOL_F
; /* not `ureal' */
2697 if (SCM_SLOPPY_COMPLEXP (second
))
2698 return SCM_BOOL_F
; /* not `ureal' */
2699 tmp
= SCM_REALPART (second
);
2701 return SCM_BOOL_F
; /* not `ureal' */
2702 return scm_make_complex (res
, (lead_sgn
* tmp
));
2708 scm_istring2number (char *str
, long len
, long radix
)
2712 char ex_p
= 0, rx_p
= 0; /* Only allow 1 exactness and 1 radix prefix */
2715 if (*str
== '+' || *str
== '-') /* Catches lone `+' and `-' for speed */
2718 while ((len
- i
) >= 2 && str
[i
] == '#' && ++i
)
2764 return scm_istr2int (&str
[i
], len
- i
, radix
);
2766 res
= scm_istr2int (&str
[i
], len
- i
, radix
);
2767 if (SCM_NFALSEP (res
))
2770 return scm_istr2flo (&str
[i
], len
- i
, radix
);
2776 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2777 (SCM str
, SCM radix
),
2779 #define FUNC_NAME s_scm_string_to_number
2783 SCM_VALIDATE_ROSTRING (1,str
);
2784 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2785 answer
= scm_istring2number (SCM_ROCHARS (str
),
2788 return scm_return_first (answer
, str
);
2791 /*** END strs->nums ***/
2794 scm_make_real (double x
)
2802 scm_make_complex (double x
, double y
)
2805 SCM_NEWCOMPLEX (z
, x
, y
);
2810 scm_bigequal (SCM x
, SCM y
)
2813 if (0 == scm_bigcomp (x
, y
))
2820 scm_real_equalp (SCM x
, SCM y
)
2822 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2826 scm_complex_equalp (SCM x
, SCM y
)
2828 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2829 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2834 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2836 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2839 #define FUNC_NAME s_scm_number_p
2851 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2854 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2857 #define FUNC_NAME s_scm_real_p
2863 if (SCM_SLOPPY_REALP (x
))
2875 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2878 #define FUNC_NAME s_scm_integer_p
2889 if (!SCM_SLOPPY_INEXACTP (x
))
2891 if (SCM_SLOPPY_COMPLEXP (x
))
2893 r
= SCM_REALPART (x
);
2902 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
2905 #define FUNC_NAME s_scm_inexact_p
2907 return SCM_BOOL (SCM_INEXACTP (x
));
2912 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
2915 scm_num_eq_p (SCM x
, SCM y
)
2917 if (SCM_INUMP (x
)) {
2918 long xx
= SCM_INUM (x
);
2919 if (SCM_INUMP (y
)) {
2920 long yy
= SCM_INUM (y
);
2921 return SCM_BOOL (xx
== yy
);
2922 } else if (SCM_BIGP (y
)) {
2924 } else if (SCM_REALP (y
)) {
2925 return SCM_BOOL ((double) xx
== SCM_REAL_VALUE (y
));
2926 } else if (SCM_COMPLEXP (y
)) {
2927 return SCM_BOOL (((double) xx
== SCM_COMPLEX_REAL (y
))
2928 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2930 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2932 } else if (SCM_BIGP (x
)) {
2933 if (SCM_INUMP (y
)) {
2935 } else if (SCM_BIGP (y
)) {
2936 return SCM_BOOL (0 == scm_bigcomp (x
, y
));
2937 } else if (SCM_REALP (y
)) {
2938 return SCM_BOOL (scm_big2dbl (x
) == SCM_REAL_VALUE (y
));
2939 } else if (SCM_COMPLEXP (y
)) {
2940 return SCM_BOOL ((scm_big2dbl (x
) == SCM_COMPLEX_REAL (y
))
2941 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2943 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2945 } else if (SCM_REALP (x
)) {
2946 if (SCM_INUMP (y
)) {
2947 return SCM_BOOL (SCM_REAL_VALUE (x
) == (double) SCM_INUM (y
));
2948 } else if (SCM_BIGP (y
)) {
2949 return SCM_BOOL (SCM_REAL_VALUE (x
) == scm_big2dbl (y
));
2950 } else if (SCM_REALP (y
)) {
2951 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2952 } else if (SCM_COMPLEXP (y
)) {
2953 return SCM_BOOL ((SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
))
2954 && (0.0 == SCM_COMPLEX_IMAG (y
)));
2956 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2958 } else if (SCM_COMPLEXP (x
)) {
2959 if (SCM_INUMP (y
)) {
2960 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == (double) SCM_INUM (y
))
2961 && (SCM_COMPLEX_IMAG (x
) == 0.0));
2962 } else if (SCM_BIGP (y
)) {
2963 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == scm_big2dbl (y
))
2964 && (SCM_COMPLEX_IMAG (x
) == 0.0));
2965 } else if (SCM_REALP (y
)) {
2966 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
))
2967 && (SCM_COMPLEX_IMAG (x
) == 0.0));
2968 } else if (SCM_COMPLEXP (y
)) {
2969 return SCM_BOOL ((SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
))
2970 && (SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
)));
2972 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2975 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
2980 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
2983 scm_less_p (SCM x
, SCM y
)
2985 if (SCM_INUMP (x
)) {
2986 long xx
= SCM_INUM (x
);
2987 if (SCM_INUMP (y
)) {
2988 long yy
= SCM_INUM (y
);
2989 return SCM_BOOL (xx
< yy
);
2990 } else if (SCM_BIGP (y
)) {
2991 return SCM_BOOL (!SCM_BIGSIGN (y
));
2992 } else if (SCM_REALP (y
)) {
2993 return SCM_BOOL ((double) xx
< SCM_REAL_VALUE (y
));
2995 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
2997 } else if (SCM_BIGP (x
)) {
2998 if (SCM_INUMP (y
)) {
2999 return SCM_BOOL (SCM_BIGSIGN (x
));
3000 } else if (SCM_BIGP (y
)) {
3001 return SCM_BOOL (1 == scm_bigcomp (x
, y
));
3002 } else if (SCM_REALP (y
)) {
3003 return SCM_BOOL (scm_big2dbl (x
) < SCM_REAL_VALUE (y
));
3005 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3007 } else if (SCM_REALP (x
)) {
3008 if (SCM_INUMP (y
)) {
3009 return SCM_BOOL (SCM_REAL_VALUE (x
) < (double) SCM_INUM (y
));
3010 } else if (SCM_BIGP (y
)) {
3011 return SCM_BOOL (SCM_REAL_VALUE (x
) < scm_big2dbl (y
));
3012 } else if (SCM_REALP (y
)) {
3013 return SCM_BOOL (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
));
3015 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3018 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3023 SCM_DEFINE1 (scm_gr_p
, ">", scm_tc7_rpsubr
,
3026 #define FUNC_NAME s_scm_gr_p
3028 return scm_less_p (y
, x
);
3033 SCM_DEFINE1 (scm_leq_p
, "<=", scm_tc7_rpsubr
,
3036 #define FUNC_NAME s_scm_leq_p
3038 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3043 SCM_DEFINE1 (scm_geq_p
, ">=", scm_tc7_rpsubr
,
3046 #define FUNC_NAME s_scm_geq_p
3048 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3053 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3061 SCM_ASRTGO (SCM_NIMP (z
), badz
);
3064 if (!SCM_SLOPPY_INEXACTP (z
))
3067 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3070 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
3071 g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3073 if (SCM_SLOPPY_REALP (z
))
3074 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3076 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3077 && SCM_COMPLEX_IMAG (z
) == 0.0);
3079 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3084 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3087 scm_positive_p (SCM x
)
3092 SCM_ASRTGO (SCM_NIMP (x
), badx
);
3094 return SCM_BOOL (!SCM_BIGSIGN (x
));
3095 if (!SCM_SLOPPY_REALP (x
))
3098 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3101 SCM_GASSERT1 (SCM_SLOPPY_REALP (x
),
3102 g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3104 return SCM_BOOL(SCM_REALPART (x
) > 0.0);
3106 return SCM_BOOL(SCM_INUM(x
) > 0);
3111 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3114 scm_negative_p (SCM x
)
3119 SCM_ASRTGO (SCM_NIMP (x
), badx
);
3121 return SCM_BOOL (SCM_BIGSIGN (x
));
3122 if (!(SCM_SLOPPY_REALP (x
)))
3125 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3128 SCM_GASSERT1 (SCM_SLOPPY_REALP (x
),
3129 g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3131 return SCM_BOOL(SCM_REALPART (x
) < 0.0);
3133 return SCM_BOOL(SCM_INUM(x
) < 0);
3137 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3140 scm_max (SCM x
, SCM y
)
3142 if (SCM_UNBNDP (y
)) {
3143 if (SCM_UNBNDP (x
)) {
3144 SCM_WTA_DISPATCH_0 (g_max
, x
, SCM_ARG1
, s_max
);
3145 } else if (SCM_NUMBERP (x
)) {
3148 SCM_WTA_DISPATCH_1 (g_max
, x
, SCM_ARG1
, s_max
);
3152 if (SCM_INUMP (x
)) {
3153 long xx
= SCM_INUM (x
);
3154 if (SCM_INUMP (y
)) {
3155 long yy
= SCM_INUM (y
);
3156 return (xx
< yy
) ? y
: x
;
3157 } else if (SCM_BIGP (y
)) {
3158 return SCM_BIGSIGN (y
) ? x
: y
;
3159 } else if (SCM_REALP (y
)) {
3161 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3163 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3165 } else if (SCM_BIGP (x
)) {
3166 if (SCM_INUMP (y
)) {
3167 return SCM_BIGSIGN (x
) ? y
: x
;
3168 } else if (SCM_BIGP (y
)) {
3169 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3170 } else if (SCM_REALP (y
)) {
3171 double z
= scm_big2dbl (x
);
3172 return (z
<= SCM_REAL_VALUE (y
)) ? y
: scm_make_real (z
);
3174 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3176 } else if (SCM_REALP (x
)) {
3177 if (SCM_INUMP (y
)) {
3178 double z
= SCM_INUM (y
);
3179 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3180 } else if (SCM_BIGP (y
)) {
3181 double z
= scm_big2dbl (y
);
3182 return (SCM_REAL_VALUE (x
) < z
) ? scm_make_real (z
) : x
;
3183 } else if (SCM_REALP (y
)) {
3184 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? y
: x
;
3186 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3189 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3194 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3197 scm_min (SCM x
, SCM y
)
3199 if (SCM_UNBNDP (y
)) {
3200 if (SCM_UNBNDP (x
)) {
3201 SCM_WTA_DISPATCH_0 (g_min
, x
, SCM_ARG1
, s_min
);
3202 } else if (SCM_NUMBERP (x
)) {
3205 SCM_WTA_DISPATCH_1 (g_min
, x
, SCM_ARG1
, s_min
);
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
) ? x
: y
;
3214 } else if (SCM_BIGP (y
)) {
3215 return SCM_BIGSIGN (y
) ? y
: x
;
3216 } else if (SCM_REALP (y
)) {
3218 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3220 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3222 } else if (SCM_BIGP (x
)) {
3223 if (SCM_INUMP (y
)) {
3224 return SCM_BIGSIGN (x
) ? x
: y
;
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_big2dbl (x
);
3229 return (z
< SCM_REAL_VALUE (y
)) ? scm_make_real (z
) : y
;
3231 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3233 } else if (SCM_REALP (x
)) {
3234 if (SCM_INUMP (y
)) {
3235 double z
= SCM_INUM (y
);
3236 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3237 } else if (SCM_BIGP (y
)) {
3238 double z
= scm_big2dbl (y
);
3239 return (SCM_REAL_VALUE (x
) <= z
) ? x
: scm_make_real (z
);
3240 } else if (SCM_REALP (y
)) {
3241 return (SCM_REAL_VALUE (x
) < SCM_REAL_VALUE (y
)) ? x
: y
;
3243 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3246 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3251 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3254 This is sick, sick, sick code.
3258 scm_sum (SCM x
, SCM y
)
3264 SCM_GASSERT1 (SCM_NUMBERP (x
), g_sum
, x
, SCM_ARG1
, s_sum
);
3273 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3282 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3285 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
))
3289 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3293 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3295 if (SCM_SLOPPY_REALP (y
))
3296 return scm_make_real (scm_big2dbl (x
) + SCM_REAL_VALUE (y
));
3298 return scm_make_complex (scm_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3299 SCM_COMPLEX_IMAG (y
));
3301 # endif /* SCM_BIGDIG */
3302 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3310 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3316 else if (!SCM_SLOPPY_INEXACTP (y
))
3319 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3321 # else /* SCM_BIGDIG */
3322 if (!SCM_SLOPPY_INEXACTP (y
))
3325 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3327 # endif /* SCM_BIGDIG */
3330 if (SCM_SLOPPY_COMPLEXP (x
))
3331 i
= SCM_COMPLEX_IMAG (x
);
3332 if (SCM_SLOPPY_COMPLEXP (y
))
3333 i
+= SCM_COMPLEX_IMAG (y
);
3334 return scm_make_complex (SCM_REALPART (x
) + SCM_REALPART (y
), i
);
3340 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3345 long i
= SCM_INUM (x
);
3346 # ifndef SCM_DIGSTOOBIG
3347 long z
= scm_pseudolong (i
);
3348 return scm_addbig ((SCM_BIGDIG
*) & z
,
3350 (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3352 # else /* SCM_DIGSTOOBIG */
3353 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3354 scm_longdigs (i
, zdigs
);
3355 return scm_addbig (zdigs
, SCM_DIGSPERLONG
, (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3357 # endif /* SCM_DIGSTOOBIG */
3360 # endif /* SCM_BIGDIG */
3361 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3364 return scm_make_real (SCM_INUM (x
) + SCM_REAL_VALUE (y
));
3366 return scm_make_complex (SCM_INUM (x
) + SCM_COMPLEX_REAL (y
),
3367 SCM_COMPLEX_IMAG (y
));
3370 long int i
= SCM_INUM (x
) + SCM_INUM (y
);
3371 if (SCM_FIXABLE (i
))
3372 return SCM_MAKINUM (i
);
3374 return scm_long2big (i
);
3375 #else /* SCM_BIGDIG */
3376 return scm_make_real ((double) i
);
3377 #endif /* SCM_BIGDIG */
3384 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3387 HWN:FIXME:: This is sick,sick, sick code. Rewrite me.
3390 scm_difference (SCM x
, SCM y
)
3399 SCM_GASSERT0 (!SCM_UNBNDP (x
), g_difference
,
3400 scm_makfrom0str (s_difference
), SCM_WNA
, 0);
3402 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3407 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3415 x
= scm_copybig (x
, !SCM_BIGSIGN (x
));
3416 return (SCM_NUMDIGS (x
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
3418 ? scm_big2inum (x
, SCM_NUMDIGS (x
))
3422 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx
);
3423 if (SCM_SLOPPY_REALP (x
))
3424 return scm_make_real (- SCM_REAL_VALUE (x
));
3426 return scm_make_complex (- SCM_COMPLEX_REAL (x
),
3427 - SCM_COMPLEX_IMAG (x
));
3430 return scm_sum (x
, SCM_MAKINUM (- SCM_INUM (y
)));
3432 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3436 return ((SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3437 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3440 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3441 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
,
3443 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3445 return scm_make_real (scm_big2dbl (x
) - SCM_REAL_VALUE (y
));
3447 return scm_make_complex (scm_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3448 - SCM_COMPLEX_IMAG (y
));
3450 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3454 return scm_make_real (SCM_REAL_VALUE (x
) - scm_big2dbl (y
));
3456 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_big2dbl (y
),
3457 SCM_COMPLEX_IMAG (x
));
3459 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3461 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3462 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3466 if (SCM_SLOPPY_COMPLEXP (x
))
3468 if (SCM_SLOPPY_COMPLEXP (y
))
3470 SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3471 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3474 SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3475 SCM_COMPLEX_IMAG (x
));
3479 if (SCM_SLOPPY_COMPLEXP (y
))
3481 SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3482 - SCM_COMPLEX_IMAG (y
));
3484 SCM_NEWREAL (z
, SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3497 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3500 long i
= SCM_INUM (x
);
3501 #ifndef SCM_DIGSTOOBIG
3502 long z
= scm_pseudolong (i
);
3503 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3504 (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3505 y
, SCM_BIGSIGNFLAG
);
3507 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3508 scm_longdigs (i
, zdigs
);
3509 return scm_addbig (zdigs
, SCM_DIGSPERLONG
, (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3510 y
, SCM_BIGSIGNFLAG
);
3513 if (!SCM_SLOPPY_INEXACTP (y
))
3516 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3519 if (!SCM_SLOPPY_INEXACTP (y
))
3522 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3525 if (SCM_SLOPPY_COMPLEXP (y
)) {
3526 return scm_make_complex (SCM_INUM (x
) - SCM_COMPLEX_REAL (y
),
3527 -SCM_COMPLEX_IMAG (y
));
3529 return scm_make_real (SCM_INUM (x
) - SCM_REAL_VALUE (y
));
3532 cx
= SCM_INUM (x
) - SCM_INUM (y
);
3534 if (SCM_FIXABLE (cx
))
3535 return SCM_MAKINUM (cx
);
3537 return scm_long2big (cx
);
3539 return scm_make_real ((double) cx
);
3544 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3547 scm_product (SCM x
, SCM y
)
3549 if (SCM_UNBNDP (y
)) {
3550 if (SCM_UNBNDP (x
)) {
3551 return SCM_MAKINUM (1L);
3552 } else if (SCM_NUMBERP (x
)) {
3555 SCM_WTA_DISPATCH_1 (g_product
, x
, SCM_ARG1
, s_product
);
3559 if (SCM_INUMP (x
)) {
3567 } else if (xx
== 1) {
3571 if (SCM_INUMP (y
)) {
3572 long yy
= SCM_INUM (y
);
3574 SCM k
= SCM_MAKINUM (kk
);
3575 if (kk
!= SCM_INUM (k
) || kk
/ xx
!= yy
) {
3577 int sgn
= (xx
< 0) ^ (yy
< 0);
3578 #ifndef SCM_DIGSTOOBIG
3579 long i
= scm_pseudolong (xx
);
3580 long j
= scm_pseudolong (yy
);
3581 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3582 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3583 #else /* SCM_DIGSTOOBIG */
3584 SCM_BIGDIG xdigs
[SCM_DIGSPERLONG
];
3585 SCM_BIGDIG ydigs
[SCM_DIGSPERLONG
];
3586 scm_longdigs (xx
, xdigs
);
3587 scm_longdigs (yy
, ydigs
);
3588 return scm_mulbig (xdigs
, SCM_DIGSPERLONG
,
3589 ydigs
, SCM_DIGSPERLONG
,
3593 return scm_make_real (((double) xx
) * ((double) yy
));
3598 } else if (SCM_BIGP (y
)) {
3599 #ifndef SCM_DIGSTOOBIG
3600 long z
= scm_pseudolong (xx
);
3601 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3602 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3603 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3605 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3606 scm_longdigs (xx
, zdigs
);
3607 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3608 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3609 SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0));
3611 } else if (SCM_REALP (y
)) {
3612 return scm_make_real (xx
* SCM_REAL_VALUE (y
));
3613 } else if (SCM_COMPLEXP (y
)) {
3614 return scm_make_complex (xx
* SCM_COMPLEX_REAL (y
),
3615 xx
* SCM_COMPLEX_IMAG (y
));
3617 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3619 } else if (SCM_BIGP (x
)) {
3620 if (SCM_INUMP (y
)) {
3623 } else if (SCM_BIGP (y
)) {
3624 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3625 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3626 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3627 } else if (SCM_REALP (y
)) {
3628 return scm_make_real (scm_big2dbl (x
) * SCM_REAL_VALUE (y
));
3629 } else if (SCM_COMPLEXP (y
)) {
3630 double z
= scm_big2dbl (x
);
3631 return scm_make_complex (z
* SCM_COMPLEX_REAL (y
),
3632 z
* SCM_COMPLEX_IMAG (y
));
3634 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3636 } else if (SCM_REALP (x
)) {
3637 if (SCM_INUMP (y
)) {
3638 return scm_make_real (SCM_INUM (y
) * SCM_REAL_VALUE (x
));
3639 } else if (SCM_BIGP (y
)) {
3640 return scm_make_real (scm_big2dbl (y
) * SCM_REAL_VALUE (x
));
3641 } else if (SCM_REALP (y
)) {
3642 return scm_make_real (SCM_REAL_VALUE (x
) * SCM_REAL_VALUE (y
));
3643 } else if (SCM_COMPLEXP (y
)) {
3644 return scm_make_complex (SCM_REAL_VALUE (x
) * SCM_COMPLEX_REAL (y
),
3645 SCM_REAL_VALUE (x
) * SCM_COMPLEX_IMAG (y
));
3647 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3649 } else if (SCM_COMPLEXP (x
)) {
3650 if (SCM_INUMP (y
)) {
3651 return scm_make_complex (SCM_INUM (y
) * SCM_COMPLEX_REAL (x
),
3652 SCM_INUM (y
) * SCM_COMPLEX_IMAG (x
));
3653 } else if (SCM_BIGP (y
)) {
3654 double z
= scm_big2dbl (y
);
3655 return scm_make_complex (z
* SCM_COMPLEX_REAL (x
),
3656 z
* SCM_COMPLEX_IMAG (x
));
3657 } else if (SCM_REALP (y
)) {
3658 return scm_make_complex (SCM_REAL_VALUE (y
) * SCM_COMPLEX_REAL (x
),
3659 SCM_REAL_VALUE (y
) * SCM_COMPLEX_IMAG (x
));
3660 } else if (SCM_COMPLEXP (y
)) {
3661 return scm_make_complex (SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_REAL (y
)
3662 - SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_IMAG (y
),
3663 SCM_COMPLEX_REAL (x
) * SCM_COMPLEX_IMAG (y
)
3664 + SCM_COMPLEX_IMAG (x
) * SCM_COMPLEX_REAL (y
));
3666 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3669 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3675 scm_num2dbl (SCM a
, const char *why
)
3676 #define FUNC_NAME why
3678 if (SCM_INUMP (a
)) {
3679 return (double) SCM_INUM (a
);
3680 } else if (SCM_BIGP (a
)) {
3681 return scm_big2dbl (a
);
3682 } else if (SCM_REALP (a
)) {
3683 return (SCM_REAL_VALUE (a
));
3685 SCM_WRONG_TYPE_ARG (SCM_ARGn
, a
);
3691 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3694 scm_divide (SCM x
, SCM y
)
3698 if (SCM_UNBNDP (y
)) {
3699 if (SCM_UNBNDP (x
)) {
3700 SCM_WTA_DISPATCH_0 (g_divide
, x
, SCM_ARG1
, s_divide
);
3701 } else if (SCM_INUMP (x
)) {
3702 if (SCM_EQ_P (x
, SCM_MAKINUM (1L)) || SCM_EQ_P (x
, SCM_MAKINUM (-1L))) {
3705 return scm_make_real (1.0 / (double) SCM_INUM (x
));
3707 } else if (SCM_BIGP (x
)) {
3708 return scm_make_real (1.0 / scm_big2dbl (x
));
3709 } else if (SCM_REALP (x
)) {
3710 return scm_make_real (1.0 / SCM_REAL_VALUE (x
));
3711 } else if (SCM_COMPLEXP (x
)) {
3712 double r
= SCM_COMPLEX_REAL (x
);
3713 double i
= SCM_COMPLEX_IMAG (x
);
3714 double d
= r
* r
+ i
* i
;
3715 return scm_make_complex (r
/ d
, -i
/ d
);
3717 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3721 if (SCM_INUMP (x
)) {
3722 long xx
= SCM_INUM (x
);
3723 if (SCM_INUMP (y
)) {
3724 long yy
= SCM_INUM (y
);
3726 scm_num_overflow (s_divide
);
3727 } else if (xx
% yy
!= 0) {
3728 return scm_make_real ((double) xx
/ (double) yy
);
3731 if (SCM_FIXABLE (z
)) {
3732 return SCM_MAKINUM (z
);
3735 return scm_long2big (z
);
3737 return scm_make_real ((double) xx
/ (double) yy
);
3741 } else if (SCM_BIGP (y
)) {
3742 return scm_make_real ((double) xx
/ scm_big2dbl (y
));
3743 } else if (SCM_REALP (y
)) {
3744 return scm_make_real ((double) xx
/ SCM_REAL_VALUE (y
));
3745 } else if (SCM_COMPLEXP (y
)) {
3747 complex_div
: /* y _must_ be a complex number */
3749 double r
= SCM_COMPLEX_REAL (y
);
3750 double i
= SCM_COMPLEX_IMAG (y
);
3751 double d
= r
* r
+ i
* i
;
3752 return scm_make_complex ((a
* r
) / d
, (-a
* i
) / d
);
3755 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3757 } else if (SCM_BIGP (x
)) {
3758 if (SCM_INUMP (y
)) {
3759 long int yy
= SCM_INUM (y
);
3761 scm_num_overflow (s_divide
);
3762 } else if (yy
== 1) {
3765 long z
= yy
< 0 ? -yy
: yy
;
3766 if (z
< SCM_BIGRAD
) {
3767 SCM w
= scm_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
3768 return scm_divbigdig (SCM_BDIGITS (w
), SCM_NUMDIGS (w
),
3770 ? scm_make_real (scm_big2dbl (x
) / (double) yy
)
3774 #ifndef SCM_DIGSTOOBIG
3775 z
= scm_pseudolong (z
);
3776 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3777 (SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3778 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3780 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3781 scm_longdigs (z
, zdigs
);
3782 w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3783 zdigs
, SCM_DIGSPERLONG
,
3784 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 3);
3786 return (!SCM_UNBNDP (w
))
3788 : scm_make_real (scm_big2dbl (x
) / (double) yy
);
3791 } else if (SCM_BIGP (y
)) {
3792 SCM w
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3793 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3794 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 3);
3795 return (!SCM_UNBNDP (w
))
3797 : scm_make_real (scm_big2dbl (x
) / scm_big2dbl (y
));
3798 } else if (SCM_REALP (y
)) {
3799 return scm_make_real (scm_big2dbl (x
) / SCM_REAL_VALUE (y
));
3800 } else if (SCM_COMPLEXP (y
)) {
3801 a
= scm_big2dbl (x
);
3804 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3806 } else if (SCM_REALP (x
)) {
3807 double rx
= SCM_REAL_VALUE (x
);
3808 if (SCM_INUMP (y
)) {
3809 return scm_make_real (rx
/ (double) SCM_INUM (y
));
3810 } else if (SCM_BIGP (y
)) {
3811 return scm_make_real (rx
/ scm_big2dbl (y
));
3812 } else if (SCM_REALP (y
)) {
3813 return scm_make_real (rx
/ SCM_REAL_VALUE (y
));
3814 } else if (SCM_COMPLEXP (y
)) {
3818 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3820 } else if (SCM_COMPLEXP (x
)) {
3821 double rx
= SCM_COMPLEX_REAL (x
);
3822 double ix
= SCM_COMPLEX_IMAG (x
);
3823 if (SCM_INUMP (y
)) {
3824 double d
= SCM_INUM (y
);
3825 return scm_make_complex (rx
/ d
, ix
/ d
);
3826 } else if (SCM_BIGP (y
)) {
3827 double d
= scm_big2dbl (y
);
3828 return scm_make_complex (rx
/ d
, ix
/ d
);
3829 } else if (SCM_REALP (y
)) {
3830 double d
= SCM_REAL_VALUE (y
);
3831 return scm_make_complex (rx
/ d
, ix
/ d
);
3832 } else if (SCM_COMPLEXP (y
)) {
3833 double ry
= SCM_COMPLEX_REAL (y
);
3834 double iy
= SCM_COMPLEX_IMAG (y
);
3835 double d
= ry
* ry
+ iy
* iy
;
3836 return scm_make_complex ((rx
* ry
+ ix
* iy
) / d
,
3837 (ix
* ry
- rx
* iy
) / d
);
3839 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3842 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
3847 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
3850 scm_asinh (double x
)
3852 return log (x
+ sqrt (x
* x
+ 1));
3858 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
3861 scm_acosh (double x
)
3863 return log (x
+ sqrt (x
* x
- 1));
3869 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
3872 scm_atanh (double x
)
3874 return 0.5 * log ((1 + x
) / (1 - x
));
3880 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
3883 scm_truncate (double x
)
3892 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
3895 scm_round (double x
)
3897 double plus_half
= x
+ 0.5;
3898 double result
= floor (plus_half
);
3899 /* Adjust so that the scm_round is towards even. */
3900 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
3901 ? result
- 1 : result
;
3906 SCM_GPROC1 (s_exact_to_inexact
, "exact->inexact", scm_tc7_cxr
, (SCM (*)()) scm_exact_to_inexact
, g_exact_to_inexact
);
3909 scm_exact_to_inexact (double z
)
3915 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
3916 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
3917 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
3918 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
3919 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
3920 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
3921 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
3922 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
3923 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
3924 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
3925 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
3926 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
3927 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
3928 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
3929 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
3936 static void scm_two_doubles (SCM z1
,
3938 const char *sstring
,
3942 scm_two_doubles (SCM z1
, SCM z2
, const char *sstring
, struct dpair
*xy
)
3945 xy
->x
= SCM_INUM (z1
);
3949 SCM_ASRTGO (SCM_NIMP (z1
), badz1
);
3951 xy
->x
= scm_big2dbl (z1
);
3954 #ifndef SCM_RECKLESS
3955 if (!SCM_SLOPPY_REALP (z1
))
3956 badz1
:scm_wta (z1
, (char *) SCM_ARG1
, sstring
);
3958 xy
->x
= SCM_REALPART (z1
);
3962 SCM_ASSERT (SCM_SLOPPY_REALP (z1
), z1
, SCM_ARG1
, sstring
);
3963 xy
->x
= SCM_REALPART (z1
);
3968 xy
->y
= SCM_INUM (z2
);
3972 SCM_ASRTGO (SCM_NIMP (z2
), badz2
);
3974 xy
->y
= scm_big2dbl (z2
);
3977 #ifndef SCM_RECKLESS
3978 if (!(SCM_SLOPPY_REALP (z2
)))
3979 badz2
:scm_wta (z2
, (char *) SCM_ARG2
, sstring
);
3981 xy
->y
= SCM_REALPART (z2
);
3985 SCM_ASSERT (SCM_SLOPPY_REALP (z2
), z2
, SCM_ARG2
, sstring
);
3986 xy
->y
= SCM_REALPART (z2
);
3995 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
3998 #define FUNC_NAME s_scm_sys_expt
4001 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4002 return scm_make_real (pow (xy
.x
, xy
.y
));
4008 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4011 #define FUNC_NAME s_scm_sys_atan2
4014 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4015 return scm_make_real (atan2 (xy
.x
, xy
.y
));
4021 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4024 #define FUNC_NAME s_scm_make_rectangular
4027 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4028 return scm_make_complex (xy
.x
, xy
.y
);
4034 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4037 #define FUNC_NAME s_scm_make_polar
4040 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4041 return scm_make_complex (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
4048 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4051 scm_real_part (SCM z
)
4056 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4059 if (!(SCM_SLOPPY_INEXACTP (z
)))
4062 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4065 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
4066 g_real_part
, z
, SCM_ARG1
, s_real_part
);
4068 if (SCM_SLOPPY_COMPLEXP (z
))
4069 return scm_make_real (SCM_REAL (z
));
4076 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4079 scm_imag_part (SCM z
)
4084 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4087 if (!(SCM_SLOPPY_INEXACTP (z
)))
4090 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4093 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
4094 g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4096 if (SCM_SLOPPY_COMPLEXP (z
))
4097 return scm_make_real (SCM_IMAG (z
));
4103 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4106 scm_magnitude (SCM z
)
4111 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4114 if (!(SCM_SLOPPY_INEXACTP (z
)))
4117 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4120 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
4121 g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4123 if (SCM_SLOPPY_COMPLEXP (z
))
4125 double i
= SCM_IMAG (z
), r
= SCM_REAL (z
);
4126 return scm_make_real (sqrt (i
* i
+ r
* r
));
4128 return scm_make_real (fabs (SCM_REALPART (z
)));
4134 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
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_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4164 #define FUNC_NAME s_scm_inexact_to_exact
4169 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4172 #ifndef SCM_RECKLESS
4173 if (!(SCM_SLOPPY_REALP (z
)))
4180 SCM_VALIDATE_REAL (1,z
);
4184 double u
= floor (SCM_REALPART (z
) + 0.5);
4185 if ((u
<= SCM_MOST_POSITIVE_FIXNUM
) && (-u
<= -SCM_MOST_NEGATIVE_FIXNUM
))
4187 /* Negation is a workaround for HP700 cc bug */
4188 SCM ans
= SCM_MAKINUM ((long) u
);
4189 if (SCM_INUM (ans
) == (long) u
)
4192 SCM_ASRTGO (isfinite (u
), badz
); /* problem? */
4193 return scm_dbl2big (u
);
4196 return SCM_MAKINUM ((long) floor (SCM_REALPART (z
) + 0.5));
4204 /* d must be integer */
4207 scm_dbl2big (double d
)
4213 double u
= (d
< 0) ? -d
: d
;
4214 while (0 != floor (u
))
4219 ans
= scm_mkbig (i
, d
< 0);
4220 digits
= SCM_BDIGITS (ans
);
4228 #ifndef SCM_RECKLESS
4230 scm_num_overflow ("dbl2big");
4241 scm_sizet i
= SCM_NUMDIGS (b
);
4242 SCM_BIGDIG
*digits
= SCM_BDIGITS (b
);
4244 ans
= digits
[i
] + SCM_BIGRAD
* ans
;
4245 if (SCM_BIGSIGN (b
))
4253 scm_long2num (long sl
)
4255 if (!SCM_FIXABLE (sl
))
4258 return scm_long2big (sl
);
4260 return scm_make_real ((double) sl
);
4263 return SCM_MAKINUM (sl
);
4267 #ifdef HAVE_LONG_LONGS
4270 scm_long_long2num (long_long sl
)
4272 if (!SCM_FIXABLE (sl
))
4275 return scm_long_long2big (sl
);
4277 return scm_make_real ((double) sl
);
4282 /* we know that sl fits into an inum */
4283 return SCM_MAKINUM ((scm_bits_t
) sl
);
4291 scm_ulong2num (unsigned long sl
)
4293 if (!SCM_POSFIXABLE (sl
))
4296 return scm_ulong2big (sl
);
4298 return scm_make_real ((double) sl
);
4301 return SCM_MAKINUM (sl
);
4306 scm_num2long (SCM num
, char *pos
, const char *s_caller
)
4310 if (SCM_INUMP (num
))
4312 res
= SCM_INUM (num
);
4315 SCM_ASRTGO (SCM_NIMP (num
), wrong_type_arg
);
4316 if (SCM_SLOPPY_REALP (num
))
4318 volatile double u
= SCM_REALPART (num
);
4328 unsigned long oldres
= 0;
4330 /* can't use res directly in case num is -2^31. */
4331 unsigned long pos_res
= 0;
4333 for (l
= SCM_NUMDIGS (num
); l
--;)
4335 pos_res
= SCM_BIGUP (pos_res
) + SCM_BDIGITS (num
)[l
];
4336 /* check for overflow. */
4337 if (pos_res
< oldres
)
4341 if (SCM_BIGSIGN (num
))
4357 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4359 scm_out_of_range (s_caller
, num
);
4364 #ifdef HAVE_LONG_LONGS
4367 scm_num2long_long (SCM num
, char *pos
, const char *s_caller
)
4371 if (SCM_INUMP (num
))
4373 res
= SCM_INUM (num
);
4376 SCM_ASRTGO (SCM_NIMP (num
), wrong_type_arg
);
4377 if (SCM_SLOPPY_REALP (num
))
4379 double u
= SCM_REALPART (num
);
4382 if ((res
< 0 && u
> 0) || (res
> 0 && u
< 0)) /* check for overflow. */
4390 unsigned long long oldres
= 0;
4392 /* can't use res directly in case num is -2^63. */
4393 unsigned long long pos_res
= 0;
4395 for (l
= SCM_NUMDIGS (num
); l
--;)
4397 pos_res
= SCM_LONGLONGBIGUP (pos_res
) + SCM_BDIGITS (num
)[l
];
4398 /* check for overflow. */
4399 if (pos_res
< oldres
)
4403 if (SCM_BIGSIGN (num
))
4419 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4421 scm_out_of_range (s_caller
, num
);
4428 scm_num2ulong (SCM num
, char *pos
, const char *s_caller
)
4432 if (SCM_INUMP (num
))
4434 if (SCM_INUM (num
) < 0)
4436 res
= SCM_INUM (num
);
4439 SCM_ASRTGO (SCM_NIMP (num
), wrong_type_arg
);
4440 if (SCM_SLOPPY_REALP (num
))
4442 double u
= SCM_REALPART (num
);
4452 unsigned long oldres
= 0;
4456 for (l
= SCM_NUMDIGS (num
); l
--;)
4458 res
= SCM_BIGUP (res
) + SCM_BDIGITS (num
)[l
];
4467 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4469 scm_out_of_range (s_caller
, num
);
4475 add1 (double f
, double *fsum
)
4486 scm_add_feature ("complex");
4487 scm_add_feature ("inexact");
4488 SCM_NEWREAL (scm_flo0
, 0.0);
4490 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4492 { /* determine floating point precision */
4494 double fsum
= 1.0 + f
;
4498 if (++scm_dblprec
> 20)
4502 scm_dblprec
= scm_dblprec
- 1;
4504 #endif /* DBL_DIG */
4505 #include "libguile/numbers.x"