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"
61 #define DIGITS '0':case '1':case '2':case '3':case '4':\
62 case '5':case '6':case '7':case '8':case '9'
65 /* IS_INF tests its floating point number for infiniteness
68 #define IS_INF(x) ((x) == (x) / 2)
71 /* Return true if X is not infinite and is not a NaN
74 #define isfinite(x) (!IS_INF (x) && (x) == (x))
80 SCM_DEFINE (scm_exact_p
, "exact?", 1, 0, 0,
82 "Return #t if X is an exact number, #f otherwise.")
83 #define FUNC_NAME s_scm_exact_p
88 } else if (SCM_BIGP (x
)) {
98 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
100 "Return #t if N is an odd number, #f otherwise.")
101 #define FUNC_NAME s_scm_odd_p
104 return SCM_BOOL ((4 & SCM_UNPACK (n
)) != 0);
106 } else if (SCM_BIGP (n
)) {
107 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) != 0);
110 SCM_WRONG_TYPE_ARG (1, n
);
116 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
118 "Return #t if N is an even number, #f otherwise.")
119 #define FUNC_NAME s_scm_even_p
122 return SCM_BOOL ((4 & SCM_UNPACK (n
)) == 0);
124 } else if (SCM_BIGP (n
)) {
125 return SCM_BOOL ((1 & SCM_BDIGITS (n
) [0]) == 0);
128 SCM_WRONG_TYPE_ARG (1, n
);
134 SCM_GPROC (s_abs
, "abs", 1, 0, 0, scm_abs
, g_abs
);
140 long int xx
= SCM_INUM (x
);
143 } else if (SCM_POSFIXABLE (-xx
)) {
144 return SCM_MAKINUM (-xx
);
147 return scm_long2big (-xx
);
149 scm_num_overflow (s_abs
);
153 } else if (SCM_BIGP (x
)) {
154 if (!SCM_BIGSIGN (x
)) {
157 return scm_copybig (x
, 0);
161 SCM_WTA_DISPATCH_1 (g_abs
, x
, 1, s_abs
);
166 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
169 scm_quotient (SCM x
, SCM y
)
172 long xx
= SCM_INUM (x
);
174 long yy
= SCM_INUM (y
);
176 scm_num_overflow (s_quotient
);
181 #if (__TURBOC__ == 1)
182 long t
= ((yy
< 0) ? -xx
: xx
) % yy
;
186 if ((t
< 0) && (xx
> 0))
188 else if ((t
> 0) && (xx
< 0))
192 if (SCM_FIXABLE (z
)) {
193 return SCM_MAKINUM (z
);
196 return scm_long2big (z
);
198 scm_num_overflow (s_quotient
);
203 } else if (SCM_BIGP (y
)) {
207 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
210 } else if (SCM_BIGP (x
)) {
212 long yy
= SCM_INUM (y
);
214 scm_num_overflow (s_quotient
);
215 } else if (yy
== 1) {
218 long z
= yy
< 0 ? -yy
: yy
;
220 if (z
< SCM_BIGRAD
) {
221 SCM sw
= scm_copybig (x
, SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0));
222 scm_divbigdig (SCM_BDIGITS (sw
), SCM_NUMDIGS (sw
), (SCM_BIGDIG
) z
);
223 return scm_normbig (sw
);
225 #ifndef SCM_DIGSTOOBIG
226 long w
= scm_pseudolong (z
);
227 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
228 (SCM_BIGDIG
*) & w
, SCM_DIGSPERLONG
,
229 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
231 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
232 scm_longdigs (z
, zdigs
);
233 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
234 zdigs
, SCM_DIGSPERLONG
,
235 SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0), 2);
239 } else if (SCM_BIGP (y
)) {
240 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
241 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
242 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 2);
244 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
248 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
253 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
256 scm_remainder (SCM x
, SCM y
)
262 SCM_GASSERT2 (SCM_BIGP (x
),
263 g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
266 SCM_ASRTGO (SCM_BIGP (y
), bady
);
267 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
268 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
271 if (!(z
= SCM_INUM (y
)))
273 return scm_divbigint (x
, z
, SCM_BIGSIGN (x
), 0);
280 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
285 SCM_GASSERT2 (SCM_INUMP (x
), g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
286 SCM_GASSERT2 (SCM_INUMP (y
), g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
288 if (!(z
= SCM_INUM (y
)))
291 scm_num_overflow (s_remainder
);
293 #if (__TURBOC__ == 1)
297 z
= SCM_INUM (x
) % z
;
307 return SCM_MAKINUM (z
);
310 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
313 scm_modulo (SCM x
, SCM y
)
316 long xx
= SCM_INUM (x
);
318 long yy
= SCM_INUM (y
);
320 scm_num_overflow (s_modulo
);
322 #if (__TURBOC__ == 1)
323 long z
= ((yy
< 0) ? -xx
: xx
) % yy
;
327 return SCM_MAKINUM (((yy
< 0) ? (z
> 0) : (z
< 0)) ? z
+ yy
: z
);
332 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
334 return (SCM_BIGSIGN (y
) ? (xx
> 0) : (xx
< 0)) ? scm_sum (x
, y
) : x
;
337 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
342 SCM_GASSERT2 (SCM_BIGP (x
), g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
343 if (SCM_NINUMP (y
)) {
345 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
347 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
348 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
350 (SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
)) ? 1 : 0);
353 long yy
= SCM_INUM (y
);
355 scm_num_overflow (s_modulo
);
357 return scm_divbigint (x
, yy
, yy
< 0,
358 (SCM_BIGSIGN (x
) ? (yy
> 0) : (yy
< 0)) ? 1 : 0);
362 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
367 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
370 scm_gcd (SCM x
, SCM y
)
374 return SCM_UNBNDP (x
) ? SCM_INUM0
: x
;
380 SCM_GASSERT2 (SCM_BIGP (x
),
381 g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
383 x
= scm_copybig (x
, 0);
387 SCM_GASSERT2 (SCM_BIGP (y
),
388 g_gcd
, x
, y
, SCM_ARGn
, s_gcd
);
390 y
= scm_copybig (y
, 0);
391 switch (scm_bigcomp (x
, y
))
396 SCM t
= scm_remainder (x
, y
);
404 y
= scm_remainder (y
, x
);
407 /* instead of the switch, we could just
408 return scm_gcd (y, scm_modulo (x, y)); */
410 if (SCM_EQ_P (y
, SCM_INUM0
))
422 SCM_GASSERT2 (SCM_INUMP (x
), g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
423 SCM_GASSERT2 (SCM_INUMP (y
), g_gcd
, x
, y
, SCM_ARGn
, s_gcd
);
438 for (k
= 1; !(1 & ((int) u
| (int) v
)); k
<<= 1, u
>>= 1, v
>>= 1);
457 if (!SCM_POSFIXABLE (u
))
459 return scm_long2big (u
);
461 scm_num_overflow (s_gcd
);
463 return SCM_MAKINUM (u
);
466 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
469 scm_lcm (SCM n1
, SCM n2
)
473 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_UNBNDP (n1
),
474 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
475 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_UNBNDP (n2
),
476 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
478 SCM_GASSERT2 (SCM_INUMP (n1
)
481 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
482 SCM_GASSERT2 (SCM_INUMP (n2
)
485 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
489 n2
= SCM_MAKINUM (1L);
494 d
= scm_gcd (n1
, n2
);
495 if (SCM_EQ_P (d
, SCM_INUM0
))
497 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
501 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
503 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
507 /* Emulating 2's complement bignums with sign magnitude arithmetic:
512 + + + x (map digit:logand X Y)
513 + - + x (map digit:logand X (lognot (+ -1 Y)))
514 - + + y (map digit:logand (lognot (+ -1 X)) Y)
515 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
520 + + + (map digit:logior X Y)
521 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
522 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
523 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
528 + + + (map digit:logxor X Y)
529 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
530 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
531 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
536 + + (any digit:logand X Y)
537 + - (any digit:logand X (lognot (+ -1 Y)))
538 - + (any digit:logand (lognot (+ -1 X)) Y)
545 SCM
scm_copy_big_dec(SCM b
, int sign
);
546 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
);
547 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
548 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
549 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
);
550 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
552 SCM
scm_copy_big_dec(SCM b
, int sign
)
555 scm_sizet nx
= SCM_NUMDIGS(b
);
557 SCM ans
= scm_mkbig(nx
, sign
);
558 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
559 if SCM_BIGSIGN(b
) do {
561 if (num
< 0) {dst
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
562 else {dst
[i
] = SCM_BIGLO(num
); num
= 0;}
565 while (nx
--) dst
[nx
] = src
[nx
];
569 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
)
573 SCM z
= scm_mkbig(nx
, zsgn
);
574 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
577 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
578 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
580 else do zds
[i
] = x
[i
]; while (++i
< nx
);
584 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
585 /* Assumes nx <= SCM_NUMDIGS(bigy) */
586 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
589 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
590 SCM z
= scm_copy_big_dec (bigy
, xsgn
& SCM_BIGSIGN (bigy
));
591 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
595 if (num
< 0) {zds
[i
] |= num
+ SCM_BIGRAD
; num
= -1;}
596 else {zds
[i
] |= SCM_BIGLO(num
); num
= 0;}
598 /* ========= Need to increment zds now =========== */
602 zds
[i
++] = SCM_BIGLO(num
);
603 num
= SCM_BIGDN(num
);
606 scm_adjbig(z
, 1 + ny
); /* OOPS, overflowed into next digit. */
607 SCM_BDIGITS(z
)[ny
] = 1;
610 else do zds
[i
] = zds
[i
] | x
[i
]; while (++i
< nx
);
614 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
615 /* Assumes nx <= SCM_NUMDIGS(bigy) */
616 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
619 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
620 SCM z
= scm_copy_big_dec(bigy
, xsgn
^ SCM_BIGSIGN(bigy
));
621 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
624 if (num
< 0) {zds
[i
] ^= num
+ SCM_BIGRAD
; num
= -1;}
625 else {zds
[i
] ^= SCM_BIGLO(num
); num
= 0;}
628 zds
[i
] = zds
[i
] ^ x
[i
];
631 if (xsgn
^ SCM_BIGSIGN(bigy
)) {
632 /* ========= Need to increment zds now =========== */
636 zds
[i
++] = SCM_BIGLO(num
);
637 num
= SCM_BIGDN(num
);
638 if (!num
) return scm_normbig(z
);
641 return scm_normbig(z
);
644 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
)
645 /* Assumes nx <= SCM_NUMDIGS(bigy) */
646 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
647 /* return sign equals either 0 or SCM_BIGSIGNFLAG */
654 z
= scm_copy_smaller(x
, nx
, zsgn
);
655 x
= SCM_BDIGITS(bigy
);
656 xsgn
= SCM_BIGSIGN(bigy
);
658 else z
= scm_copy_big_dec(bigy
, zsgn
);
659 zds
= SCM_BDIGITS(z
);
664 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
665 else {zds
[i
] &= SCM_BIGLO(num
); num
= 0;}
667 else do zds
[i
] = zds
[i
] & ~x
[i
]; while (++i
< nx
);
668 /* ========= need to increment zds now =========== */
672 zds
[i
++] = SCM_BIGLO(num
);
673 num
= SCM_BIGDN(num
);
674 if (!num
) return scm_normbig(z
);
679 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
680 else {zds
[i
] &= ~SCM_BIGLO(num
); num
= 0;}
682 else do zds
[i
] = zds
[i
] & x
[i
]; while (++i
< nx
);
683 return scm_normbig(z
);
686 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
687 /* Assumes nx <= SCM_NUMDIGS(bigy) */
688 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
693 if (SCM_BIGSIGN(bigy
) & xsgn
) return SCM_BOOL_T
;
694 if (SCM_NUMDIGS(bigy
) != nx
&& xsgn
) return SCM_BOOL_T
;
695 y
= SCM_BDIGITS(bigy
);
700 if (y
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
704 if (y
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
708 else if SCM_BIGSIGN(bigy
)
712 if (x
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
716 if (x
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
721 do if (x
[i
] & y
[i
]) return SCM_BOOL_T
;
728 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
730 "Returns the integer which is the bit-wise AND of the two integer\n"
734 "(number->string (logand #b1100 #b1010) 2)\n"
735 " @result{} \"1000\"")
736 #define FUNC_NAME s_scm_logand
741 return SCM_MAKINUM (-1);
743 if (!(SCM_NUMBERP (n1
)))
744 badx
: SCM_WTA (SCM_ARG1
, n1
);
751 SCM_ASRTGO(SCM_NIMP(n1
) && SCM_BIGP(n1
), badx
);
752 if SCM_INUMP(n2
) {t
= n1
; n1
= n2
; n2
= t
; goto intbig
;}
753 SCM_ASRTGO(SCM_NIMP(n2
) && SCM_BIGP(n2
), bady
);
754 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {t
= n1
; n1
= n2
; n2
= t
;}
755 if ((SCM_BIGSIGN(n1
)) && SCM_BIGSIGN(n2
))
756 return scm_big_ior (SCM_BDIGITS(n1
),
760 return scm_big_and (SCM_BDIGITS(n1
),
767 # ifndef SCM_RECKLESS
768 if (!(SCM_NIMP(n2
) && SCM_BIGP(n2
)))
769 bady
: SCM_WTA (SCM_ARG2
, n2
);
772 # ifndef SCM_DIGSTOOBIG
773 long z
= scm_pseudolong(SCM_INUM(n1
));
774 if ((n1
< 0) && SCM_BIGSIGN(n2
))
775 return scm_big_ior((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
776 return scm_big_and((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
778 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
779 scm_longdigs(SCM_INUM(n1
), zdigs
);
780 if ((n1
< 0) && SCM_BIGSIGN(n2
))
781 return scm_big_ior(zdigs
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
782 return scm_big_and(zdigs
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
786 SCM_ASRTGO(SCM_INUMP(n1
), badx
);
787 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, FUNC_NAME
);
789 return SCM_MAKINUM(SCM_INUM(n1
) & SCM_INUM(n2
));
793 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
795 "Returns the integer which is the bit-wise OR of the two integer\n"
799 "(number->string (logior #b1100 #b1010) 2)\n"
800 " @result{} \"1110\"\n"
802 #define FUNC_NAME s_scm_logior
809 if (!(SCM_NUMBERP(n1
)))
810 badx
: SCM_WTA(SCM_ARG1
, n1
);
817 SCM_ASRTGO(SCM_NIMP(n1
) && SCM_BIGP(n1
), badx
);
818 if SCM_INUMP(n2
) {t
= n1
; n1
= n2
; n2
= t
; goto intbig
;}
819 SCM_ASRTGO(SCM_NIMP(n2
) && SCM_BIGP(n2
), bady
);
820 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {t
= n1
; n1
= n2
; n2
= t
;}
821 if ((!SCM_BIGSIGN(n1
)) && !SCM_BIGSIGN(n2
))
822 return scm_big_ior(SCM_BDIGITS(n1
), SCM_NUMDIGS(n1
), SCM_BIGSIGN(n1
), n2
);
823 return scm_big_and(SCM_BDIGITS(n1
), SCM_NUMDIGS(n1
), SCM_BIGSIGN(n1
), n2
, SCM_BIGSIGNFLAG
);
826 # ifndef SCM_RECKLESS
827 if (!(SCM_NIMP(n2
) && SCM_BIGP(n2
)))
828 bady
: SCM_WTA(SCM_ARG2
, n2
);
831 # ifndef SCM_DIGSTOOBIG
832 long z
= scm_pseudolong(SCM_INUM(n1
));
833 if ((!(n1
< 0)) && !SCM_BIGSIGN(n2
))
834 return scm_big_ior((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
835 return scm_big_and((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
837 BIGDIG zdigs
[DIGSPERLONG
];
838 scm_longdigs(SCM_INUM(n1
), zdigs
);
839 if ((!(n1
< 0)) && !SCM_BIGSIGN(n2
))
840 return scm_big_ior(zdigs
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
841 return scm_big_and(zdigs
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
845 SCM_ASRTGO(SCM_INUMP(n1
), badx
);
846 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, FUNC_NAME
);
848 return SCM_MAKINUM(SCM_INUM(n1
) | SCM_INUM(n2
));
852 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
854 "Returns the integer which is the bit-wise XOR of the two integer\n"
858 "(number->string (logxor #b1100 #b1010) 2)\n"
859 " @result{} \"110\"\n"
861 #define FUNC_NAME s_scm_logxor
868 if (!(SCM_NUMBERP(n1
)))
869 badx
: SCM_WTA(SCM_ARG1
, n1
);
876 SCM_ASRTGO(SCM_NIMP(n1
) && SCM_BIGP(n1
), badx
);
884 SCM_ASRTGO(SCM_NIMP(n2
) && SCM_BIGP(n2
), bady
);
885 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
))
891 return scm_big_xor(SCM_BDIGITS(n1
), SCM_NUMDIGS(n1
), SCM_BIGSIGN(n1
), n2
);
894 # ifndef SCM_RECKLESS
895 if (!(SCM_NIMP(n2
) && SCM_BIGP(n2
)))
896 bady
: SCM_WTA (SCM_ARG2
, n2
);
900 # ifndef SCM_DIGSTOOBIG
901 long z
= scm_pseudolong(SCM_INUM(n1
));
902 return scm_big_xor((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
904 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
905 scm_longdigs(SCM_INUM(n1
), zdigs
);
906 return scm_big_xor(zdigs
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
911 SCM_ASRTGO(INUMP(n1
), badx
);
912 SCM_ASSERT(INUMP(n2
), n2
, SCM_ARG2
, FUNC_NAME
);
914 return SCM_MAKINUM(SCM_INUM(n1
) ^ SCM_INUM(n2
));
918 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
921 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
922 "(logtest #b0100 #b1011) @result{} #f\n"
923 "(logtest #b0100 #b0111) @result{} #t\n"
925 #define FUNC_NAME s_scm_logtest
928 if (!(SCM_NUMBERP(n1
)))
929 badx
: SCM_WTA(SCM_ARG1
, n1
);
934 SCM_ASRTGO(SCM_NIMP(n1
) && SCM_BIGP(n1
), badx
);
935 if SCM_INUMP(n2
) {t
= n1
; n1
= n2
; n2
= t
; goto intbig
;}
936 SCM_ASRTGO(SCM_NIMP(n2
) && SCM_BIGP(n2
), bady
);
937 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {t
= n1
; n1
= n2
; n2
= t
;}
938 return scm_big_test(SCM_BDIGITS(n1
), SCM_NUMDIGS(n1
), SCM_BIGSIGN(n1
), n2
);
941 # ifndef SCM_RECKLESS
942 if (!(SCM_NIMP(n2
) && SCM_BIGP(n2
)))
943 bady
: SCM_WTA(SCM_ARG2
, n2
);
946 # ifndef SCM_DIGSTOOBIG
947 long z
= scm_pseudolong(SCM_INUM(n1
));
948 return scm_big_test((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
950 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
951 scm_longdigs(SCM_INUM(n1
), zdigs
);
952 return scm_big_test(zdigs
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
956 SCM_ASRTGO(SCM_INUMP(n1
), badx
);
957 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, FUNC_NAME
);
959 return (SCM_INUM(n1
) & SCM_INUM(n2
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
964 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
967 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
968 "(logbit? 0 #b1101) @result{} #t\n"
969 "(logbit? 1 #b1101) @result{} #f\n"
970 "(logbit? 2 #b1101) @result{} #t\n"
971 "(logbit? 3 #b1101) @result{} #t\n"
972 "(logbit? 4 #b1101) @result{} #f\n"
974 #define FUNC_NAME s_scm_logbit_p
976 SCM_ASSERT(SCM_INUMP(index
) && SCM_INUM(index
) >= 0, index
, SCM_ARG1
, FUNC_NAME
);
979 SCM_ASSERT(SCM_NIMP(j
) && SCM_BIGP(j
), j
, SCM_ARG2
, FUNC_NAME
);
980 if (SCM_NUMDIGS(j
) * SCM_BITSPERDIG
< SCM_INUM(index
)) return SCM_BOOL_F
;
981 else if SCM_BIGSIGN(j
) {
984 SCM_BIGDIG
*x
= SCM_BDIGITS(j
);
985 scm_sizet nx
= SCM_INUM(index
)/SCM_BITSPERDIG
;
989 return ((1L << (SCM_INUM(index
)%SCM_BITSPERDIG
)) & num
) ? SCM_BOOL_F
: SCM_BOOL_T
;
990 if (num
< 0) num
= -1;
994 else return (SCM_BDIGITS(j
)[SCM_INUM(index
)/SCM_BITSPERDIG
] &
995 (1L << (SCM_INUM(index
)%SCM_BITSPERDIG
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
998 SCM_ASSERT(SCM_INUMP(j
), j
, SCM_ARG2
, FUNC_NAME
);
1000 return ((1L << SCM_INUM(index
)) & SCM_INUM(j
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
1004 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
1006 "Returns the integer which is the 2s-complement of the integer argument.\n\n"
1009 "(number->string (lognot #b10000000) 2)\n"
1010 " @result{} \"-10000001\"\n"
1011 "(number->string (lognot #b0) 2)\n"
1012 " @result{} \"-1\"\n"
1015 #define FUNC_NAME s_scm_lognot
1017 return scm_difference (SCM_MAKINUM (-1L), n
);
1021 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1023 "Returns @var{n} raised to the non-negative integer exponent @var{k}.\n\n"
1026 "(integer-expt 2 5)\n"
1028 "(integer-expt -3 3)\n"
1031 #define FUNC_NAME s_scm_integer_expt
1033 SCM acc
= SCM_MAKINUM (1L);
1036 if (SCM_EQ_P (n
, SCM_INUM0
) || SCM_EQ_P (n
, acc
))
1038 else if (SCM_EQ_P (n
, SCM_MAKINUM (-1L)))
1039 return SCM_FALSEP (scm_even_p (k
)) ? n
: acc
;
1041 SCM_VALIDATE_ULONG_COPY (2,k
,i2
);
1045 n
= scm_divide (n
, SCM_UNDEFINED
);
1052 return scm_product (acc
, n
);
1054 acc
= scm_product (acc
, n
);
1055 n
= scm_product (n
, n
);
1061 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1063 "The function ash performs an arithmetic shift left by CNT bits\n"
1064 "(or shift right, if CNT is negative). 'Arithmetic' means, that\n"
1065 "the function does not guarantee to keep the bit structure of N,\n"
1066 "but rather guarantees that the result will always be rounded\n"
1067 "towards minus infinity. Therefore, the results of ash and a\n"
1068 "corresponding bitwise shift will differ if N is negative.\n\n"
1069 "Formally, the function returns an integer equivalent to\n"
1070 "@code{(inexact->exact (floor (* N (expt 2 CNT))))}.@refill\n\n"
1073 "(number->string (ash #b1 3) 2)\n"
1074 " @result{} \"1000\""
1075 "(number->string (ash #b1010 -1) 2)"
1076 " @result{} \"101\""
1078 #define FUNC_NAME s_scm_ash
1083 SCM_VALIDATE_INUM (1, n
)
1085 SCM_VALIDATE_INUM (2, cnt
);
1087 bits_to_shift
= SCM_INUM (cnt
);
1089 if (bits_to_shift
< 0) {
1090 /* Shift right by abs(cnt) bits. This is realized as a division by
1091 div:=2^abs(cnt). However, to guarantee the floor rounding, negative
1092 values require some special treatment.
1094 SCM div
= scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift
));
1095 if (SCM_FALSEP (scm_negative_p (n
)))
1096 return scm_quotient (n
, div
);
1098 return scm_sum (SCM_MAKINUM (-1L),
1099 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1101 /* Shift left is done by multiplication with 2^CNT */
1102 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1104 if (bits_to_shift
< 0)
1105 /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */
1106 return SCM_MAKINUM (SCM_SRS (SCM_INUM (n
), -bits_to_shift
));
1108 /* Shift left, but make sure not to leave the range of inums */
1109 SCM res
= SCM_MAKINUM (SCM_INUM (n
) << cnt
);
1110 if (SCM_INUM (res
) >> cnt
!= SCM_INUM (n
))
1111 scm_num_overflow (FUNC_NAME
);
1118 /* GJB:FIXME: do not use SCMs as integers! */
1119 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1120 (SCM n
, SCM start
, SCM end
),
1121 "Returns the integer composed of the @var{start} (inclusive) through\n"
1122 "@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes\n"
1123 "the 0-th bit in the result.@refill\n\n"
1126 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1127 " @result{} \"1010\"\n"
1128 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1129 " @result{} \"10110\"\n"
1131 #define FUNC_NAME s_scm_bit_extract
1134 SCM_VALIDATE_INUM (1,n
);
1135 SCM_VALIDATE_INUM_MIN_COPY (2,start
,0,istart
);
1136 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1137 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1141 scm_logand (scm_difference (scm_integer_expt (SCM_MAKINUM (2),
1142 SCM_MAKINUM (iend
- istart
)),
1144 scm_ash (n
, SCM_MAKINUM (-istart
)));
1146 SCM_VALIDATE_INUM (1,n
);
1148 return SCM_MAKINUM ((SCM_INUM (n
) >> istart
) & ((1L << (iend
- istart
)) - 1));
1152 static const char scm_logtab
[] = {
1153 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1156 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1158 "Returns the number of bits in integer @var{n}. If integer is positive,\n"
1159 "the 1-bits in its binary representation are counted. If negative, the\n"
1160 "0-bits in its two's-complement binary representation are counted. If 0,\n"
1161 "0 is returned.\n\n"
1164 "(logcount #b10101010)\n"
1171 #define FUNC_NAME s_scm_logcount
1173 register unsigned long c
= 0;
1180 SCM_VALIDATE_BIGINT (1,n
);
1181 if (SCM_BIGSIGN (n
))
1182 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n
));
1183 ds
= SCM_BDIGITS (n
);
1184 for (i
= SCM_NUMDIGS (n
); i
--;)
1185 for (d
= ds
[i
]; d
; d
>>= 4)
1186 c
+= scm_logtab
[15 & d
];
1187 return SCM_MAKINUM (c
);
1190 SCM_VALIDATE_INUM (1,n
);
1192 if ((nn
= SCM_INUM (n
)) < 0)
1194 for (; nn
; nn
>>= 4)
1195 c
+= scm_logtab
[15 & nn
];
1196 return SCM_MAKINUM (c
);
1201 static const char scm_ilentab
[] = {
1202 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1205 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1207 "Returns the number of bits neccessary to represent @var{n}.\n\n"
1210 "(integer-length #b10101010)\n"
1212 "(integer-length 0)\n"
1214 "(integer-length #b1111)\n"
1217 #define FUNC_NAME s_scm_integer_length
1219 register unsigned long c
= 0;
1226 SCM_VALIDATE_BIGINT (1,n
);
1227 if (SCM_BIGSIGN (n
))
1228 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n
));
1229 ds
= SCM_BDIGITS (n
);
1230 d
= ds
[c
= SCM_NUMDIGS (n
) - 1];
1231 for (c
*= SCM_BITSPERDIG
; d
; d
>>= 4)
1234 l
= scm_ilentab
[15 & d
];
1236 return SCM_MAKINUM (c
- 4 + l
);
1239 SCM_VALIDATE_INUM (1,n
);
1241 if ((nn
= SCM_INUM (n
)) < 0)
1243 for (; nn
; nn
>>= 4)
1246 l
= scm_ilentab
[15 & nn
];
1248 return SCM_MAKINUM (c
- 4 + l
);
1254 static const char s_bignum
[] = "bignum";
1257 scm_mkbig (scm_sizet nlen
, int sign
)
1260 /* Cast to long int to avoid signed/unsigned comparison warnings. */
1261 if ((( ((long int) nlen
) << SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
)
1263 scm_wta (SCM_MAKINUM (nlen
), (char *) SCM_NALLOC
, s_bignum
);
1267 SCM_SETCHARS (v
, scm_must_malloc ((long) (nlen
* sizeof (SCM_BIGDIG
)),
1269 SCM_SETNUMDIGS (v
, nlen
, sign
);
1276 scm_big2inum (SCM b
, scm_sizet l
)
1278 unsigned long num
= 0;
1279 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1281 num
= SCM_BIGUP (num
) + tmp
[l
];
1282 if (!SCM_BIGSIGN (b
))
1284 if (SCM_POSFIXABLE (num
))
1285 return SCM_MAKINUM (num
);
1287 else if (SCM_UNEGFIXABLE (num
))
1288 return SCM_MAKINUM (-num
);
1293 static const char s_adjbig
[] = "scm_adjbig";
1296 scm_adjbig (SCM b
, scm_sizet nlen
)
1298 scm_sizet nsiz
= nlen
;
1299 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1300 scm_wta (scm_ulong2num (nsiz
), (char *) SCM_NALLOC
, s_adjbig
);
1306 scm_must_realloc ((char *) SCM_CHARS (b
),
1307 (long) (SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
)),
1308 (long) (nsiz
* sizeof (SCM_BIGDIG
)), s_bignum
));
1310 SCM_SETCHARS (b
, digits
);
1311 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1323 scm_sizet nlen
= SCM_NUMDIGS (b
);
1325 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1327 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1328 while (nlen
-- && !zds
[nlen
]);
1330 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1331 if (SCM_INUMP (b
= scm_big2inum (b
, (scm_sizet
) nlen
)))
1333 if (SCM_NUMDIGS (b
) == nlen
)
1335 return scm_adjbig (b
, (scm_sizet
) nlen
);
1341 scm_copybig (SCM b
, int sign
)
1343 scm_sizet i
= SCM_NUMDIGS (b
);
1344 SCM ans
= scm_mkbig (i
, sign
);
1345 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1354 scm_long2big (long n
)
1358 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, n
< 0);
1359 digits
= SCM_BDIGITS (ans
);
1362 while (i
< SCM_DIGSPERLONG
)
1364 digits
[i
++] = SCM_BIGLO (n
);
1365 n
= SCM_BIGDN ((unsigned long) n
);
1370 #ifdef HAVE_LONG_LONGS
1373 scm_long_long2big (long_long n
)
1383 if ((long long) tn
== n
)
1384 return scm_long2big (tn
);
1390 for (tn
= n
, n_digits
= 0;
1392 ++n_digits
, tn
= SCM_BIGDN ((ulong_long
) tn
))
1397 ans
= scm_mkbig (n_digits
, n
< 0);
1398 digits
= SCM_BDIGITS (ans
);
1401 while (i
< n_digits
)
1403 digits
[i
++] = SCM_BIGLO (n
);
1404 n
= SCM_BIGDN ((ulong_long
) n
);
1412 scm_2ulong2big (unsigned long *np
)
1419 ans
= scm_mkbig (2 * SCM_DIGSPERLONG
, 0);
1420 digits
= SCM_BDIGITS (ans
);
1423 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1425 digits
[i
] = SCM_BIGLO (n
);
1426 n
= SCM_BIGDN ((unsigned long) n
);
1429 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1431 digits
[i
+ SCM_DIGSPERLONG
] = SCM_BIGLO (n
);
1432 n
= SCM_BIGDN ((unsigned long) n
);
1440 scm_ulong2big (unsigned long n
)
1444 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, 0);
1445 digits
= SCM_BDIGITS (ans
);
1446 while (i
< SCM_DIGSPERLONG
)
1448 digits
[i
++] = SCM_BIGLO (n
);
1457 scm_bigcomp (SCM x
, SCM y
)
1459 int xsign
= SCM_BIGSIGN (x
);
1460 int ysign
= SCM_BIGSIGN (y
);
1461 scm_sizet xlen
, ylen
;
1463 /* Look at the signs, first. */
1469 /* They're the same sign, so see which one has more digits. Note
1470 that, if they are negative, the longer number is the lesser. */
1471 ylen
= SCM_NUMDIGS (y
);
1472 xlen
= SCM_NUMDIGS (x
);
1474 return (xsign
) ? -1 : 1;
1476 return (xsign
) ? 1 : -1;
1478 /* They have the same number of digits, so find the most significant
1479 digit where they differ. */
1483 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1484 /* Make the discrimination based on the digit that differs. */
1485 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1487 : (xsign
? 1 : -1));
1490 /* The numbers are identical. */
1494 #ifndef SCM_DIGSTOOBIG
1498 scm_pseudolong (long x
)
1503 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1509 while (i
< SCM_DIGSPERLONG
)
1511 p
.bd
[i
++] = SCM_BIGLO (x
);
1514 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1522 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1527 while (i
< SCM_DIGSPERLONG
)
1529 digs
[i
++] = SCM_BIGLO (x
);
1538 scm_addbig (SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int sgny
)
1540 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1541 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1543 scm_sizet i
= 0, ny
= SCM_NUMDIGS (bigy
);
1544 SCM z
= scm_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1545 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1546 if (xsgn
^ SCM_BIGSIGN (z
))
1550 num
+= (long) zds
[i
] - x
[i
];
1553 zds
[i
] = num
+ SCM_BIGRAD
;
1558 zds
[i
] = SCM_BIGLO (num
);
1563 if (num
&& nx
== ny
)
1567 SCM_SET_CELL_WORD_0 (z
, SCM_CELL_WORD_0 (z
) ^ SCM_BIGSIGNFLAG
);
1570 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1571 zds
[i
++] = SCM_BIGLO (num
);
1572 num
= SCM_BIGDN (num
);
1582 zds
[i
++] = num
+ SCM_BIGRAD
;
1587 zds
[i
++] = SCM_BIGLO (num
);
1596 num
+= (long) zds
[i
] + x
[i
];
1597 zds
[i
++] = SCM_BIGLO (num
);
1598 num
= SCM_BIGDN (num
);
1606 zds
[i
++] = SCM_BIGLO (num
);
1607 num
= SCM_BIGDN (num
);
1613 z
= scm_adjbig (z
, ny
+ 1);
1614 SCM_BDIGITS (z
)[ny
] = num
;
1618 return scm_normbig (z
);
1623 scm_mulbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
)
1625 scm_sizet i
= 0, j
= nx
+ ny
;
1626 unsigned long n
= 0;
1627 SCM z
= scm_mkbig (j
, sgn
);
1628 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1638 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1639 zds
[i
+ j
++] = SCM_BIGLO (n
);
1651 return scm_normbig (z
);
1655 /* Sun's compiler complains about the fact that this function has an
1656 ANSI prototype in numbers.h, but a K&R declaration here, and the
1657 two specify different promotions for the third argument. I'm going
1658 to turn this into an ANSI declaration, and see if anyone complains
1659 about it not being K&R. */
1662 scm_divbigdig (SCM_BIGDIG
* ds
,
1666 register unsigned long t2
= 0;
1669 t2
= SCM_BIGUP (t2
) + ds
[h
];
1679 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1685 register unsigned long t2
= 0;
1686 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1687 scm_sizet nd
= SCM_NUMDIGS (x
);
1689 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1692 return SCM_MAKINUM (sgn
? -t2
: t2
);
1695 #ifndef SCM_DIGSTOOBIG
1696 unsigned long t2
= scm_pseudolong (z
);
1697 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1698 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1701 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1702 scm_longdigs (z
, t2
);
1703 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1704 t2
, SCM_DIGSPERLONG
,
1712 scm_divbigbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
)
1714 /* modes description
1718 3 quotient but returns 0 if division is not exact. */
1719 scm_sizet i
= 0, j
= 0;
1721 unsigned long t2
= 0;
1723 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1724 /* algorithm requires nx >= ny */
1728 case 0: /* remainder -- just return x */
1729 z
= scm_mkbig (nx
, sgn
);
1730 zds
= SCM_BDIGITS (z
);
1737 case 1: /* scm_modulo -- return y-x */
1738 z
= scm_mkbig (ny
, sgn
);
1739 zds
= SCM_BDIGITS (z
);
1742 num
+= (long) y
[i
] - x
[i
];
1745 zds
[i
] = num
+ SCM_BIGRAD
;
1760 zds
[i
++] = num
+ SCM_BIGRAD
;
1771 return SCM_INUM0
; /* quotient is zero */
1773 return 0; /* the division is not exact */
1776 z
= scm_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1777 zds
= SCM_BDIGITS (z
);
1781 ny
--; /* in case y came in as a psuedolong */
1782 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1783 { /* normalize operands */
1784 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1785 newy
= scm_mkbig (ny
, 0);
1786 yds
= SCM_BDIGITS (newy
);
1789 t2
+= (unsigned long) y
[j
] * d
;
1790 yds
[j
++] = SCM_BIGLO (t2
);
1791 t2
= SCM_BIGDN (t2
);
1798 t2
+= (unsigned long) x
[j
] * d
;
1799 zds
[j
++] = SCM_BIGLO (t2
);
1800 t2
= SCM_BIGDN (t2
);
1810 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1812 { /* loop over digits of quotient */
1813 if (zds
[j
] == y
[ny
- 1])
1814 qhat
= SCM_BIGRAD
- 1;
1816 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1823 { /* multiply and subtract */
1824 t2
+= (unsigned long) y
[i
] * qhat
;
1825 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1828 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1833 zds
[j
- ny
+ i
] = num
;
1836 t2
= SCM_BIGDN (t2
);
1839 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1841 { /* "add back" required */
1847 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1848 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1849 num
= SCM_BIGDN (num
);
1860 case 3: /* check that remainder==0 */
1861 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1864 case 2: /* move quotient down in z */
1865 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
1866 for (i
= 0; i
< j
; i
++)
1867 zds
[i
] = zds
[i
+ ny
];
1870 case 1: /* subtract for scm_modulo */
1876 num
+= y
[i
] - zds
[i
];
1880 zds
[i
] = num
+ SCM_BIGRAD
;
1892 case 0: /* just normalize remainder */
1894 scm_divbigdig (zds
, ny
, d
);
1897 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1898 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
1899 if (SCM_INUMP (z
= scm_big2inum (z
, j
)))
1901 return scm_adjbig (z
, j
);
1909 /*** NUMBERS -> STRINGS ***/
1911 static const double fx
[] =
1912 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1913 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1914 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1915 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1921 idbl2str (double f
, char *a
)
1923 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1928 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1947 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1948 make-uniform-vector, from causing infinite loops. */
1952 if (exp
-- < DBL_MIN_10_EXP
)
1958 if (exp
++ > DBL_MAX_10_EXP
)
1973 if (f
+ fx
[wp
] >= 10.0)
1980 dpt
= (exp
+ 9999) % 3;
1984 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2009 if (f
+ fx
[wp
] >= 1.0)
2023 if ((dpt
> 4) && (exp
> 6))
2025 d
= (a
[0] == '-' ? 2 : 1);
2026 for (i
= ch
++; i
> d
; i
--)
2039 if (a
[ch
- 1] == '.')
2040 a
[ch
++] = '0'; /* trailing zero */
2049 for (i
= 10; i
<= exp
; i
*= 10);
2050 for (i
/= 10; i
; i
/= 10)
2052 a
[ch
++] = exp
/ i
+ '0';
2061 iflo2str (SCM flt
, char *str
)
2064 if (SCM_SLOPPY_REALP (flt
))
2065 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2068 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2069 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2071 if (0 <= SCM_COMPLEX_IMAG (flt
))
2073 i
+= idbl2str (SCM_COMPLEX_IMAG (flt
), &str
[i
]);
2080 /* convert a long to a string (unterminated). returns the number of
2081 characters in the result.
2083 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2085 scm_iint2str (long num
, int rad
, char *p
)
2089 unsigned long n
= (num
< 0) ? -num
: num
;
2091 for (n
/= rad
; n
> 0; n
/= rad
)
2108 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2117 big2str (SCM b
, unsigned int radix
)
2119 SCM t
= scm_copybig (b
, 0); /* sign of temp doesn't matter */
2120 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2121 scm_sizet i
= SCM_NUMDIGS (t
);
2122 scm_sizet j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2123 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2124 : (SCM_BITSPERDIG
* i
) + 2;
2126 scm_sizet radct
= 0;
2127 scm_sizet ch
; /* jeh */
2128 SCM_BIGDIG radpow
= 1, radmod
= 0;
2129 SCM ss
= scm_makstr ((long) j
, 0);
2130 char *s
= SCM_CHARS (ss
), c
;
2131 while ((long) radpow
* radix
< SCM_BIGRAD
)
2136 s
[0] = SCM_BIGSIGN (b
) ? '-' : '+';
2137 while ((i
|| radmod
) && j
)
2141 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2149 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2151 ch
= s
[0] == '-' ? 1 : 0; /* jeh */
2154 for (i
= j
; j
< SCM_LENGTH (ss
); j
++)
2155 s
[ch
+ j
- i
] = s
[j
]; /* jeh */
2156 scm_vector_set_length_x (ss
, /* jeh */
2157 SCM_MAKINUM (ch
+ SCM_LENGTH (ss
) - i
));
2160 return scm_return_first (ss
, t
);
2165 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2168 #define FUNC_NAME s_scm_number_to_string
2171 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2174 char num_buf
[SCM_FLOBUFLEN
];
2176 SCM_ASRTGO (SCM_NIMP (x
), badx
);
2178 return big2str (x
, (unsigned int) base
);
2179 #ifndef SCM_RECKLESS
2180 if (!SCM_SLOPPY_INEXACTP (x
))
2187 SCM_ASSERT (SCM_SLOPPY_INEXACTP (x
),
2188 x
, SCM_ARG1
, s_number_to_string
);
2190 return scm_makfromstr (num_buf
, iflo2str (x
, num_buf
), 0);
2193 char num_buf
[SCM_INTBUFLEN
];
2194 return scm_makfromstr (num_buf
,
2195 scm_iint2str (SCM_INUM (x
),
2204 /* These print routines are stubbed here so that scm_repl.c doesn't need
2205 SCM_BIGDIG conditionals */
2208 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2210 char num_buf
[SCM_FLOBUFLEN
];
2211 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2216 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2218 char num_buf
[SCM_FLOBUFLEN
];
2219 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2224 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate
)
2227 exp
= big2str (exp
, (unsigned int) 10);
2228 scm_lfwrite (SCM_CHARS (exp
), (scm_sizet
) SCM_LENGTH (exp
), port
);
2230 scm_ipruk ("bignum", exp
, port
);
2234 /*** END nums->strs ***/
2236 /*** STRINGS -> NUMBERS ***/
2239 scm_small_istr2int (char *str
, long len
, long radix
)
2241 register long n
= 0, ln
;
2246 return SCM_BOOL_F
; /* zero scm_length */
2248 { /* leading sign */
2253 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2258 switch (c
= str
[i
++])
2280 return SCM_BOOL_F
; /* bad digit for radix */
2283 /* Negation is a workaround for HP700 cc bug */
2284 if (n
> ln
|| (-n
> -SCM_MOST_NEGATIVE_FIXNUM
))
2288 return SCM_BOOL_F
; /* not a digit */
2293 if ((n
= -n
) > SCM_MOST_POSITIVE_FIXNUM
)
2295 return SCM_MAKINUM (n
);
2296 ovfl
: /* overflow scheme integer */
2303 scm_istr2int (char *str
, long len
, long radix
)
2306 register scm_sizet k
, blen
= 1;
2310 register SCM_BIGDIG
*ds
;
2311 register unsigned long t2
;
2314 return SCM_BOOL_F
; /* zero scm_length */
2316 /* Short numbers we parse directly into an int, to avoid the overhead
2317 of creating a bignum. */
2319 return scm_small_istr2int (str
, len
, radix
);
2322 j
= 1 + (4 * len
* sizeof (char)) / (SCM_BITSPERDIG
);
2323 else if (10 <= radix
)
2324 j
= 1 + (84 * len
* sizeof (char)) / (SCM_BITSPERDIG
* 25);
2326 j
= 1 + (len
* sizeof (char)) / (SCM_BITSPERDIG
);
2328 { /* leading sign */
2331 if (++i
== (unsigned) len
)
2332 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2334 res
= scm_mkbig (j
, '-' == str
[0]);
2335 ds
= SCM_BDIGITS (res
);
2340 switch (c
= str
[i
++])
2362 return SCM_BOOL_F
; /* bad digit for radix */
2368 /* printf ("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]); */
2369 t2
+= ds
[k
] * radix
;
2370 ds
[k
++] = SCM_BIGLO (t2
);
2371 t2
= SCM_BIGDN (t2
);
2374 scm_num_overflow ("bignum");
2382 return SCM_BOOL_F
; /* not a digit */
2385 while (i
< (unsigned) len
);
2386 if (blen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
2387 if (SCM_INUMP (res
= scm_big2inum (res
, blen
)))
2391 return scm_adjbig (res
, blen
);
2395 scm_istr2flo (char *str
, long len
, long radix
)
2397 register int c
, i
= 0;
2399 double res
= 0.0, tmp
= 0.0;
2405 return SCM_BOOL_F
; /* zero scm_length */
2408 { /* leading sign */
2421 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2423 if (str
[i
] == 'i' || str
[i
] == 'I')
2424 { /* handle `+i' and `-i' */
2425 if (lead_sgn
== 0.0)
2426 return SCM_BOOL_F
; /* must have leading sign */
2428 return SCM_BOOL_F
; /* `i' not last character */
2429 return scm_makdbl (0.0, lead_sgn
);
2432 { /* check initial digits */
2442 goto out1
; /* must be exponent */
2459 return SCM_BOOL_F
; /* bad digit for radix */
2460 res
= res
* radix
+ c
;
2461 flg
= 1; /* res is valid */
2470 /* if true, then we did see a digit above, and res is valid */
2474 /* By here, must have seen a digit,
2475 or must have next char be a `.' with radix==10 */
2477 if (!(str
[i
] == '.' && radix
== 10))
2480 while (str
[i
] == '#')
2481 { /* optional sharps */
2514 tmp
= tmp
* radix
+ c
;
2522 return SCM_BOOL_F
; /* `slash zero' not allowed */
2524 while (str
[i
] == '#')
2525 { /* optional sharps */
2535 { /* decimal point notation */
2537 return SCM_BOOL_F
; /* must be radix 10 */
2544 res
= res
* 10.0 + c
- '0';
2553 return SCM_BOOL_F
; /* no digits before or after decimal point */
2556 while (str
[i
] == '#')
2557 { /* ignore remaining sharps */
2576 int expsgn
= 1, expon
= 0;
2578 return SCM_BOOL_F
; /* only in radix 10 */
2580 return SCM_BOOL_F
; /* bad exponent */
2587 return SCM_BOOL_F
; /* bad exponent */
2589 if (str
[i
] < '0' || str
[i
] > '9')
2590 return SCM_BOOL_F
; /* bad exponent */
2596 expon
= expon
* 10 + c
- '0';
2597 if (expon
> SCM_MAXEXP
)
2598 return SCM_BOOL_F
; /* exponent too large */
2606 point
+= expsgn
* expon
;
2624 /* at this point, we have a legitimate floating point result */
2625 if (lead_sgn
== -1.0)
2628 return scm_makdbl (res
, 0.0);
2630 if (str
[i
] == 'i' || str
[i
] == 'I')
2631 { /* pure imaginary number */
2632 if (lead_sgn
== 0.0)
2633 return SCM_BOOL_F
; /* must have leading sign */
2635 return SCM_BOOL_F
; /* `i' not last character */
2636 return scm_makdbl (0.0, res
);
2648 { /* polar input for complex number */
2649 /* get a `real' for scm_angle */
2650 second
= scm_istr2flo (&str
[i
], (long) (len
- i
), radix
);
2651 if (!SCM_SLOPPY_INEXACTP (second
))
2652 return SCM_BOOL_F
; /* not `real' */
2653 if (SCM_SLOPPY_COMPLEXP (second
))
2654 return SCM_BOOL_F
; /* not `real' */
2655 tmp
= SCM_REALPART (second
);
2656 return scm_makdbl (res
* cos (tmp
), res
* sin (tmp
));
2662 /* at this point, last char must be `i' */
2663 if (str
[len
- 1] != 'i' && str
[len
- 1] != 'I')
2665 /* handles `x+i' and `x-i' */
2667 return scm_makdbl (res
, lead_sgn
);
2668 /* get a `ureal' for complex part */
2669 second
= scm_istr2flo (&str
[i
], (long) ((len
- i
) - 1), radix
);
2670 if (!SCM_INEXACTP (second
))
2671 return SCM_BOOL_F
; /* not `ureal' */
2672 if (SCM_SLOPPY_COMPLEXP (second
))
2673 return SCM_BOOL_F
; /* not `ureal' */
2674 tmp
= SCM_REALPART (second
);
2676 return SCM_BOOL_F
; /* not `ureal' */
2677 return scm_makdbl (res
, (lead_sgn
* tmp
));
2683 scm_istring2number (char *str
, long len
, long radix
)
2687 char ex_p
= 0, rx_p
= 0; /* Only allow 1 exactness and 1 radix prefix */
2690 if (*str
== '+' || *str
== '-') /* Catches lone `+' and `-' for speed */
2693 while ((len
- i
) >= 2 && str
[i
] == '#' && ++i
)
2739 return scm_istr2int (&str
[i
], len
- i
, radix
);
2741 res
= scm_istr2int (&str
[i
], len
- i
, radix
);
2742 if (SCM_NFALSEP (res
))
2745 return scm_istr2flo (&str
[i
], len
- i
, radix
);
2751 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2752 (SCM str
, SCM radix
),
2754 #define FUNC_NAME s_scm_string_to_number
2758 SCM_VALIDATE_ROSTRING (1,str
);
2759 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2760 answer
= scm_istring2number (SCM_ROCHARS (str
),
2763 return scm_return_first (answer
, str
);
2766 /*** END strs->nums ***/
2769 scm_make_real (double x
)
2777 scm_make_complex (double x
, double y
)
2780 SCM_NEWCOMPLEX (z
, x
, y
);
2785 scm_bigequal (SCM x
, SCM y
)
2788 if (0 == scm_bigcomp (x
, y
))
2795 scm_real_equalp (SCM x
, SCM y
)
2797 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2801 scm_complex_equalp (SCM x
, SCM y
)
2803 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2804 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2809 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2811 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2814 #define FUNC_NAME s_scm_number_p
2826 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2829 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2832 #define FUNC_NAME s_scm_real_p
2838 if (SCM_SLOPPY_REALP (x
))
2850 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2853 #define FUNC_NAME s_scm_integer_p
2864 if (!SCM_SLOPPY_INEXACTP (x
))
2866 if (SCM_SLOPPY_COMPLEXP (x
))
2868 r
= SCM_REALPART (x
);
2877 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
2880 #define FUNC_NAME s_scm_inexact_p
2882 if (SCM_INEXACTP (x
))
2891 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
2894 scm_num_eq_p (SCM x
, SCM y
)
2903 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
2909 SCM_ASRTGO (SCM_NIMP (y
), bady
);
2911 return SCM_BOOL(0 == scm_bigcomp (x
, y
));
2912 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
2914 return ((SCM_SLOPPY_REALP (y
) && (scm_big2dbl (x
) == SCM_REALPART (y
)))
2918 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx
);
2920 SCM_GASSERT2 (SCM_SLOPPY_INEXACTP (x
),
2921 g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
2931 SCM_ASRTGO (SCM_NIMP (y
), bady
);
2939 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
2941 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
2943 if (SCM_SLOPPY_REALP (x
))
2945 if (SCM_SLOPPY_REALP (y
))
2946 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2948 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
)
2949 && 0.0 == SCM_COMPLEX_IMAG (y
));
2953 if (SCM_SLOPPY_REALP (y
))
2954 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
)
2955 && SCM_COMPLEX_IMAG (x
) == 0.0);
2957 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2958 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2964 SCM_ASRTGO (SCM_NIMP (y
), bady
);
2967 if (!SCM_SLOPPY_INEXACTP (y
))
2970 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2973 if (!SCM_SLOPPY_INEXACTP (y
))
2976 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2980 if (SCM_SLOPPY_REALP (y
))
2981 return SCM_BOOL ((double) SCM_INUM (x
) == SCM_REAL_VALUE (y
));
2983 return SCM_BOOL ((double) SCM_INUM (x
) == SCM_COMPLEX_REAL (y
)
2984 && 0.0 == SCM_COMPLEX_IMAG (y
));
2986 return SCM_BOOL((long) x
== (long) y
);
2991 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
2994 scm_less_p (SCM x
, SCM y
)
3002 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3007 return SCM_BOOL(SCM_BIGSIGN (x
));
3008 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3010 return SCM_BOOL(1 == scm_bigcomp (x
, y
));
3011 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3012 return ((scm_big2dbl (x
) < SCM_REALPART (y
))
3016 SCM_ASRTGO (SCM_SLOPPY_REALP (x
), badx
);
3018 SCM_GASSERT2 (SCM_SLOPPY_REALP (x
),
3019 g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3022 return ((SCM_REALPART (x
) < ((double) SCM_INUM (y
)))
3026 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3028 return SCM_BOOL(SCM_REALPART (x
) < scm_big2dbl (y
));
3029 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3031 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3033 return SCM_BOOL(SCM_REALPART (x
) < SCM_REALPART (y
));
3038 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3040 return SCM_NEGATE_BOOL(SCM_BIGSIGN (y
));
3041 if (!SCM_SLOPPY_REALP (y
))
3044 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3047 if (!SCM_SLOPPY_REALP (y
))
3050 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3053 return ((((double) SCM_INUM (x
)) < SCM_REALPART (y
))
3057 return SCM_BOOL((long) x
< (long) y
);
3061 SCM_DEFINE1 (scm_gr_p
, ">", scm_tc7_rpsubr
,
3064 #define FUNC_NAME s_scm_gr_p
3066 return scm_less_p (y
, x
);
3072 SCM_DEFINE1 (scm_leq_p
, "<=", scm_tc7_rpsubr
,
3075 #define FUNC_NAME s_scm_leq_p
3077 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3083 SCM_DEFINE1 (scm_geq_p
, ">=", scm_tc7_rpsubr
,
3086 #define FUNC_NAME s_scm_geq_p
3088 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3094 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3102 SCM_ASRTGO (SCM_NIMP (z
), badz
);
3105 if (!SCM_SLOPPY_INEXACTP (z
))
3108 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3111 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
3112 g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3114 if (SCM_SLOPPY_REALP (z
))
3115 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3117 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3118 && SCM_COMPLEX_IMAG (z
) == 0.0);
3120 return SCM_BOOL (SCM_EQ_P (z
, SCM_INUM0
));
3125 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3128 scm_positive_p (SCM x
)
3133 SCM_ASRTGO (SCM_NIMP (x
), badx
);
3135 return SCM_BOOL (!SCM_BIGSIGN (x
));
3136 if (!SCM_SLOPPY_REALP (x
))
3139 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3142 SCM_GASSERT1 (SCM_SLOPPY_REALP (x
),
3143 g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3145 return SCM_BOOL(SCM_REALPART (x
) > 0.0);
3147 return SCM_BOOL(SCM_INUM(x
) > 0);
3152 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3155 scm_negative_p (SCM x
)
3160 SCM_ASRTGO (SCM_NIMP (x
), badx
);
3162 return SCM_BOOL (SCM_BIGSIGN (x
));
3163 if (!(SCM_SLOPPY_REALP (x
)))
3166 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3169 SCM_GASSERT1 (SCM_SLOPPY_REALP (x
),
3170 g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3172 return SCM_BOOL(SCM_REALPART (x
) < 0.0);
3174 return SCM_BOOL(SCM_INUM(x
) < 0);
3178 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3181 scm_max (SCM x
, SCM y
)
3186 SCM_GASSERT0 (!SCM_UNBNDP (x
),
3187 g_max
, scm_makfrom0str (s_max
), SCM_WNA
, 0);
3188 SCM_GASSERT1 (SCM_NUMBERP (x
), g_max
, x
, SCM_ARG1
, s_max
);
3197 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3202 return SCM_BIGSIGN (x
) ? y
: x
;
3203 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3205 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3206 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3207 z
= scm_big2dbl (x
);
3208 return (z
< SCM_REALPART (y
)) ? y
: scm_makdbl (z
, 0.0);
3210 SCM_ASRTGO (SCM_SLOPPY_REALP (x
), badx2
);
3212 SCM_GASSERT2 (SCM_SLOPPY_REALP (x
),
3213 g_max
, x
, y
, SCM_ARG1
, s_max
);
3216 return ((SCM_REALPART (x
) < (z
= SCM_INUM (y
)))
3217 ? scm_makdbl (z
, 0.0)
3220 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3222 return ((SCM_REALPART (x
) < (z
= scm_big2dbl (y
)))
3223 ? scm_makdbl (z
, 0.0)
3225 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3227 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3229 return (SCM_REALPART (x
) < SCM_REALPART (y
)) ? y
: x
;
3234 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3236 return SCM_BIGSIGN (y
) ? x
: y
;
3237 if (!(SCM_SLOPPY_REALP (y
)))
3240 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3243 if (!SCM_SLOPPY_REALP (y
))
3246 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3249 return (((z
= SCM_INUM (x
)) < SCM_REALPART (y
))
3251 : scm_makdbl (z
, 0.0));
3253 return ((long) x
< (long) y
) ? y
: x
;
3257 #define SCM_SWAP(x,y) do { SCM t = x; x = y; y = t; } while (0)
3261 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3264 scm_min (SCM x
, SCM y
)
3269 SCM_GASSERT0 (!SCM_UNBNDP (x
),
3270 g_min
, scm_makfrom0str (s_min
), SCM_WNA
, 0);
3271 SCM_GASSERT1 (SCM_NUMBERP (x
), g_min
, x
, SCM_ARG1
, s_min
);
3280 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3285 return SCM_BIGSIGN (x
) ? x
: y
;
3286 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3288 return (-1 == scm_bigcomp (x
, y
)) ? y
: x
;
3289 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3290 z
= scm_big2dbl (x
);
3291 return (z
> SCM_REALPART (y
)) ? y
: scm_makdbl (z
, 0.0);
3293 SCM_ASRTGO (SCM_SLOPPY_REALP (x
), badx2
);
3295 SCM_GASSERT2 (SCM_SLOPPY_REALP (x
),
3296 g_min
, x
, y
, SCM_ARG1
, s_min
);
3299 return ((SCM_REALPART (x
) > (z
= SCM_INUM (y
)))
3300 ? scm_makdbl (z
, 0.0)
3303 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3305 return ((SCM_REALPART (x
) > (z
= scm_big2dbl (y
)))
3306 ? scm_makdbl (z
, 0.0)
3308 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3310 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3312 return (SCM_REALPART (x
) > SCM_REALPART (y
)) ? y
: x
;
3317 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3319 return SCM_BIGSIGN (y
) ? y
: x
;
3320 if (!(SCM_SLOPPY_REALP (y
)))
3323 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3326 if (!SCM_SLOPPY_REALP (y
))
3329 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3332 return (((z
= SCM_INUM (x
)) > SCM_REALPART (y
))
3334 : scm_makdbl (z
, 0.0));
3336 return ((long) x
> (long) y
) ? y
: x
;
3342 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3345 This is sick, sick, sick code.
3349 scm_sum (SCM x
, SCM y
)
3355 SCM_GASSERT1 (SCM_NUMBERP (x
), g_sum
, x
, SCM_ARG1
, s_sum
);
3364 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3373 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3376 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
))
3380 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3384 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3386 if (SCM_SLOPPY_REALP (y
))
3387 return scm_make_real (scm_big2dbl (x
) + SCM_REAL_VALUE (y
));
3389 return scm_make_complex (scm_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3390 SCM_COMPLEX_IMAG (y
));
3392 # endif /* SCM_BIGDIG */
3393 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3401 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3407 else if (!SCM_SLOPPY_INEXACTP (y
))
3410 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3412 # else /* SCM_BIGDIG */
3413 if (!SCM_SLOPPY_INEXACTP (y
))
3416 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3418 # endif /* SCM_BIGDIG */
3421 if (SCM_SLOPPY_COMPLEXP (x
))
3422 i
= SCM_COMPLEX_IMAG (x
);
3423 if (SCM_SLOPPY_COMPLEXP (y
))
3424 i
+= SCM_COMPLEX_IMAG (y
);
3425 return scm_makdbl (SCM_REALPART (x
) + SCM_REALPART (y
), i
);
3431 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3436 long i
= SCM_INUM (x
);
3437 # ifndef SCM_DIGSTOOBIG
3438 long z
= scm_pseudolong (i
);
3439 return scm_addbig ((SCM_BIGDIG
*) & z
,
3441 (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3443 # else /* SCM_DIGSTOOBIG */
3444 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3445 scm_longdigs (i
, zdigs
);
3446 return scm_addbig (zdigs
, SCM_DIGSPERLONG
, (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3448 # endif /* SCM_DIGSTOOBIG */
3451 # endif /* SCM_BIGDIG */
3452 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3455 return scm_make_real (SCM_INUM (x
) + SCM_REAL_VALUE (y
));
3457 return scm_make_complex (SCM_INUM (x
) + SCM_COMPLEX_REAL (y
),
3458 SCM_COMPLEX_IMAG (y
));
3461 long int i
= SCM_INUM (x
) + SCM_INUM (y
);
3462 if (SCM_FIXABLE (i
))
3463 return SCM_MAKINUM (i
);
3465 return scm_long2big (i
);
3466 #else /* SCM_BIGDIG */
3467 return scm_makdbl ((double) i
, 0.0);
3468 #endif /* SCM_BIGDIG */
3475 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3478 HWN:FIXME:: This is sick,sick, sick code. Rewrite me.
3481 scm_difference (SCM x
, SCM y
)
3490 SCM_GASSERT0 (!SCM_UNBNDP (x
), g_difference
,
3491 scm_makfrom0str (s_difference
), SCM_WNA
, 0);
3493 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3498 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3506 x
= scm_copybig (x
, !SCM_BIGSIGN (x
));
3507 return (SCM_NUMDIGS (x
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
3509 ? scm_big2inum (x
, SCM_NUMDIGS (x
))
3513 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx
);
3514 if (SCM_SLOPPY_REALP (x
))
3515 return scm_make_real (- SCM_REAL_VALUE (x
));
3517 return scm_make_complex (- SCM_COMPLEX_REAL (x
),
3518 - SCM_COMPLEX_IMAG (x
));
3521 return scm_sum (x
, SCM_MAKINUM (- SCM_INUM (y
)));
3523 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3527 return ((SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3528 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3531 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3532 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
,
3534 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3536 return scm_make_real (scm_big2dbl (x
) - SCM_REAL_VALUE (y
));
3538 return scm_make_complex (scm_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3539 - SCM_COMPLEX_IMAG (y
));
3541 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3545 return scm_make_real (SCM_REAL_VALUE (x
) - scm_big2dbl (y
));
3547 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_big2dbl (y
),
3548 SCM_COMPLEX_IMAG (x
));
3550 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3552 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3553 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3557 if (SCM_SLOPPY_COMPLEXP (x
))
3559 if (SCM_SLOPPY_COMPLEXP (y
))
3561 SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3562 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3565 SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3566 SCM_COMPLEX_IMAG (x
));
3570 if (SCM_SLOPPY_COMPLEXP (y
))
3572 SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3573 - SCM_COMPLEX_IMAG (y
));
3575 SCM_NEWREAL (z
, SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3588 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3591 long i
= SCM_INUM (x
);
3592 #ifndef SCM_DIGSTOOBIG
3593 long z
= scm_pseudolong (i
);
3594 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3595 (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3596 y
, SCM_BIGSIGNFLAG
);
3598 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3599 scm_longdigs (i
, zdigs
);
3600 return scm_addbig (zdigs
, SCM_DIGSPERLONG
, (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3601 y
, SCM_BIGSIGNFLAG
);
3604 if (!SCM_SLOPPY_INEXACTP (y
))
3607 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3610 if (!SCM_SLOPPY_INEXACTP (y
))
3613 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3616 return scm_makdbl (SCM_INUM (x
) - SCM_REALPART (y
),
3617 SCM_SLOPPY_COMPLEXP (y
) ? -SCM_IMAG (y
) : 0.0);
3619 cx
= SCM_INUM (x
) - SCM_INUM (y
);
3621 if (SCM_FIXABLE (cx
))
3622 return SCM_MAKINUM (cx
);
3624 return scm_long2big (cx
);
3626 return scm_makdbl ((double) cx
, 0.0);
3633 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3636 scm_product (SCM x
, SCM y
)
3641 return SCM_MAKINUM (1L);
3642 SCM_GASSERT1 (SCM_NUMBERP (x
), g_product
, x
, SCM_ARG1
, s_product
);
3652 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3663 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3665 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3666 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3667 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3668 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3671 double bg
= scm_big2dbl (x
);
3672 return scm_makdbl (bg
* SCM_REALPART (y
),
3673 SCM_SLOPPY_COMPLEXP (y
) ? bg
* SCM_IMAG (y
) : 0.0);
3676 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3678 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3688 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3696 else if (!(SCM_SLOPPY_INEXACTP (y
)))
3699 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3702 if (!SCM_SLOPPY_INEXACTP (y
))
3705 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3708 if (SCM_SLOPPY_COMPLEXP (x
))
3710 if (SCM_SLOPPY_COMPLEXP (y
))
3711 return scm_makdbl (SCM_REAL (x
) * SCM_REAL (y
)
3712 - SCM_IMAG (x
) * SCM_IMAG (y
),
3713 SCM_REAL (x
) * SCM_IMAG (y
)
3714 + SCM_IMAG (x
) * SCM_REAL (y
));
3716 return scm_makdbl (SCM_REAL (x
) * SCM_REALPART (y
),
3717 SCM_IMAG (x
) * SCM_REALPART (y
));
3719 return scm_makdbl (SCM_REALPART (x
) * SCM_REALPART (y
),
3720 SCM_SLOPPY_COMPLEXP (y
)
3721 ? SCM_REALPART (x
) * SCM_IMAG (y
)
3727 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3731 if (SCM_EQ_P (x
, SCM_INUM0
))
3733 if (SCM_EQ_P (x
, SCM_MAKINUM (1L)))
3736 #ifndef SCM_DIGSTOOBIG
3737 long z
= scm_pseudolong (SCM_INUM (x
));
3738 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3739 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3740 SCM_BIGSIGN (y
) ? (x
> 0) : (x
< 0));
3742 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3743 scm_longdigs (SCM_INUM (x
), zdigs
);
3744 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3745 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3746 SCM_BIGSIGN (y
) ? (x
> 0) : (x
< 0));
3750 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3752 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3755 return scm_makdbl (SCM_INUM (x
) * SCM_REALPART (y
),
3756 SCM_SLOPPY_COMPLEXP (y
) ? SCM_INUM (x
) * SCM_IMAG (y
) : 0.0);
3765 y
= SCM_MAKINUM (k
);
3766 if (k
!= SCM_INUM (y
) || k
/ i
!= j
)
3769 int sgn
= (i
< 0) ^ (j
< 0);
3770 #ifndef SCM_DIGSTOOBIG
3771 i
= scm_pseudolong (i
);
3772 j
= scm_pseudolong (j
);
3773 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3774 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3775 #else /* SCM_DIGSTOOBIG */
3776 SCM_BIGDIG idigs
[SCM_DIGSPERLONG
];
3777 SCM_BIGDIG jdigs
[SCM_DIGSPERLONG
];
3778 scm_longdigs (i
, idigs
);
3779 scm_longdigs (j
, jdigs
);
3780 return scm_mulbig (idigs
, SCM_DIGSPERLONG
,
3781 jdigs
, SCM_DIGSPERLONG
,
3786 return scm_makdbl (((double) i
) * ((double) j
), 0.0);
3795 scm_num2dbl (SCM a
, const char *why
)
3798 return (double) SCM_INUM (a
);
3799 SCM_ASSERT (SCM_NIMP (a
), a
, "wrong type argument", why
);
3800 if (SCM_SLOPPY_REALP (a
))
3801 return (SCM_REALPART (a
));
3803 return scm_big2dbl (a
);
3805 SCM_ASSERT (0, a
, "wrong type argument", why
);
3807 unreachable, hopefully.
3809 return (double) 0.0; /* ugh. */
3810 /* return SCM_UNSPECIFIED; */
3814 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3817 scm_divide (SCM x
, SCM y
)
3822 if (!(SCM_NIMP (x
)))
3826 SCM_GASSERT0 (!SCM_UNBNDP (x
),
3827 g_divide
, scm_makfrom0str (s_divide
), SCM_WNA
, 0);
3829 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3834 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
3841 return scm_makdbl (1.0 / scm_big2dbl (x
), 0.0);
3843 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx
);
3844 if (SCM_SLOPPY_REALP (x
))
3845 return scm_makdbl (1.0 / SCM_REALPART (x
), 0.0);
3849 return scm_makdbl (r
/ d
, -i
/ d
);
3856 long int z
= SCM_INUM (y
);
3857 #ifndef SCM_RECKLESS
3859 scm_num_overflow (s_divide
);
3867 SCM w
= scm_copybig (x
, SCM_BIGSIGN (x
) ? (y
> 0) : (y
< 0));
3868 return (scm_divbigdig (SCM_BDIGITS (w
), SCM_NUMDIGS (w
),
3870 ? scm_makdbl (scm_big2dbl (x
) / SCM_INUM (y
), 0.0)
3873 #ifndef SCM_DIGSTOOBIG
3874 /*ugh! Does anyone know what this is supposed to do?*/
3875 z
= scm_pseudolong (z
);
3876 z
= SCM_INUM(scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3877 (SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3878 SCM_BIGSIGN (x
) ? (y
> 0) : (y
< 0), 3));
3881 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3882 scm_longdigs (z
, zdigs
);
3883 z
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3884 zdigs
, SCM_DIGSPERLONG
,
3885 SCM_BIGSIGN (x
) ? (y
> 0) : (y
< 0), 3);
3888 return z
? SCM_PACK (z
) : scm_makdbl (scm_big2dbl (x
) / SCM_INUM (y
), 0.0);
3890 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3893 SCM z
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3894 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3895 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 3);
3896 return z
? z
: scm_makdbl (scm_big2dbl (x
) / scm_big2dbl (y
),
3899 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3900 if (SCM_SLOPPY_REALP (y
))
3901 return scm_makdbl (scm_big2dbl (x
) / SCM_REALPART (y
), 0.0);
3902 a
= scm_big2dbl (x
);
3906 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3913 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3916 d
= scm_big2dbl (y
);
3919 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3921 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3923 if (SCM_SLOPPY_REALP (y
))
3925 d
= SCM_REALPART (y
);
3927 return scm_makdbl (SCM_REALPART (x
) / d
,
3928 SCM_SLOPPY_COMPLEXP (x
) ? SCM_IMAG (x
) / d
: 0.0);
3930 a
= SCM_REALPART (x
);
3931 if (SCM_SLOPPY_REALP (x
))
3936 return scm_makdbl ((a
* r
+ SCM_IMAG (x
) * i
) / d
,
3937 (SCM_IMAG (x
) * r
- a
* i
) / d
);
3941 if (SCM_EQ_P (x
, SCM_MAKINUM (1L)) || SCM_EQ_P (x
, SCM_MAKINUM (-1L)))
3943 return scm_makdbl (1.0 / ((double) SCM_INUM (x
)), 0.0);
3948 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3950 return scm_makdbl (SCM_INUM (x
) / scm_big2dbl (y
), 0.0);
3951 if (!(SCM_SLOPPY_INEXACTP (y
)))
3954 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3957 if (!SCM_SLOPPY_INEXACTP (y
))
3960 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3963 if (SCM_SLOPPY_REALP (y
))
3964 return scm_makdbl (SCM_INUM (x
) / SCM_REALPART (y
), 0.0);
3970 return scm_makdbl ((a
* r
) / d
, (-a
* i
) / d
);
3973 long z
= SCM_INUM (y
);
3974 if ((0 == z
) || SCM_INUM (x
) % z
)
3976 z
= SCM_INUM (x
) / z
;
3977 if (SCM_FIXABLE (z
))
3978 return SCM_MAKINUM (z
);
3980 return scm_long2big (z
);
3983 return scm_makdbl (((double) SCM_INUM (x
)) / ((double) SCM_INUM (y
)), 0.0);
3990 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
3993 scm_asinh (double x
)
3995 return log (x
+ sqrt (x
* x
+ 1));
4001 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
4004 scm_acosh (double x
)
4006 return log (x
+ sqrt (x
* x
- 1));
4012 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
4015 scm_atanh (double x
)
4017 return 0.5 * log ((1 + x
) / (1 - x
));
4023 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
4026 scm_truncate (double x
)
4035 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
4038 scm_round (double x
)
4040 double plus_half
= x
+ 0.5;
4041 double result
= floor (plus_half
);
4042 /* Adjust so that the scm_round is towards even. */
4043 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
4044 ? result
- 1 : result
;
4049 SCM_GPROC1 (s_exact_to_inexact
, "exact->inexact", scm_tc7_cxr
, (SCM (*)()) scm_exact_to_inexact
, g_exact_to_inexact
);
4052 scm_exact_to_inexact (double z
)
4058 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
4059 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
4060 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
4061 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
4062 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
4063 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
4064 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
4065 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
4066 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
4067 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
4068 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
4069 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
4070 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
4071 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
4072 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
4079 static void scm_two_doubles (SCM z1
,
4081 const char *sstring
,
4085 scm_two_doubles (SCM z1
, SCM z2
, const char *sstring
, struct dpair
*xy
)
4088 xy
->x
= SCM_INUM (z1
);
4092 SCM_ASRTGO (SCM_NIMP (z1
), badz1
);
4094 xy
->x
= scm_big2dbl (z1
);
4097 #ifndef SCM_RECKLESS
4098 if (!SCM_SLOPPY_REALP (z1
))
4099 badz1
:scm_wta (z1
, (char *) SCM_ARG1
, sstring
);
4101 xy
->x
= SCM_REALPART (z1
);
4105 SCM_ASSERT (SCM_SLOPPY_REALP (z1
), z1
, SCM_ARG1
, sstring
);
4106 xy
->x
= SCM_REALPART (z1
);
4111 xy
->y
= SCM_INUM (z2
);
4115 SCM_ASRTGO (SCM_NIMP (z2
), badz2
);
4117 xy
->y
= scm_big2dbl (z2
);
4120 #ifndef SCM_RECKLESS
4121 if (!(SCM_SLOPPY_REALP (z2
)))
4122 badz2
:scm_wta (z2
, (char *) SCM_ARG2
, sstring
);
4124 xy
->y
= SCM_REALPART (z2
);
4128 SCM_ASSERT (SCM_SLOPPY_REALP (z2
), z2
, SCM_ARG2
, sstring
);
4129 xy
->y
= SCM_REALPART (z2
);
4138 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
4141 #define FUNC_NAME s_scm_sys_expt
4144 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4145 return scm_makdbl (pow (xy
.x
, xy
.y
), 0.0);
4151 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4154 #define FUNC_NAME s_scm_sys_atan2
4157 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4158 return scm_makdbl (atan2 (xy
.x
, xy
.y
), 0.0);
4164 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4167 #define FUNC_NAME s_scm_make_rectangular
4170 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4171 return scm_makdbl (xy
.x
, xy
.y
);
4177 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4180 #define FUNC_NAME s_scm_make_polar
4183 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4184 return scm_makdbl (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
4191 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4194 scm_real_part (SCM z
)
4199 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4202 if (!(SCM_SLOPPY_INEXACTP (z
)))
4205 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4208 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
4209 g_real_part
, z
, SCM_ARG1
, s_real_part
);
4211 if (SCM_SLOPPY_COMPLEXP (z
))
4212 return scm_makdbl (SCM_REAL (z
), 0.0);
4219 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4222 scm_imag_part (SCM z
)
4227 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4230 if (!(SCM_SLOPPY_INEXACTP (z
)))
4233 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4236 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
4237 g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4239 if (SCM_SLOPPY_COMPLEXP (z
))
4240 return scm_makdbl (SCM_IMAG (z
), 0.0);
4246 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4249 scm_magnitude (SCM z
)
4254 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4257 if (!(SCM_SLOPPY_INEXACTP (z
)))
4260 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4263 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
4264 g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4266 if (SCM_SLOPPY_COMPLEXP (z
))
4268 double i
= SCM_IMAG (z
), r
= SCM_REAL (z
);
4269 return scm_makdbl (sqrt (i
* i
+ r
* r
), 0.0);
4271 return scm_makdbl (fabs (SCM_REALPART (z
)), 0.0);
4277 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
4285 x
= (z
>= SCM_INUM0
) ? 1.0 : -1.0;
4289 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4292 x
= (SCM_BIGSIGN (z
)) ? -1.0 : 1.0;
4295 if (!(SCM_SLOPPY_INEXACTP (z
)))
4298 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
4301 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
), g_angle
, z
, SCM_ARG1
, s_angle
);
4303 if (SCM_SLOPPY_REALP (z
))
4305 x
= SCM_REALPART (z
);
4311 return scm_makdbl (atan2 (y
, x
), 0.0);
4315 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4318 #define FUNC_NAME s_scm_inexact_to_exact
4323 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4326 #ifndef SCM_RECKLESS
4327 if (!(SCM_SLOPPY_REALP (z
)))
4334 SCM_VALIDATE_REAL (1,z
);
4338 double u
= floor (SCM_REALPART (z
) + 0.5);
4339 if ((u
<= SCM_MOST_POSITIVE_FIXNUM
) && (-u
<= -SCM_MOST_NEGATIVE_FIXNUM
))
4341 /* Negation is a workaround for HP700 cc bug */
4342 SCM ans
= SCM_MAKINUM ((long) u
);
4343 if (SCM_INUM (ans
) == (long) u
)
4346 SCM_ASRTGO (isfinite (u
), badz
); /* problem? */
4347 return scm_dbl2big (u
);
4350 return SCM_MAKINUM ((long) floor (SCM_REALPART (z
) + 0.5));
4358 /* d must be integer */
4361 scm_dbl2big (double d
)
4367 double u
= (d
< 0) ? -d
: d
;
4368 while (0 != floor (u
))
4373 ans
= scm_mkbig (i
, d
< 0);
4374 digits
= SCM_BDIGITS (ans
);
4382 #ifndef SCM_RECKLESS
4384 scm_num_overflow ("dbl2big");
4395 scm_sizet i
= SCM_NUMDIGS (b
);
4396 SCM_BIGDIG
*digits
= SCM_BDIGITS (b
);
4398 ans
= digits
[i
] + SCM_BIGRAD
* ans
;
4399 if (SCM_BIGSIGN (b
))
4407 scm_long2num (long sl
)
4409 if (!SCM_FIXABLE (sl
))
4412 return scm_long2big (sl
);
4414 return scm_makdbl ((double) sl
, 0.0);
4417 return SCM_MAKINUM (sl
);
4421 #ifdef HAVE_LONG_LONGS
4424 scm_long_long2num (long_long sl
)
4426 if (!SCM_FIXABLE (sl
))
4429 return scm_long_long2big (sl
);
4431 return scm_makdbl ((double) sl
, 0.0);
4436 /* we know that sl fits into an inum */
4437 return SCM_MAKINUM ((scm_bits_t
) sl
);
4445 scm_ulong2num (unsigned long sl
)
4447 if (!SCM_POSFIXABLE (sl
))
4450 return scm_ulong2big (sl
);
4452 return scm_makdbl ((double) sl
, 0.0);
4455 return SCM_MAKINUM (sl
);
4460 scm_num2long (SCM num
, char *pos
, const char *s_caller
)
4464 if (SCM_INUMP (num
))
4466 res
= SCM_INUM (num
);
4469 SCM_ASRTGO (SCM_NIMP (num
), wrong_type_arg
);
4470 if (SCM_SLOPPY_REALP (num
))
4472 volatile double u
= SCM_REALPART (num
);
4482 unsigned long oldres
= 0;
4484 /* can't use res directly in case num is -2^31. */
4485 unsigned long pos_res
= 0;
4487 for (l
= SCM_NUMDIGS (num
); l
--;)
4489 pos_res
= SCM_BIGUP (pos_res
) + SCM_BDIGITS (num
)[l
];
4490 /* check for overflow. */
4491 if (pos_res
< oldres
)
4495 if (SCM_BIGSIGN (num
))
4511 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4513 scm_out_of_range (s_caller
, num
);
4518 #ifdef HAVE_LONG_LONGS
4521 scm_num2long_long (SCM num
, char *pos
, const char *s_caller
)
4525 if (SCM_INUMP (num
))
4527 res
= SCM_INUM (num
);
4530 SCM_ASRTGO (SCM_NIMP (num
), wrong_type_arg
);
4531 if (SCM_SLOPPY_REALP (num
))
4533 double u
= SCM_REALPART (num
);
4536 if ((res
< 0 && u
> 0) || (res
> 0 && u
< 0)) /* check for overflow. */
4544 unsigned long long oldres
= 0;
4546 /* can't use res directly in case num is -2^63. */
4547 unsigned long long pos_res
= 0;
4549 for (l
= SCM_NUMDIGS (num
); l
--;)
4551 pos_res
= SCM_LONGLONGBIGUP (pos_res
) + SCM_BDIGITS (num
)[l
];
4552 /* check for overflow. */
4553 if (pos_res
< oldres
)
4557 if (SCM_BIGSIGN (num
))
4573 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4575 scm_out_of_range (s_caller
, num
);
4582 scm_num2ulong (SCM num
, char *pos
, const char *s_caller
)
4586 if (SCM_INUMP (num
))
4588 if (SCM_INUM (num
) < 0)
4590 res
= SCM_INUM (num
);
4593 SCM_ASRTGO (SCM_NIMP (num
), wrong_type_arg
);
4594 if (SCM_SLOPPY_REALP (num
))
4596 double u
= SCM_REALPART (num
);
4606 unsigned long oldres
= 0;
4610 for (l
= SCM_NUMDIGS (num
); l
--;)
4612 res
= SCM_BIGUP (res
) + SCM_BDIGITS (num
)[l
];
4621 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4623 scm_out_of_range (s_caller
, num
);
4629 add1 (double f
, double *fsum
)
4640 scm_add_feature ("complex");
4641 scm_add_feature ("inexact");
4642 SCM_NEWREAL (scm_flo0
, 0.0);
4644 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4646 { /* determine floating point precision */
4648 double fsum
= 1.0 + f
;
4652 if (++scm_dblprec
> 20)
4656 scm_dblprec
= scm_dblprec
- 1;
4658 #endif /* DBL_DIG */
4659 #include "libguile/numbers.x"