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 */
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,
83 #define FUNC_NAME s_scm_exact_p
95 SCM_DEFINE (scm_odd_p
, "odd?", 1, 0, 0,
98 #define FUNC_NAME s_scm_odd_p
103 SCM_VALIDATE_BIGINT (1,n
);
104 return SCM_BOOL(1 & SCM_BDIGITS (n
)[0]);
107 SCM_VALIDATE_INUM (1,n
);
109 return SCM_BOOL(4 & (int) n
);
113 SCM_DEFINE (scm_even_p
, "even?", 1, 0, 0,
116 #define FUNC_NAME s_scm_even_p
121 SCM_VALIDATE_BIGINT (1,n
);
122 return SCM_NEGATE_BOOL(1 & SCM_BDIGITS (n
)[0]);
125 SCM_VALIDATE_INUM (1,n
);
127 return SCM_NEGATE_BOOL(4 & (int) n
);
131 SCM_GPROC (s_abs
, "abs", 1, 0, 0, scm_abs
, g_abs
);
140 SCM_GASSERT1 (SCM_BIGP (x
), g_abs
, x
, SCM_ARG1
, s_abs
);
141 if (!SCM_BIGSIGN (x
))
143 return scm_copybig (x
, 0);
146 SCM_GASSERT1 (SCM_INUMP (x
), g_abs
, x
, SCM_ARG1
, s_abs
);
148 if (SCM_INUM (x
) >= 0)
151 if (!SCM_POSFIXABLE (cx
))
153 return scm_long2big (cx
);
155 scm_num_overflow (s_abs
);
157 return SCM_MAKINUM (cx
);
160 SCM_GPROC (s_quotient
, "quotient", 2, 0, 0, scm_quotient
, g_quotient
);
163 scm_quotient (SCM x
, SCM y
)
169 SCM_GASSERT2 (SCM_BIGP (x
),
170 g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
173 SCM_ASRTGO (SCM_BIGP (y
), bady
);
174 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
175 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
176 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 2);
186 SCM sw
= scm_copybig (x
,
188 ? (SCM_UNPACK (y
) > 0)
189 : (SCM_UNPACK (y
) < 0));
190 scm_divbigdig (SCM_BDIGITS (sw
), SCM_NUMDIGS (sw
), (SCM_BIGDIG
) z
);
191 return scm_normbig (sw
);
194 #ifndef SCM_DIGSTOOBIG
195 long w
= scm_pseudolong (z
);
196 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
197 (SCM_BIGDIG
*) & w
, SCM_DIGSPERLONG
,
198 SCM_BIGSIGN (x
) ? (y
> 0) : (y
< 0), 2);
200 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
201 scm_longdigs (z
, zdigs
);
202 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
203 zdigs
, SCM_DIGSPERLONG
,
204 SCM_BIGSIGN (x
) ? (y
> 0) : (y
< 0), 2);
213 SCM_WTA_DISPATCH_2 (g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
218 SCM_GASSERT2 (SCM_INUMP (x
), g_quotient
, x
, y
, SCM_ARG1
, s_quotient
);
219 SCM_GASSERT2 (SCM_INUMP (y
), g_quotient
, x
, y
, SCM_ARG2
, s_quotient
);
221 if ((z
= SCM_INUM (y
)) == 0)
224 scm_num_overflow (s_quotient
);
226 z
= SCM_INUM (x
) / z
;
229 #if (__TURBOC__ == 1)
230 long t
= ((y
< 0) ? -SCM_INUM (x
) : SCM_INUM (x
)) % SCM_INUM (y
);
232 long t
= SCM_INUM (x
) % SCM_INUM (y
);
243 if (!SCM_FIXABLE (z
))
245 return scm_long2big (z
);
247 scm_num_overflow (s_quotient
);
249 return SCM_MAKINUM (z
);
252 SCM_GPROC (s_remainder
, "remainder", 2, 0, 0, scm_remainder
, g_remainder
);
255 scm_remainder (SCM x
, SCM y
)
261 SCM_GASSERT2 (SCM_BIGP (x
),
262 g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
265 SCM_ASRTGO (SCM_BIGP (y
), bady
);
266 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
267 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
270 if (!(z
= SCM_INUM (y
)))
272 return scm_divbigint (x
, z
, SCM_BIGSIGN (x
), 0);
279 SCM_WTA_DISPATCH_2 (g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
284 SCM_GASSERT2 (SCM_INUMP (x
), g_remainder
, x
, y
, SCM_ARG1
, s_remainder
);
285 SCM_GASSERT2 (SCM_INUMP (y
), g_remainder
, x
, y
, SCM_ARG2
, s_remainder
);
287 if (!(z
= SCM_INUM (y
)))
290 scm_num_overflow (s_remainder
);
292 #if (__TURBOC__ == 1)
296 z
= SCM_INUM (x
) % z
;
306 return SCM_MAKINUM (z
);
309 SCM_GPROC (s_modulo
, "modulo", 2, 0, 0, scm_modulo
, g_modulo
);
312 scm_modulo (SCM x
, SCM y
)
318 SCM_GASSERT2 (SCM_BIGP (x
),
319 g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
322 SCM_ASRTGO (SCM_BIGP (y
), bady
);
323 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
324 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
326 (SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
)) ? 1 : 0);
328 if (!(z
= SCM_INUM (y
)))
330 return scm_divbigint (x
, z
, y
< 0,
331 (SCM_BIGSIGN (x
) ? (y
> 0) : (y
< 0)) ? 1 : 0);
338 SCM_WTA_DISPATCH_2 (g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
340 return (SCM_BIGSIGN (y
) ? (x
> 0) : (x
< 0)) ? scm_sum (x
, y
) : x
;
343 SCM_GASSERT1 (SCM_INUMP (x
), g_modulo
, x
, y
, SCM_ARG1
, s_modulo
);
344 SCM_GASSERT2 (SCM_INUMP (y
), g_modulo
, x
, y
, SCM_ARG2
, s_modulo
);
346 if (!(yy
= SCM_INUM (y
)))
349 scm_num_overflow (s_modulo
);
353 z
= ((yy
< 0) ? -z
: z
) % yy
;
355 z
= SCM_INUM (x
) % yy
;
357 return SCM_MAKINUM (((yy
< 0) ? (z
> 0) : (z
< 0)) ? z
+ yy
: z
);
360 SCM_GPROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
, g_gcd
);
363 scm_gcd (SCM x
, SCM y
)
367 return SCM_UNBNDP (x
) ? SCM_INUM0
: x
;
373 SCM_GASSERT2 (SCM_BIGP (x
),
374 g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
376 x
= scm_copybig (x
, 0);
380 SCM_GASSERT2 (SCM_BIGP (y
),
381 g_gcd
, x
, y
, SCM_ARGn
, s_gcd
);
383 y
= scm_copybig (y
, 0);
384 switch (scm_bigcomp (x
, y
))
389 SCM t
= scm_remainder (x
, y
);
397 y
= scm_remainder (y
, x
);
400 /* instead of the switch, we could just
401 return scm_gcd (y, scm_modulo (x, y)); */
415 SCM_GASSERT2 (SCM_INUMP (x
), g_gcd
, x
, y
, SCM_ARG1
, s_gcd
);
416 SCM_GASSERT2 (SCM_INUMP (y
), g_gcd
, x
, y
, SCM_ARGn
, s_gcd
);
431 for (k
= 1; !(1 & ((int) u
| (int) v
)); k
<<= 1, u
>>= 1, v
>>= 1);
450 if (!SCM_POSFIXABLE (u
))
452 return scm_long2big (u
);
454 scm_num_overflow (s_gcd
);
456 return SCM_MAKINUM (u
);
459 SCM_GPROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
, g_lcm
);
462 scm_lcm (SCM n1
, SCM n2
)
466 SCM_GASSERT2 (SCM_INUMP (n1
) || SCM_UNBNDP (n1
),
467 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
468 SCM_GASSERT2 (SCM_INUMP (n2
) || SCM_UNBNDP (n2
),
469 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
471 SCM_GASSERT2 (SCM_INUMP (n1
)
474 g_lcm
, n1
, n2
, SCM_ARG1
, s_lcm
);
475 SCM_GASSERT2 (SCM_INUMP (n2
)
478 g_lcm
, n1
, n2
, SCM_ARGn
, s_lcm
);
482 n2
= SCM_MAKINUM (1L);
487 d
= scm_gcd (n1
, n2
);
490 return scm_abs (scm_product (n1
, scm_quotient (n2
, d
)));
494 #define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
496 #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
500 /* Emulating 2's complement bignums with sign magnitude arithmetic:
505 + + + x (map digit:logand X Y)
506 + - + x (map digit:logand X (lognot (+ -1 Y)))
507 - + + y (map digit:logand (lognot (+ -1 X)) Y)
508 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
513 + + + (map digit:logior X Y)
514 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
515 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
516 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
521 + + + (map digit:logxor X Y)
522 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
523 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
524 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
529 + + (any digit:logand X Y)
530 + - (any digit:logand X (lognot (+ -1 Y)))
531 - + (any digit:logand (lognot (+ -1 X)) Y)
538 SCM
scm_copy_big_dec(SCM b
, int sign
);
539 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
);
540 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
541 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
542 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
);
543 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
);
545 SCM
scm_copy_big_dec(SCM b
, int sign
)
548 scm_sizet nx
= SCM_NUMDIGS(b
);
550 SCM ans
= scm_mkbig(nx
, sign
);
551 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
552 if SCM_BIGSIGN(b
) do {
554 if (num
< 0) {dst
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
555 else {dst
[i
] = SCM_BIGLO(num
); num
= 0;}
558 while (nx
--) dst
[nx
] = src
[nx
];
562 SCM
scm_copy_smaller(SCM_BIGDIG
*x
, scm_sizet nx
, int zsgn
)
566 SCM z
= scm_mkbig(nx
, zsgn
);
567 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 else do zds
[i
] = x
[i
]; while (++i
< nx
);
577 SCM
scm_big_ior(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
578 /* Assumes nx <= SCM_NUMDIGS(bigy) */
579 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
582 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
583 SCM z
= scm_copy_big_dec (bigy
, xsgn
& SCM_BIGSIGN (bigy
));
584 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
588 if (num
< 0) {zds
[i
] |= num
+ SCM_BIGRAD
; num
= -1;}
589 else {zds
[i
] |= SCM_BIGLO(num
); num
= 0;}
591 /* ========= Need to increment zds now =========== */
595 zds
[i
++] = SCM_BIGLO(num
);
596 num
= SCM_BIGDN(num
);
599 scm_adjbig(z
, 1 + ny
); /* OOPS, overflowed into next digit. */
600 SCM_BDIGITS(z
)[ny
] = 1;
603 else do zds
[i
] = zds
[i
] | x
[i
]; while (++i
< nx
);
607 SCM
scm_big_xor(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
608 /* Assumes nx <= SCM_NUMDIGS(bigy) */
609 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
612 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
613 SCM z
= scm_copy_big_dec(bigy
, xsgn
^ SCM_BIGSIGN(bigy
));
614 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
617 if (num
< 0) {zds
[i
] ^= num
+ SCM_BIGRAD
; num
= -1;}
618 else {zds
[i
] ^= SCM_BIGLO(num
); num
= 0;}
621 zds
[i
] = zds
[i
] ^ x
[i
];
624 if (xsgn
^ SCM_BIGSIGN(bigy
)) {
625 /* ========= Need to increment zds now =========== */
629 zds
[i
++] = SCM_BIGLO(num
);
630 num
= SCM_BIGDN(num
);
631 if (!num
) return scm_normbig(z
);
634 return scm_normbig(z
);
637 SCM
scm_big_and(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int zsgn
)
638 /* Assumes nx <= SCM_NUMDIGS(bigy) */
639 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
640 /* return sign equals either 0 or SCM_BIGSIGNFLAG */
647 z
= scm_copy_smaller(x
, nx
, zsgn
);
648 x
= SCM_BDIGITS(bigy
);
649 xsgn
= SCM_BIGSIGN(bigy
);
651 else z
= scm_copy_big_dec(bigy
, zsgn
);
652 zds
= SCM_BDIGITS(z
);
657 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
658 else {zds
[i
] &= SCM_BIGLO(num
); num
= 0;}
660 else do zds
[i
] = zds
[i
] & ~x
[i
]; while (++i
< nx
);
661 /* ========= need to increment zds now =========== */
665 zds
[i
++] = SCM_BIGLO(num
);
666 num
= SCM_BIGDN(num
);
667 if (!num
) return scm_normbig(z
);
672 if (num
< 0) {zds
[i
] &= num
+ SCM_BIGRAD
; num
= -1;}
673 else {zds
[i
] &= ~SCM_BIGLO(num
); num
= 0;}
675 else do zds
[i
] = zds
[i
] & x
[i
]; while (++i
< nx
);
676 return scm_normbig(z
);
679 SCM
scm_big_test(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
)
680 /* Assumes nx <= SCM_NUMDIGS(bigy) */
681 /* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */
686 if (SCM_BIGSIGN(bigy
) & xsgn
) return SCM_BOOL_T
;
687 if (SCM_NUMDIGS(bigy
) != nx
&& xsgn
) return SCM_BOOL_T
;
688 y
= SCM_BDIGITS(bigy
);
693 if (y
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
697 if (y
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
701 else if SCM_BIGSIGN(bigy
)
705 if (x
[i
] & ~(num
+ SCM_BIGRAD
)) return SCM_BOOL_T
;
709 if (x
[i
] & ~SCM_BIGLO(num
)) return SCM_BOOL_T
;
714 do if (x
[i
] & y
[i
]) return SCM_BOOL_T
;
721 SCM_DEFINE1 (scm_logand
, "logand", scm_tc7_asubr
,
723 "Returns the integer which is the bit-wise AND of the two integer\n"
727 "(number->string (logand #b1100 #b1010) 2)\n"
728 " @result{} \"1000\"")
729 #define FUNC_NAME s_scm_logand
734 return SCM_MAKINUM (-1);
736 if (!(SCM_NUMBERP (n1
)))
737 badx
: SCM_WTA (SCM_ARG1
, n1
);
744 SCM_ASRTGO(SCM_NIMP(n1
) && SCM_BIGP(n1
), badx
);
745 if SCM_INUMP(n2
) {t
= n1
; n1
= n2
; n2
= t
; goto intbig
;}
746 SCM_ASRTGO(SCM_NIMP(n2
) && SCM_BIGP(n2
), bady
);
747 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {t
= n1
; n1
= n2
; n2
= t
;}
748 if ((SCM_BIGSIGN(n1
)) && SCM_BIGSIGN(n2
))
749 return scm_big_ior (SCM_BDIGITS(n1
),
753 return scm_big_and (SCM_BDIGITS(n1
),
760 # ifndef SCM_RECKLESS
761 if (!(SCM_NIMP(n2
) && SCM_BIGP(n2
)))
762 bady
: SCM_WTA (SCM_ARG2
, n2
);
765 # ifndef SCM_DIGSTOOBIG
766 long z
= scm_pseudolong(SCM_INUM(n1
));
767 if ((n1
< 0) && SCM_BIGSIGN(n2
))
768 return scm_big_ior((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
769 return scm_big_and((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
771 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
772 scm_longdigs(SCM_INUM(n1
), zdigs
);
773 if ((n1
< 0) && SCM_BIGSIGN(n2
))
774 return scm_big_ior(zdigs
, SCM_DIGSPERLONG
, SCM_BIGSIGNFLAG
, n2
);
775 return scm_big_and(zdigs
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, 0);
779 SCM_ASRTGO(SCM_INUMP(n1
), badx
);
780 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, FUNC_NAME
);
782 return SCM_MAKINUM(SCM_INUM(n1
) & SCM_INUM(n2
));
786 SCM_DEFINE1 (scm_logior
, "logior", scm_tc7_asubr
,
788 "Returns the integer which is the bit-wise OR of the two integer\n"
792 "(number->string (logior #b1100 #b1010) 2)\n"
793 " @result{} \"1110\"\n"
795 #define FUNC_NAME s_scm_logior
802 if (!(SCM_NUMBERP(n1
)))
803 badx
: SCM_WTA(SCM_ARG1
, n1
);
810 SCM_ASRTGO(SCM_NIMP(n1
) && SCM_BIGP(n1
), badx
);
811 if SCM_INUMP(n2
) {t
= n1
; n1
= n2
; n2
= t
; goto intbig
;}
812 SCM_ASRTGO(SCM_NIMP(n2
) && SCM_BIGP(n2
), bady
);
813 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {t
= n1
; n1
= n2
; n2
= t
;}
814 if ((!SCM_BIGSIGN(n1
)) && !SCM_BIGSIGN(n2
))
815 return scm_big_ior(SCM_BDIGITS(n1
), SCM_NUMDIGS(n1
), SCM_BIGSIGN(n1
), n2
);
816 return scm_big_and(SCM_BDIGITS(n1
), SCM_NUMDIGS(n1
), SCM_BIGSIGN(n1
), n2
, SCM_BIGSIGNFLAG
);
819 # ifndef SCM_RECKLESS
820 if (!(SCM_NIMP(n2
) && SCM_BIGP(n2
)))
821 bady
: SCM_WTA(SCM_ARG2
, n2
);
824 # ifndef SCM_DIGSTOOBIG
825 long z
= scm_pseudolong(SCM_INUM(n1
));
826 if ((!(n1
< 0)) && !SCM_BIGSIGN(n2
))
827 return scm_big_ior((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
828 return scm_big_and((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
830 BIGDIG zdigs
[DIGSPERLONG
];
831 scm_longdigs(SCM_INUM(n1
), zdigs
);
832 if ((!(n1
< 0)) && !SCM_BIGSIGN(n2
))
833 return scm_big_ior(zdigs
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
834 return scm_big_and(zdigs
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
, SCM_BIGSIGNFLAG
);
838 SCM_ASRTGO(SCM_INUMP(n1
), badx
);
839 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, FUNC_NAME
);
841 return SCM_MAKINUM(SCM_INUM(n1
) | SCM_INUM(n2
));
845 SCM_DEFINE1 (scm_logxor
, "logxor", scm_tc7_asubr
,
847 "Returns the integer which is the bit-wise XOR of the two integer\n"
851 "(number->string (logxor #b1100 #b1010) 2)\n"
852 " @result{} \"110\"\n"
854 #define FUNC_NAME s_scm_logxor
861 if (!(SCM_NUMBERP(n1
)))
862 badx
: SCM_WTA(SCM_ARG1
, n1
);
869 SCM_ASRTGO(SCM_NIMP(n1
) && SCM_BIGP(n1
), badx
);
877 SCM_ASRTGO(SCM_NIMP(n2
) && SCM_BIGP(n2
), bady
);
878 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
))
884 return scm_big_xor(SCM_BDIGITS(n1
), SCM_NUMDIGS(n1
), SCM_BIGSIGN(n1
), n2
);
887 # ifndef SCM_RECKLESS
888 if (!(SCM_NIMP(n2
) && SCM_BIGP(n2
)))
889 bady
: SCM_WTA (SCM_ARG2
, n2
);
893 # ifndef SCM_DIGSTOOBIG
894 long z
= scm_pseudolong(SCM_INUM(n1
));
895 return scm_big_xor((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
897 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
898 scm_longdigs(SCM_INUM(n1
), zdigs
);
899 return scm_big_xor(zdigs
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
904 SCM_ASRTGO(INUMP(n1
), badx
);
905 SCM_ASSERT(INUMP(n2
), n2
, SCM_ARG2
, FUNC_NAME
);
907 return SCM_MAKINUM(SCM_INUM(n1
) ^ SCM_INUM(n2
));
911 SCM_DEFINE (scm_logtest
, "logtest", 2, 0, 0,
914 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
915 "(logtest #b0100 #b1011) @result{} #f\n"
916 "(logtest #b0100 #b0111) @result{} #t\n"
918 #define FUNC_NAME s_scm_logtest
921 if (!(SCM_NUMBERP(n1
)))
922 badx
: SCM_WTA(SCM_ARG1
, n1
);
927 SCM_ASRTGO(SCM_NIMP(n1
) && SCM_BIGP(n1
), badx
);
928 if SCM_INUMP(n2
) {t
= n1
; n1
= n2
; n2
= t
; goto intbig
;}
929 SCM_ASRTGO(SCM_NIMP(n2
) && SCM_BIGP(n2
), bady
);
930 if (SCM_NUMDIGS(n1
) > SCM_NUMDIGS(n2
)) {t
= n1
; n1
= n2
; n2
= t
;}
931 return scm_big_test(SCM_BDIGITS(n1
), SCM_NUMDIGS(n1
), SCM_BIGSIGN(n1
), n2
);
934 # ifndef SCM_RECKLESS
935 if (!(SCM_NIMP(n2
) && SCM_BIGP(n2
)))
936 bady
: SCM_WTA(SCM_ARG2
, n2
);
939 # ifndef SCM_DIGSTOOBIG
940 long z
= scm_pseudolong(SCM_INUM(n1
));
941 return scm_big_test((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
943 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
944 scm_longdigs(SCM_INUM(n1
), zdigs
);
945 return scm_big_test(zdigs
, SCM_DIGSPERLONG
, (n1
< 0) ? SCM_BIGSIGNFLAG
: 0, n2
);
949 SCM_ASRTGO(SCM_INUMP(n1
), badx
);
950 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, FUNC_NAME
);
952 return (SCM_INUM(n1
) & SCM_INUM(n2
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
957 SCM_DEFINE (scm_logbit_p
, "logbit?", 2, 0, 0,
960 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
961 "(logbit? 0 #b1101) @result{} #t\n"
962 "(logbit? 1 #b1101) @result{} #f\n"
963 "(logbit? 2 #b1101) @result{} #t\n"
964 "(logbit? 3 #b1101) @result{} #t\n"
965 "(logbit? 4 #b1101) @result{} #f\n"
967 #define FUNC_NAME s_scm_logbit_p
969 SCM_ASSERT(SCM_INUMP(index
) && SCM_INUM(index
) >= 0, index
, SCM_ARG1
, FUNC_NAME
);
972 SCM_ASSERT(SCM_NIMP(j
) && SCM_BIGP(j
), j
, SCM_ARG2
, FUNC_NAME
);
973 if (SCM_NUMDIGS(j
) * SCM_BITSPERDIG
< SCM_INUM(index
)) return SCM_BOOL_F
;
974 else if SCM_BIGSIGN(j
) {
977 SCM_BIGDIG
*x
= SCM_BDIGITS(j
);
978 scm_sizet nx
= SCM_INUM(index
)/SCM_BITSPERDIG
;
982 return ((1L << (SCM_INUM(index
)%SCM_BITSPERDIG
)) & num
) ? SCM_BOOL_F
: SCM_BOOL_T
;
983 if (num
< 0) num
= -1;
987 else return (SCM_BDIGITS(j
)[SCM_INUM(index
)/SCM_BITSPERDIG
] &
988 (1L << (SCM_INUM(index
)%SCM_BITSPERDIG
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
991 SCM_ASSERT(SCM_INUMP(j
), j
, SCM_ARG2
, FUNC_NAME
);
993 return ((1L << SCM_INUM(index
)) & SCM_INUM(j
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
997 SCM_DEFINE (scm_lognot
, "lognot", 1, 0, 0,
999 "Returns the integer which is the 2s-complement of the integer argument.\n\n"
1002 "(number->string (lognot #b10000000) 2)\n"
1003 " @result{} \"-10000001\"\n"
1004 "(number->string (lognot #b0) 2)\n"
1005 " @result{} \"-1\"\n"
1008 #define FUNC_NAME s_scm_lognot
1010 return scm_difference (SCM_MAKINUM (-1L), n
);
1014 SCM_DEFINE (scm_integer_expt
, "integer-expt", 2, 0, 0,
1016 "Returns @var{n} raised to the non-negative integer exponent @var{k}.\n\n"
1019 "(integer-expt 2 5)\n"
1021 "(integer-expt -3 3)\n"
1024 #define FUNC_NAME s_scm_integer_expt
1026 SCM acc
= SCM_MAKINUM (1L);
1029 if (SCM_INUM0
== n
|| acc
== n
)
1031 else if (SCM_MAKINUM (-1L) == n
)
1032 return SCM_BOOL_F
== scm_even_p (k
) ? n
: acc
;
1034 SCM_VALIDATE_ULONG_COPY (2,k
,i2
);
1038 n
= scm_divide (n
, SCM_UNDEFINED
);
1045 return scm_product (acc
, n
);
1047 acc
= scm_product (acc
, n
);
1048 n
= scm_product (n
, n
);
1054 SCM_DEFINE (scm_ash
, "ash", 2, 0, 0,
1056 "The function ash performs an arithmetic shift left by CNT bits\n"
1057 "(or shift right, if CNT is negative). 'Arithmetic' means, that\n"
1058 "the function does not guarantee to keep the bit structure of N,\n"
1059 "but rather guarantees that the result will always be rounded\n"
1060 "towards minus infinity. Therefore, the results of ash and a\n"
1061 "corresponding bitwise shift will differ if N is negative.\n\n"
1062 "Formally, the function returns an integer equivalent to\n"
1063 "@code{(inexact->exact (floor (* N (expt 2 CNT))))}.@refill\n\n"
1066 "(number->string (ash #b1 3) 2)\n"
1067 " @result{} \"1000\""
1068 "(number->string (ash #b1010 -1) 2)"
1069 " @result{} \"101\""
1071 #define FUNC_NAME s_scm_ash
1076 SCM_VALIDATE_INUM (1, n
)
1078 SCM_VALIDATE_INUM (2, cnt
);
1080 bits_to_shift
= SCM_INUM (cnt
);
1082 if (bits_to_shift
< 0) {
1083 /* Shift right by abs(cnt) bits. This is realized as a division by
1084 div:=2^abs(cnt). However, to guarantee the floor rounding, negative
1085 values require some special treatment.
1087 SCM div
= scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift
));
1088 if (SCM_FALSEP (scm_negative_p (n
)))
1089 return scm_quotient (n
, div
);
1091 return scm_sum (SCM_MAKINUM (-1L),
1092 scm_quotient (scm_sum (SCM_MAKINUM (1L), n
), div
));
1094 /* Shift left is done by multiplication with 2^CNT */
1095 return scm_product (n
, scm_integer_expt (SCM_MAKINUM (2), cnt
));
1097 if (bits_to_shift
< 0)
1098 /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */
1099 return SCM_MAKINUM (SCM_SRS (SCM_INUM (n
), -bits_to_shift
));
1101 /* Shift left, but make sure not to leave the range of inums */
1102 SCM res
= SCM_MAKINUM (SCM_INUM (n
) << cnt
);
1103 if (SCM_INUM (res
) >> cnt
!= SCM_INUM (n
))
1104 scm_num_overflow (FUNC_NAME
);
1111 /* GJB:FIXME: do not use SCMs as integers! */
1112 SCM_DEFINE (scm_bit_extract
, "bit-extract", 3, 0, 0,
1113 (SCM n
, SCM start
, SCM end
),
1114 "Returns the integer composed of the @var{start} (inclusive) through\n"
1115 "@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes\n"
1116 "the 0-th bit in the result.@refill\n\n"
1119 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1120 " @result{} \"1010\"\n"
1121 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1122 " @result{} \"10110\"\n"
1124 #define FUNC_NAME s_scm_bit_extract
1127 SCM_VALIDATE_INUM (1,n
);
1128 SCM_VALIDATE_INUM_MIN_COPY (2,start
,0,istart
);
1129 SCM_VALIDATE_INUM_MIN_COPY (3, end
, 0, iend
);
1130 SCM_ASSERT_RANGE (3, end
, (iend
>= istart
));
1134 scm_logand (scm_difference (scm_integer_expt (SCM_MAKINUM (2),
1135 SCM_MAKINUM (iend
- istart
)),
1137 scm_ash (n
, SCM_MAKINUM (-istart
)));
1139 SCM_VALIDATE_INUM (1,n
);
1141 return SCM_MAKINUM ((SCM_INUM (n
) >> istart
) & ((1L << (iend
- istart
)) - 1));
1145 static const char scm_logtab
[] = {
1146 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1149 SCM_DEFINE (scm_logcount
, "logcount", 1, 0, 0,
1151 "Returns the number of bits in integer @var{n}. If integer is positive,\n"
1152 "the 1-bits in its binary representation are counted. If negative, the\n"
1153 "0-bits in its two's-complement binary representation are counted. If 0,\n"
1154 "0 is returned.\n\n"
1157 "(logcount #b10101010)\n"
1164 #define FUNC_NAME s_scm_logcount
1166 register unsigned long c
= 0;
1173 SCM_VALIDATE_BIGINT (1,n
);
1174 if (SCM_BIGSIGN (n
))
1175 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n
));
1176 ds
= SCM_BDIGITS (n
);
1177 for (i
= SCM_NUMDIGS (n
); i
--;)
1178 for (d
= ds
[i
]; d
; d
>>= 4)
1179 c
+= scm_logtab
[15 & d
];
1180 return SCM_MAKINUM (c
);
1183 SCM_VALIDATE_INUM (1,n
);
1185 if ((nn
= SCM_INUM (n
)) < 0)
1187 for (; nn
; nn
>>= 4)
1188 c
+= scm_logtab
[15 & nn
];
1189 return SCM_MAKINUM (c
);
1194 static const char scm_ilentab
[] = {
1195 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1198 SCM_DEFINE (scm_integer_length
, "integer-length", 1, 0, 0,
1200 "Returns the number of bits neccessary to represent @var{n}.\n\n"
1203 "(integer-length #b10101010)\n"
1205 "(integer-length 0)\n"
1207 "(integer-length #b1111)\n"
1210 #define FUNC_NAME s_scm_integer_length
1212 register unsigned long c
= 0;
1219 SCM_VALIDATE_BIGINT (1,n
);
1220 if (SCM_BIGSIGN (n
))
1221 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n
));
1222 ds
= SCM_BDIGITS (n
);
1223 d
= ds
[c
= SCM_NUMDIGS (n
) - 1];
1224 for (c
*= SCM_BITSPERDIG
; d
; d
>>= 4)
1227 l
= scm_ilentab
[15 & d
];
1229 return SCM_MAKINUM (c
- 4 + l
);
1232 SCM_VALIDATE_INUM (1,n
);
1234 if ((nn
= SCM_INUM (n
)) < 0)
1236 for (; nn
; nn
>>= 4)
1239 l
= scm_ilentab
[15 & nn
];
1241 return SCM_MAKINUM (c
- 4 + l
);
1247 static const char s_bignum
[] = "bignum";
1250 scm_mkbig (scm_sizet nlen
, int sign
)
1253 /* Cast to long int to avoid signed/unsigned comparison warnings. */
1254 if ((( ((long int) nlen
) << SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
)
1256 scm_wta (SCM_MAKINUM (nlen
), (char *) SCM_NALLOC
, s_bignum
);
1260 SCM_SETCHARS (v
, scm_must_malloc ((long) (nlen
* sizeof (SCM_BIGDIG
)),
1262 SCM_SETNUMDIGS (v
, nlen
, sign
);
1269 scm_big2inum (SCM b
, scm_sizet l
)
1271 unsigned long num
= 0;
1272 SCM_BIGDIG
*tmp
= SCM_BDIGITS (b
);
1274 num
= SCM_BIGUP (num
) + tmp
[l
];
1275 if (!SCM_BIGSIGN (b
))
1277 if (SCM_POSFIXABLE (num
))
1278 return SCM_MAKINUM (num
);
1280 else if (SCM_UNEGFIXABLE (num
))
1281 return SCM_MAKINUM (-num
);
1286 static const char s_adjbig
[] = "scm_adjbig";
1289 scm_adjbig (SCM b
, scm_sizet nlen
)
1291 scm_sizet nsiz
= nlen
;
1292 if (((nsiz
<< SCM_BIGSIZEFIELD
) >> SCM_BIGSIZEFIELD
) != nlen
)
1293 scm_wta (scm_ulong2num (nsiz
), (char *) SCM_NALLOC
, s_adjbig
);
1299 scm_must_realloc ((char *) SCM_CHARS (b
),
1300 (long) (SCM_NUMDIGS (b
) * sizeof (SCM_BIGDIG
)),
1301 (long) (nsiz
* sizeof (SCM_BIGDIG
)), s_adjbig
));
1303 SCM_SETCHARS (b
, digits
);
1304 SCM_SETNUMDIGS (b
, nsiz
, SCM_BIGSIGN (b
));
1316 scm_sizet nlen
= SCM_NUMDIGS (b
);
1318 int nlen
= SCM_NUMDIGS (b
); /* unsigned nlen breaks on Cray when nlen => 0 */
1320 SCM_BIGDIG
*zds
= SCM_BDIGITS (b
);
1321 while (nlen
-- && !zds
[nlen
]);
1323 if (nlen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
1324 if (SCM_INUMP (b
= scm_big2inum (b
, (scm_sizet
) nlen
)))
1326 if (SCM_NUMDIGS (b
) == nlen
)
1328 return scm_adjbig (b
, (scm_sizet
) nlen
);
1334 scm_copybig (SCM b
, int sign
)
1336 scm_sizet i
= SCM_NUMDIGS (b
);
1337 SCM ans
= scm_mkbig (i
, sign
);
1338 SCM_BIGDIG
*src
= SCM_BDIGITS (b
), *dst
= SCM_BDIGITS (ans
);
1347 scm_long2big (long n
)
1351 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, n
< 0);
1352 digits
= SCM_BDIGITS (ans
);
1355 while (i
< SCM_DIGSPERLONG
)
1357 digits
[i
++] = SCM_BIGLO (n
);
1358 n
= SCM_BIGDN ((unsigned long) n
);
1363 #ifdef HAVE_LONG_LONGS
1366 scm_long_long2big (long_long n
)
1376 if ((long long) tn
== n
)
1377 return scm_long2big (tn
);
1383 for (tn
= n
, n_digits
= 0;
1385 ++n_digits
, tn
= SCM_BIGDN ((ulong_long
) tn
))
1390 ans
= scm_mkbig (n_digits
, n
< 0);
1391 digits
= SCM_BDIGITS (ans
);
1394 while (i
< n_digits
)
1396 digits
[i
++] = SCM_BIGLO (n
);
1397 n
= SCM_BIGDN ((ulong_long
) n
);
1405 scm_2ulong2big (unsigned long *np
)
1412 ans
= scm_mkbig (2 * SCM_DIGSPERLONG
, 0);
1413 digits
= SCM_BDIGITS (ans
);
1416 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1418 digits
[i
] = SCM_BIGLO (n
);
1419 n
= SCM_BIGDN ((unsigned long) n
);
1422 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
1424 digits
[i
+ SCM_DIGSPERLONG
] = SCM_BIGLO (n
);
1425 n
= SCM_BIGDN ((unsigned long) n
);
1433 scm_ulong2big (unsigned long n
)
1437 SCM ans
= scm_mkbig (SCM_DIGSPERLONG
, 0);
1438 digits
= SCM_BDIGITS (ans
);
1439 while (i
< SCM_DIGSPERLONG
)
1441 digits
[i
++] = SCM_BIGLO (n
);
1450 scm_bigcomp (SCM x
, SCM y
)
1452 int xsign
= SCM_BIGSIGN (x
);
1453 int ysign
= SCM_BIGSIGN (y
);
1454 scm_sizet xlen
, ylen
;
1456 /* Look at the signs, first. */
1462 /* They're the same sign, so see which one has more digits. Note
1463 that, if they are negative, the longer number is the lesser. */
1464 ylen
= SCM_NUMDIGS (y
);
1465 xlen
= SCM_NUMDIGS (x
);
1467 return (xsign
) ? -1 : 1;
1469 return (xsign
) ? 1 : -1;
1471 /* They have the same number of digits, so find the most significant
1472 digit where they differ. */
1476 if (SCM_BDIGITS (y
)[xlen
] != SCM_BDIGITS (x
)[xlen
])
1477 /* Make the discrimination based on the digit that differs. */
1478 return ((SCM_BDIGITS (y
)[xlen
] > SCM_BDIGITS (x
)[xlen
])
1480 : (xsign
? 1 : -1));
1483 /* The numbers are identical. */
1487 #ifndef SCM_DIGSTOOBIG
1491 scm_pseudolong (long x
)
1496 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1502 while (i
< SCM_DIGSPERLONG
)
1504 p
.bd
[i
++] = SCM_BIGLO (x
);
1507 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1515 scm_longdigs (long x
, SCM_BIGDIG digs
[])
1520 while (i
< SCM_DIGSPERLONG
)
1522 digs
[i
++] = SCM_BIGLO (x
);
1531 scm_addbig (SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int sgny
)
1533 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1534 /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */
1536 scm_sizet i
= 0, ny
= SCM_NUMDIGS (bigy
);
1537 SCM z
= scm_copybig (bigy
, SCM_BIGSIGN (bigy
) ^ sgny
);
1538 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1539 if (xsgn
^ SCM_BIGSIGN (z
))
1543 num
+= (long) zds
[i
] - x
[i
];
1546 zds
[i
] = num
+ SCM_BIGRAD
;
1551 zds
[i
] = SCM_BIGLO (num
);
1556 if (num
&& nx
== ny
)
1560 SCM_SETCAR (z
, SCM_UNPACK_CAR (z
) ^ SCM_BIGSIGNFLAG
);
1563 num
+= (SCM_BIGRAD
- 1) - zds
[i
];
1564 zds
[i
++] = SCM_BIGLO (num
);
1565 num
= SCM_BIGDN (num
);
1575 zds
[i
++] = num
+ SCM_BIGRAD
;
1580 zds
[i
++] = SCM_BIGLO (num
);
1589 num
+= (long) zds
[i
] + x
[i
];
1590 zds
[i
++] = SCM_BIGLO (num
);
1591 num
= SCM_BIGDN (num
);
1599 zds
[i
++] = SCM_BIGLO (num
);
1600 num
= SCM_BIGDN (num
);
1606 z
= scm_adjbig (z
, ny
+ 1);
1607 SCM_BDIGITS (z
)[ny
] = num
;
1611 return scm_normbig (z
);
1616 scm_mulbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
)
1618 scm_sizet i
= 0, j
= nx
+ ny
;
1619 unsigned long n
= 0;
1620 SCM z
= scm_mkbig (j
, sgn
);
1621 SCM_BIGDIG
*zds
= SCM_BDIGITS (z
);
1631 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1632 zds
[i
+ j
++] = SCM_BIGLO (n
);
1644 return scm_normbig (z
);
1648 /* Sun's compiler complains about the fact that this function has an
1649 ANSI prototype in numbers.h, but a K&R declaration here, and the
1650 two specify different promotions for the third argument. I'm going
1651 to turn this into an ANSI declaration, and see if anyone complains
1652 about it not being K&R. */
1655 scm_divbigdig (SCM_BIGDIG
* ds
,
1659 register unsigned long t2
= 0;
1662 t2
= SCM_BIGUP (t2
) + ds
[h
];
1672 scm_divbigint (SCM x
, long z
, int sgn
, int mode
)
1678 register unsigned long t2
= 0;
1679 register SCM_BIGDIG
*ds
= SCM_BDIGITS (x
);
1680 scm_sizet nd
= SCM_NUMDIGS (x
);
1682 t2
= (SCM_BIGUP (t2
) + ds
[nd
]) % z
;
1685 return SCM_MAKINUM (sgn
? -t2
: t2
);
1688 #ifndef SCM_DIGSTOOBIG
1689 unsigned long t2
= scm_pseudolong (z
);
1690 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1691 (SCM_BIGDIG
*) & t2
, SCM_DIGSPERLONG
,
1694 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1695 scm_longdigs (z
, t2
);
1696 return scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
1697 t2
, SCM_DIGSPERLONG
,
1705 scm_divbigbig (SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
)
1707 /* modes description
1711 3 quotient but returns 0 if division is not exact. */
1712 scm_sizet i
= 0, j
= 0;
1714 unsigned long t2
= 0;
1716 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1717 /* algorithm requires nx >= ny */
1721 case 0: /* remainder -- just return x */
1722 z
= scm_mkbig (nx
, sgn
);
1723 zds
= SCM_BDIGITS (z
);
1730 case 1: /* scm_modulo -- return y-x */
1731 z
= scm_mkbig (ny
, sgn
);
1732 zds
= SCM_BDIGITS (z
);
1735 num
+= (long) y
[i
] - x
[i
];
1738 zds
[i
] = num
+ SCM_BIGRAD
;
1753 zds
[i
++] = num
+ SCM_BIGRAD
;
1764 return SCM_INUM0
; /* quotient is zero */
1766 return 0; /* the division is not exact */
1769 z
= scm_mkbig (nx
== ny
? nx
+ 2 : nx
+ 1, sgn
);
1770 zds
= SCM_BDIGITS (z
);
1774 ny
--; /* in case y came in as a psuedolong */
1775 if (y
[ny
- 1] < (SCM_BIGRAD
>> 1))
1776 { /* normalize operands */
1777 d
= SCM_BIGRAD
/ (y
[ny
- 1] + 1);
1778 newy
= scm_mkbig (ny
, 0);
1779 yds
= SCM_BDIGITS (newy
);
1782 t2
+= (unsigned long) y
[j
] * d
;
1783 yds
[j
++] = SCM_BIGLO (t2
);
1784 t2
= SCM_BIGDN (t2
);
1791 t2
+= (unsigned long) x
[j
] * d
;
1792 zds
[j
++] = SCM_BIGLO (t2
);
1793 t2
= SCM_BIGDN (t2
);
1803 j
= nx
== ny
? nx
+ 1 : nx
; /* dividend needs more digits than divisor */
1805 { /* loop over digits of quotient */
1806 if (zds
[j
] == y
[ny
- 1])
1807 qhat
= SCM_BIGRAD
- 1;
1809 qhat
= (SCM_BIGUP (zds
[j
]) + zds
[j
- 1]) / y
[ny
- 1];
1816 { /* multiply and subtract */
1817 t2
+= (unsigned long) y
[i
] * qhat
;
1818 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO (t2
);
1821 zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
;
1826 zds
[j
- ny
+ i
] = num
;
1829 t2
= SCM_BIGDN (t2
);
1832 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1834 { /* "add back" required */
1840 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1841 zds
[j
- ny
+ i
] = SCM_BIGLO (num
);
1842 num
= SCM_BIGDN (num
);
1853 case 3: /* check that remainder==0 */
1854 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1857 case 2: /* move quotient down in z */
1858 j
= (nx
== ny
? nx
+ 2 : nx
+ 1) - ny
;
1859 for (i
= 0; i
< j
; i
++)
1860 zds
[i
] = zds
[i
+ ny
];
1863 case 1: /* subtract for scm_modulo */
1869 num
+= y
[i
] - zds
[i
];
1873 zds
[i
] = num
+ SCM_BIGRAD
;
1885 case 0: /* just normalize remainder */
1887 scm_divbigdig (zds
, ny
, d
);
1890 for (j
= ny
; j
&& !zds
[j
- 1]; --j
);
1891 if (j
* SCM_BITSPERDIG
<= sizeof (SCM
) * SCM_CHAR_BIT
)
1892 if (SCM_INUMP (z
= scm_big2inum (z
, j
)))
1894 return scm_adjbig (z
, j
);
1902 /*** NUMBERS -> STRINGS ***/
1904 static const double fx
[] =
1905 { 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1906 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1907 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1908 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
1914 idbl2str (double f
, char *a
)
1916 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1921 goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1940 #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1941 make-uniform-vector, from causing infinite loops. */
1945 if (exp
-- < DBL_MIN_10_EXP
)
1951 if (exp
++ > DBL_MAX_10_EXP
)
1966 if (f
+ fx
[wp
] >= 10.0)
1973 dpt
= (exp
+ 9999) % 3;
1977 efmt
= (exp
< -3) || (exp
> wp
+ 2);
2002 if (f
+ fx
[wp
] >= 1.0)
2016 if ((dpt
> 4) && (exp
> 6))
2018 d
= (a
[0] == '-' ? 2 : 1);
2019 for (i
= ch
++; i
> d
; i
--)
2032 if (a
[ch
- 1] == '.')
2033 a
[ch
++] = '0'; /* trailing zero */
2042 for (i
= 10; i
<= exp
; i
*= 10);
2043 for (i
/= 10; i
; i
/= 10)
2045 a
[ch
++] = exp
/ i
+ '0';
2054 iflo2str (SCM flt
, char *str
)
2057 if (SCM_SLOPPY_REALP (flt
))
2058 i
= idbl2str (SCM_REAL_VALUE (flt
), str
);
2061 i
= idbl2str (SCM_COMPLEX_REAL (flt
), str
);
2062 if (SCM_COMPLEX_IMAG (flt
) != 0.0)
2064 if (0 <= SCM_COMPLEX_IMAG (flt
))
2066 i
+= idbl2str (SCM_COMPLEX_IMAG (flt
), &str
[i
]);
2073 /* convert a long to a string (unterminated). returns the number of
2074 characters in the result.
2076 p is destination: worst case (base 2) is SCM_INTBUFLEN */
2078 scm_iint2str (long num
, int rad
, char *p
)
2082 unsigned long n
= (num
< 0) ? -num
: num
;
2084 for (n
/= rad
; n
> 0; n
/= rad
)
2101 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
2110 big2str (SCM b
, unsigned int radix
)
2112 SCM t
= scm_copybig (b
, 0); /* sign of temp doesn't matter */
2113 register SCM_BIGDIG
*ds
= SCM_BDIGITS (t
);
2114 scm_sizet i
= SCM_NUMDIGS (t
);
2115 scm_sizet j
= radix
== 16 ? (SCM_BITSPERDIG
* i
) / 4 + 2
2116 : radix
>= 10 ? (SCM_BITSPERDIG
* i
* 241L) / 800 + 2
2117 : (SCM_BITSPERDIG
* i
) + 2;
2119 scm_sizet radct
= 0;
2120 scm_sizet ch
; /* jeh */
2121 SCM_BIGDIG radpow
= 1, radmod
= 0;
2122 SCM ss
= scm_makstr ((long) j
, 0);
2123 char *s
= SCM_CHARS (ss
), c
;
2124 while ((long) radpow
* radix
< SCM_BIGRAD
)
2129 s
[0] = SCM_BIGSIGN (b
) ? '-' : '+';
2130 while ((i
|| radmod
) && j
)
2134 radmod
= (SCM_BIGDIG
) scm_divbigdig (ds
, i
, radpow
);
2142 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
2144 ch
= s
[0] == '-' ? 1 : 0; /* jeh */
2147 for (i
= j
; j
< SCM_LENGTH (ss
); j
++)
2148 s
[ch
+ j
- i
] = s
[j
]; /* jeh */
2149 scm_vector_set_length_x (ss
, /* jeh */
2150 (SCM
) SCM_MAKINUM (ch
+ SCM_LENGTH (ss
) - i
));
2153 return scm_return_first (ss
, t
);
2158 SCM_DEFINE (scm_number_to_string
, "number->string", 1, 1, 0,
2161 #define FUNC_NAME s_scm_number_to_string
2164 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2167 char num_buf
[SCM_FLOBUFLEN
];
2169 SCM_ASRTGO (SCM_NIMP (x
), badx
);
2171 return big2str (x
, (unsigned int) base
);
2172 #ifndef SCM_RECKLESS
2173 if (!SCM_SLOPPY_INEXACTP (x
))
2180 SCM_ASSERT (SCM_SLOPPY_INEXACTP (x
),
2181 x
, SCM_ARG1
, s_number_to_string
);
2183 return scm_makfromstr (num_buf
, iflo2str (x
, num_buf
), 0);
2186 char num_buf
[SCM_INTBUFLEN
];
2187 return scm_makfromstr (num_buf
,
2188 scm_iint2str (SCM_INUM (x
),
2197 /* These print routines are stubbed here so that scm_repl.c doesn't need
2198 SCM_BIGDIG conditionals */
2201 scm_print_real (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2203 char num_buf
[SCM_FLOBUFLEN
];
2204 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2209 scm_print_complex (SCM sexp
, SCM port
, scm_print_state
*pstate
)
2211 char num_buf
[SCM_FLOBUFLEN
];
2212 scm_lfwrite (num_buf
, iflo2str (sexp
, num_buf
), port
);
2217 scm_bigprint (SCM exp
, SCM port
, scm_print_state
*pstate
)
2220 exp
= big2str (exp
, (unsigned int) 10);
2221 scm_lfwrite (SCM_CHARS (exp
), (scm_sizet
) SCM_LENGTH (exp
), port
);
2223 scm_ipruk ("bignum", exp
, port
);
2227 /*** END nums->strs ***/
2229 /*** STRINGS -> NUMBERS ***/
2232 scm_small_istr2int (char *str
, long len
, long radix
)
2234 register long n
= 0, ln
;
2239 return SCM_BOOL_F
; /* zero scm_length */
2241 { /* leading sign */
2246 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2251 switch (c
= str
[i
++])
2273 return SCM_BOOL_F
; /* bad digit for radix */
2276 /* Negation is a workaround for HP700 cc bug */
2277 if (n
> ln
|| (-n
> -SCM_MOST_NEGATIVE_FIXNUM
))
2281 return SCM_BOOL_F
; /* not a digit */
2286 if ((n
= -n
) > SCM_MOST_POSITIVE_FIXNUM
)
2288 return SCM_MAKINUM (n
);
2289 ovfl
: /* overflow scheme integer */
2296 scm_istr2int (char *str
, long len
, long radix
)
2299 register scm_sizet k
, blen
= 1;
2303 register SCM_BIGDIG
*ds
;
2304 register unsigned long t2
;
2307 return SCM_BOOL_F
; /* zero scm_length */
2309 /* Short numbers we parse directly into an int, to avoid the overhead
2310 of creating a bignum. */
2312 return scm_small_istr2int (str
, len
, radix
);
2315 j
= 1 + (4 * len
* sizeof (char)) / (SCM_BITSPERDIG
);
2316 else if (10 <= radix
)
2317 j
= 1 + (84 * len
* sizeof (char)) / (SCM_BITSPERDIG
* 25);
2319 j
= 1 + (len
* sizeof (char)) / (SCM_BITSPERDIG
);
2321 { /* leading sign */
2324 if (++i
== (unsigned) len
)
2325 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2327 res
= scm_mkbig (j
, '-' == str
[0]);
2328 ds
= SCM_BDIGITS (res
);
2333 switch (c
= str
[i
++])
2355 return SCM_BOOL_F
; /* bad digit for radix */
2361 /* printf ("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]); */
2362 t2
+= ds
[k
] * radix
;
2363 ds
[k
++] = SCM_BIGLO (t2
);
2364 t2
= SCM_BIGDN (t2
);
2367 scm_num_overflow ("bignum");
2375 return SCM_BOOL_F
; /* not a digit */
2378 while (i
< (unsigned) len
);
2379 if (blen
* SCM_BITSPERDIG
/ SCM_CHAR_BIT
<= sizeof (SCM
))
2380 if (SCM_INUMP (res
= scm_big2inum (res
, blen
)))
2384 return scm_adjbig (res
, blen
);
2388 scm_istr2flo (char *str
, long len
, long radix
)
2390 register int c
, i
= 0;
2392 double res
= 0.0, tmp
= 0.0;
2398 return SCM_BOOL_F
; /* zero scm_length */
2401 { /* leading sign */
2414 return SCM_BOOL_F
; /* bad if lone `+' or `-' */
2416 if (str
[i
] == 'i' || str
[i
] == 'I')
2417 { /* handle `+i' and `-i' */
2418 if (lead_sgn
== 0.0)
2419 return SCM_BOOL_F
; /* must have leading sign */
2421 return SCM_BOOL_F
; /* `i' not last character */
2422 return scm_makdbl (0.0, lead_sgn
);
2425 { /* check initial digits */
2435 goto out1
; /* must be exponent */
2452 return SCM_BOOL_F
; /* bad digit for radix */
2453 res
= res
* radix
+ c
;
2454 flg
= 1; /* res is valid */
2463 /* if true, then we did see a digit above, and res is valid */
2467 /* By here, must have seen a digit,
2468 or must have next char be a `.' with radix==10 */
2470 if (!(str
[i
] == '.' && radix
== 10))
2473 while (str
[i
] == '#')
2474 { /* optional sharps */
2507 tmp
= tmp
* radix
+ c
;
2515 return SCM_BOOL_F
; /* `slash zero' not allowed */
2517 while (str
[i
] == '#')
2518 { /* optional sharps */
2528 { /* decimal point notation */
2530 return SCM_BOOL_F
; /* must be radix 10 */
2537 res
= res
* 10.0 + c
- '0';
2546 return SCM_BOOL_F
; /* no digits before or after decimal point */
2549 while (str
[i
] == '#')
2550 { /* ignore remaining sharps */
2569 int expsgn
= 1, expon
= 0;
2571 return SCM_BOOL_F
; /* only in radix 10 */
2573 return SCM_BOOL_F
; /* bad exponent */
2580 return SCM_BOOL_F
; /* bad exponent */
2582 if (str
[i
] < '0' || str
[i
] > '9')
2583 return SCM_BOOL_F
; /* bad exponent */
2589 expon
= expon
* 10 + c
- '0';
2590 if (expon
> SCM_MAXEXP
)
2591 return SCM_BOOL_F
; /* exponent too large */
2599 point
+= expsgn
* expon
;
2617 /* at this point, we have a legitimate floating point result */
2618 if (lead_sgn
== -1.0)
2621 return scm_makdbl (res
, 0.0);
2623 if (str
[i
] == 'i' || str
[i
] == 'I')
2624 { /* pure imaginary number */
2625 if (lead_sgn
== 0.0)
2626 return SCM_BOOL_F
; /* must have leading sign */
2628 return SCM_BOOL_F
; /* `i' not last character */
2629 return scm_makdbl (0.0, res
);
2641 { /* polar input for complex number */
2642 /* get a `real' for scm_angle */
2643 second
= scm_istr2flo (&str
[i
], (long) (len
- i
), radix
);
2644 if (!SCM_SLOPPY_INEXACTP (second
))
2645 return SCM_BOOL_F
; /* not `real' */
2646 if (SCM_SLOPPY_COMPLEXP (second
))
2647 return SCM_BOOL_F
; /* not `real' */
2648 tmp
= SCM_REALPART (second
);
2649 return scm_makdbl (res
* cos (tmp
), res
* sin (tmp
));
2655 /* at this point, last char must be `i' */
2656 if (str
[len
- 1] != 'i' && str
[len
- 1] != 'I')
2658 /* handles `x+i' and `x-i' */
2660 return scm_makdbl (res
, lead_sgn
);
2661 /* get a `ureal' for complex part */
2662 second
= scm_istr2flo (&str
[i
], (long) ((len
- i
) - 1), radix
);
2663 if (!SCM_INEXACTP (second
))
2664 return SCM_BOOL_F
; /* not `ureal' */
2665 if (SCM_SLOPPY_COMPLEXP (second
))
2666 return SCM_BOOL_F
; /* not `ureal' */
2667 tmp
= SCM_REALPART (second
);
2669 return SCM_BOOL_F
; /* not `ureal' */
2670 return scm_makdbl (res
, (lead_sgn
* tmp
));
2676 scm_istring2number (char *str
, long len
, long radix
)
2680 char ex_p
= 0, rx_p
= 0; /* Only allow 1 exactness and 1 radix prefix */
2683 if (*str
== '+' || *str
== '-') /* Catches lone `+' and `-' for speed */
2686 while ((len
- i
) >= 2 && str
[i
] == '#' && ++i
)
2732 return scm_istr2int (&str
[i
], len
- i
, radix
);
2734 res
= scm_istr2int (&str
[i
], len
- i
, radix
);
2735 if (SCM_NFALSEP (res
))
2738 return scm_istr2flo (&str
[i
], len
- i
, radix
);
2744 SCM_DEFINE (scm_string_to_number
, "string->number", 1, 1, 0,
2745 (SCM str
, SCM radix
),
2747 #define FUNC_NAME s_scm_string_to_number
2751 SCM_VALIDATE_ROSTRING (1,str
);
2752 SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix
,2,10,base
);
2753 answer
= scm_istring2number (SCM_ROCHARS (str
),
2756 return scm_return_first (answer
, str
);
2759 /*** END strs->nums ***/
2762 scm_make_real (double x
)
2770 scm_make_complex (double x
, double y
)
2773 SCM_NEWCOMPLEX (z
, x
, y
);
2778 scm_bigequal (SCM x
, SCM y
)
2781 if (0 == scm_bigcomp (x
, y
))
2788 scm_real_equalp (SCM x
, SCM y
)
2790 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2794 scm_complex_equalp (SCM x
, SCM y
)
2796 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2797 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2802 SCM_REGISTER_PROC (s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2804 SCM_DEFINE (scm_number_p
, "complex?", 1, 0, 0,
2807 #define FUNC_NAME s_scm_number_p
2819 SCM_REGISTER_PROC (s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2822 SCM_DEFINE (scm_real_p
, "rational?", 1, 0, 0,
2825 #define FUNC_NAME s_scm_real_p
2831 if (SCM_SLOPPY_REALP (x
))
2843 SCM_DEFINE (scm_integer_p
, "integer?", 1, 0, 0,
2846 #define FUNC_NAME s_scm_integer_p
2857 if (!SCM_SLOPPY_INEXACTP (x
))
2859 if (SCM_SLOPPY_COMPLEXP (x
))
2861 r
= SCM_REALPART (x
);
2870 SCM_DEFINE (scm_inexact_p
, "inexact?", 1, 0, 0,
2873 #define FUNC_NAME s_scm_inexact_p
2875 if (SCM_INEXACTP (x
))
2884 SCM_GPROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
, g_eq_p
);
2887 scm_num_eq_p (SCM x
, SCM y
)
2896 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
2902 SCM_ASRTGO (SCM_NIMP (y
), bady
);
2904 return SCM_BOOL(0 == scm_bigcomp (x
, y
));
2905 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
2907 return ((SCM_SLOPPY_REALP (y
) && (scm_big2dbl (x
) == SCM_REALPART (y
)))
2911 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx
);
2913 SCM_GASSERT2 (SCM_SLOPPY_INEXACTP (x
),
2914 g_eq_p
, x
, y
, SCM_ARG1
, s_eq_p
);
2924 SCM_ASRTGO (SCM_NIMP (y
), bady
);
2932 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
2934 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
2936 if (SCM_SLOPPY_REALP (x
))
2938 if (SCM_SLOPPY_REALP (y
))
2939 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_REAL_VALUE (y
));
2941 return SCM_BOOL (SCM_REAL_VALUE (x
) == SCM_COMPLEX_REAL (y
)
2942 && 0.0 == SCM_COMPLEX_IMAG (y
));
2946 if (SCM_SLOPPY_REALP (y
))
2947 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_REAL_VALUE (y
)
2948 && SCM_COMPLEX_IMAG (x
) == 0.0);
2950 return SCM_BOOL (SCM_COMPLEX_REAL (x
) == SCM_COMPLEX_REAL (y
)
2951 && SCM_COMPLEX_IMAG (x
) == SCM_COMPLEX_IMAG (y
));
2957 SCM_ASRTGO (SCM_NIMP (y
), bady
);
2960 if (!SCM_SLOPPY_INEXACTP (y
))
2963 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2966 if (!SCM_SLOPPY_INEXACTP (y
))
2969 SCM_WTA_DISPATCH_2 (g_eq_p
, x
, y
, SCM_ARGn
, s_eq_p
);
2973 if (SCM_SLOPPY_REALP (y
))
2974 return SCM_BOOL ((double) SCM_INUM (x
) == SCM_REAL_VALUE (y
));
2976 return SCM_BOOL ((double) SCM_INUM (x
) == SCM_COMPLEX_REAL (y
)
2977 && 0.0 == SCM_COMPLEX_IMAG (y
));
2979 return SCM_BOOL((long) x
== (long) y
);
2984 SCM_GPROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
, g_less_p
);
2987 scm_less_p (SCM x
, SCM y
)
2995 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3000 return SCM_BOOL(SCM_BIGSIGN (x
));
3001 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3003 return SCM_BOOL(1 == scm_bigcomp (x
, y
));
3004 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3005 return ((scm_big2dbl (x
) < SCM_REALPART (y
))
3009 SCM_ASRTGO (SCM_SLOPPY_REALP (x
), badx
);
3011 SCM_GASSERT2 (SCM_SLOPPY_REALP (x
),
3012 g_less_p
, x
, y
, SCM_ARG1
, s_less_p
);
3015 return ((SCM_REALPART (x
) < ((double) SCM_INUM (y
)))
3019 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3021 return SCM_BOOL(SCM_REALPART (x
) < scm_big2dbl (y
));
3022 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3024 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3026 return SCM_BOOL(SCM_REALPART (x
) < SCM_REALPART (y
));
3031 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3033 return SCM_NEGATE_BOOL(SCM_BIGSIGN (y
));
3034 if (!SCM_SLOPPY_REALP (y
))
3037 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3040 if (!SCM_SLOPPY_REALP (y
))
3043 SCM_WTA_DISPATCH_2 (g_less_p
, x
, y
, SCM_ARGn
, s_less_p
);
3046 return ((((double) SCM_INUM (x
)) < SCM_REALPART (y
))
3050 return SCM_BOOL((long) x
< (long) y
);
3054 SCM_DEFINE1 (scm_gr_p
, ">", scm_tc7_rpsubr
,
3057 #define FUNC_NAME s_scm_gr_p
3059 return scm_less_p (y
, x
);
3065 SCM_DEFINE1 (scm_leq_p
, "<=", scm_tc7_rpsubr
,
3068 #define FUNC_NAME s_scm_leq_p
3070 return SCM_BOOL_NOT (scm_less_p (y
, x
));
3076 SCM_DEFINE1 (scm_geq_p
, ">=", scm_tc7_rpsubr
,
3079 #define FUNC_NAME s_scm_geq_p
3081 return SCM_BOOL_NOT (scm_less_p (x
, y
));
3087 SCM_GPROC (s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
, g_zero_p
);
3095 SCM_ASRTGO (SCM_NIMP (z
), badz
);
3098 if (!SCM_SLOPPY_INEXACTP (z
))
3101 SCM_WTA_DISPATCH_1 (g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3104 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
3105 g_zero_p
, z
, SCM_ARG1
, s_zero_p
);
3107 if (SCM_SLOPPY_REALP (z
))
3108 return SCM_BOOL (SCM_REAL_VALUE (z
) == 0.0);
3110 return SCM_BOOL (SCM_COMPLEX_REAL (z
) == 0.0
3111 && SCM_COMPLEX_IMAG (z
) == 0.0);
3113 return SCM_BOOL(z
== SCM_INUM0
);
3118 SCM_GPROC (s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
, g_positive_p
);
3121 scm_positive_p (SCM x
)
3126 SCM_ASRTGO (SCM_NIMP (x
), badx
);
3128 return SCM_BOOL (!SCM_BIGSIGN (x
));
3129 if (!SCM_SLOPPY_REALP (x
))
3132 SCM_WTA_DISPATCH_1 (g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3135 SCM_GASSERT1 (SCM_SLOPPY_REALP (x
),
3136 g_positive_p
, x
, SCM_ARG1
, s_positive_p
);
3138 return SCM_BOOL(SCM_REALPART (x
) > 0.0);
3140 return SCM_BOOL(SCM_INUM(x
) > 0);
3145 SCM_GPROC (s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
, g_negative_p
);
3148 scm_negative_p (SCM x
)
3153 SCM_ASRTGO (SCM_NIMP (x
), badx
);
3155 return SCM_BOOL (SCM_BIGSIGN (x
));
3156 if (!(SCM_SLOPPY_REALP (x
)))
3159 SCM_WTA_DISPATCH_1 (g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3162 SCM_GASSERT1 (SCM_SLOPPY_REALP (x
),
3163 g_negative_p
, x
, SCM_ARG1
, s_negative_p
);
3165 return SCM_BOOL(SCM_REALPART (x
) < 0.0);
3167 return SCM_BOOL(SCM_INUM(x
) < 0);
3171 SCM_GPROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
, g_max
);
3174 scm_max (SCM x
, SCM y
)
3179 SCM_GASSERT0 (!SCM_UNBNDP (x
),
3180 g_max
, scm_makfrom0str (s_max
), SCM_WNA
, 0);
3181 SCM_GASSERT1 (SCM_NUMBERP (x
), g_max
, x
, SCM_ARG1
, s_max
);
3190 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARG1
, s_max
);
3195 return SCM_BIGSIGN (x
) ? y
: x
;
3196 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3198 return (1 == scm_bigcomp (x
, y
)) ? y
: x
;
3199 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3200 z
= scm_big2dbl (x
);
3201 return (z
< SCM_REALPART (y
)) ? y
: scm_makdbl (z
, 0.0);
3203 SCM_ASRTGO (SCM_SLOPPY_REALP (x
), badx2
);
3205 SCM_GASSERT2 (SCM_SLOPPY_REALP (x
),
3206 g_max
, x
, y
, SCM_ARG1
, s_max
);
3209 return ((SCM_REALPART (x
) < (z
= SCM_INUM (y
)))
3210 ? scm_makdbl (z
, 0.0)
3213 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3215 return ((SCM_REALPART (x
) < (z
= scm_big2dbl (y
)))
3216 ? scm_makdbl (z
, 0.0)
3218 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3220 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3222 return (SCM_REALPART (x
) < SCM_REALPART (y
)) ? y
: x
;
3227 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3229 return SCM_BIGSIGN (y
) ? x
: y
;
3230 if (!(SCM_SLOPPY_REALP (y
)))
3233 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3236 if (!SCM_SLOPPY_REALP (y
))
3239 SCM_WTA_DISPATCH_2 (g_max
, x
, y
, SCM_ARGn
, s_max
);
3242 return (((z
= SCM_INUM (x
)) < SCM_REALPART (y
))
3244 : scm_makdbl (z
, 0.0));
3246 return ((long) x
< (long) y
) ? y
: x
;
3250 #define SCM_SWAP(x,y) do { SCM t = x; x = y; y = t; } while (0)
3254 SCM_GPROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
, g_min
);
3257 scm_min (SCM x
, SCM y
)
3262 SCM_GASSERT0 (!SCM_UNBNDP (x
),
3263 g_min
, scm_makfrom0str (s_min
), SCM_WNA
, 0);
3264 SCM_GASSERT1 (SCM_NUMBERP (x
), g_min
, x
, SCM_ARG1
, s_min
);
3273 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARG1
, s_min
);
3278 return SCM_BIGSIGN (x
) ? x
: y
;
3279 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3281 return (-1 == scm_bigcomp (x
, y
)) ? y
: x
;
3282 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3283 z
= scm_big2dbl (x
);
3284 return (z
> SCM_REALPART (y
)) ? y
: scm_makdbl (z
, 0.0);
3286 SCM_ASRTGO (SCM_SLOPPY_REALP (x
), badx2
);
3288 SCM_GASSERT2 (SCM_SLOPPY_REALP (x
),
3289 g_min
, x
, y
, SCM_ARG1
, s_min
);
3292 return ((SCM_REALPART (x
) > (z
= SCM_INUM (y
)))
3293 ? scm_makdbl (z
, 0.0)
3296 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3298 return ((SCM_REALPART (x
) > (z
= scm_big2dbl (y
)))
3299 ? scm_makdbl (z
, 0.0)
3301 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3303 SCM_ASRTGO (SCM_SLOPPY_REALP (y
), bady
);
3305 return (SCM_REALPART (x
) > SCM_REALPART (y
)) ? y
: x
;
3310 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3312 return SCM_BIGSIGN (y
) ? y
: x
;
3313 if (!(SCM_SLOPPY_REALP (y
)))
3316 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3319 if (!SCM_SLOPPY_REALP (y
))
3322 SCM_WTA_DISPATCH_2 (g_min
, x
, y
, SCM_ARGn
, s_min
);
3325 return (((z
= SCM_INUM (x
)) > SCM_REALPART (y
))
3327 : scm_makdbl (z
, 0.0));
3329 return ((long) x
> (long) y
) ? y
: x
;
3335 SCM_GPROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
, g_sum
);
3338 This is sick, sick, sick code.
3342 scm_sum (SCM x
, SCM y
)
3348 SCM_GASSERT1 (SCM_NUMBERP (x
), g_sum
, x
, SCM_ARG1
, s_sum
);
3357 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARG1
, s_sum
);
3366 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3369 if (SCM_NUMDIGS (x
) > SCM_NUMDIGS (y
))
3373 return scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3377 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3379 if (SCM_SLOPPY_REALP (y
))
3380 return scm_make_real (scm_big2dbl (x
) + SCM_REAL_VALUE (y
));
3382 return scm_make_complex (scm_big2dbl (x
) + SCM_COMPLEX_REAL (y
),
3383 SCM_COMPLEX_IMAG (y
));
3385 # endif /* SCM_BIGDIG */
3386 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3394 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3400 else if (!SCM_SLOPPY_INEXACTP (y
))
3403 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3405 # else /* SCM_BIGDIG */
3406 if (!SCM_SLOPPY_INEXACTP (y
))
3409 SCM_WTA_DISPATCH_2 (g_sum
, x
, y
, SCM_ARGn
, s_sum
);
3411 # endif /* SCM_BIGDIG */
3414 if (SCM_SLOPPY_COMPLEXP (x
))
3415 i
= SCM_COMPLEX_IMAG (x
);
3416 if (SCM_SLOPPY_COMPLEXP (y
))
3417 i
+= SCM_COMPLEX_IMAG (y
);
3418 return scm_makdbl (SCM_REALPART (x
) + SCM_REALPART (y
), i
);
3424 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3429 long i
= SCM_INUM (x
);
3430 # ifndef SCM_DIGSTOOBIG
3431 long z
= scm_pseudolong (i
);
3432 return scm_addbig ((SCM_BIGDIG
*) & z
,
3434 (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3436 # else /* SCM_DIGSTOOBIG */
3437 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3438 scm_longdigs (i
, zdigs
);
3439 return scm_addbig (zdigs
, SCM_DIGSPERLONG
, (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3441 # endif /* SCM_DIGSTOOBIG */
3444 # endif /* SCM_BIGDIG */
3445 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3448 return scm_make_real (SCM_INUM (x
) + SCM_REAL_VALUE (y
));
3450 return scm_make_complex (SCM_INUM (x
) + SCM_COMPLEX_REAL (y
),
3451 SCM_COMPLEX_IMAG (y
));
3454 long int i
= SCM_INUM (x
) + SCM_INUM (y
);
3455 if (SCM_FIXABLE (i
))
3456 return SCM_MAKINUM (i
);
3458 return scm_long2big (i
);
3459 #else /* SCM_BIGDIG */
3460 return scm_makdbl ((double) i
, 0.0);
3461 #endif /* SCM_BIGDIG */
3468 SCM_GPROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
, g_difference
);
3471 HWN:FIXME:: This is sick,sick, sick code. Rewrite me.
3474 scm_difference (SCM x
, SCM y
)
3483 SCM_GASSERT0 (!SCM_UNBNDP (x
), g_difference
,
3484 scm_makfrom0str (s_difference
), SCM_WNA
, 0);
3486 SCM_WTA_DISPATCH_1 (g_difference
, x
, SCM_ARG1
, s_difference
);
3491 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARG1
, s_difference
);
3499 x
= scm_copybig (x
, !SCM_BIGSIGN (x
));
3500 return (SCM_NUMDIGS (x
) * SCM_BITSPERDIG
/ SCM_CHAR_BIT
3502 ? scm_big2inum (x
, SCM_NUMDIGS (x
))
3506 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx
);
3507 if (SCM_SLOPPY_REALP (x
))
3508 return scm_make_real (- SCM_REAL_VALUE (x
));
3510 return scm_make_complex (- SCM_COMPLEX_REAL (x
),
3511 - SCM_COMPLEX_IMAG (x
));
3514 return scm_sum (x
, SCM_MAKINUM (- SCM_INUM (y
)));
3516 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3520 return ((SCM_NUMDIGS (x
) < SCM_NUMDIGS (y
))
3521 ? scm_addbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3524 : scm_addbig (SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3525 SCM_BIGSIGN (y
) ^ SCM_BIGSIGNFLAG
,
3527 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3529 return scm_make_real (scm_big2dbl (x
) - SCM_REAL_VALUE (y
));
3531 return scm_make_complex (scm_big2dbl (x
) - SCM_COMPLEX_REAL (y
),
3532 - SCM_COMPLEX_IMAG (y
));
3534 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3538 return scm_make_real (SCM_REAL_VALUE (x
) - scm_big2dbl (y
));
3540 return scm_make_complex (SCM_COMPLEX_REAL (x
) - scm_big2dbl (y
),
3541 SCM_COMPLEX_IMAG (x
));
3543 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3545 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3546 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3550 if (SCM_SLOPPY_COMPLEXP (x
))
3552 if (SCM_SLOPPY_COMPLEXP (y
))
3554 SCM_COMPLEX_REAL (x
) - SCM_COMPLEX_REAL (y
),
3555 SCM_COMPLEX_IMAG (x
) - SCM_COMPLEX_IMAG (y
));
3558 SCM_COMPLEX_REAL (x
) - SCM_REAL_VALUE (y
),
3559 SCM_COMPLEX_IMAG (x
));
3563 if (SCM_SLOPPY_COMPLEXP (y
))
3565 SCM_REAL_VALUE (x
) - SCM_COMPLEX_REAL (y
),
3566 - SCM_COMPLEX_IMAG (y
));
3568 SCM_NEWREAL (z
, SCM_REAL_VALUE (x
) - SCM_REAL_VALUE (y
));
3581 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3584 long i
= SCM_INUM (x
);
3585 #ifndef SCM_DIGSTOOBIG
3586 long z
= scm_pseudolong (i
);
3587 return scm_addbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3588 (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3589 y
, SCM_BIGSIGNFLAG
);
3591 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3592 scm_longdigs (i
, zdigs
);
3593 return scm_addbig (zdigs
, SCM_DIGSPERLONG
, (i
< 0) ? SCM_BIGSIGNFLAG
: 0,
3594 y
, SCM_BIGSIGNFLAG
);
3597 if (!SCM_SLOPPY_INEXACTP (y
))
3600 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3603 if (!SCM_SLOPPY_INEXACTP (y
))
3606 SCM_WTA_DISPATCH_2 (g_difference
, x
, y
, SCM_ARGn
, s_difference
);
3609 return scm_makdbl (SCM_INUM (x
) - SCM_REALPART (y
),
3610 SCM_SLOPPY_COMPLEXP (y
) ? -SCM_IMAG (y
) : 0.0);
3612 cx
= SCM_INUM (x
) - SCM_INUM (y
);
3614 if (SCM_FIXABLE (cx
))
3615 return SCM_MAKINUM (cx
);
3617 return scm_long2big (cx
);
3619 return scm_makdbl ((double) cx
, 0.0);
3626 SCM_GPROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
, g_product
);
3629 scm_product (SCM x
, SCM y
)
3634 return SCM_MAKINUM (1L);
3635 SCM_GASSERT1 (SCM_NUMBERP (x
), g_product
, x
, SCM_ARG1
, s_product
);
3645 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARG1
, s_product
);
3656 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3658 return scm_mulbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3659 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3660 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
));
3661 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3664 double bg
= scm_big2dbl (x
);
3665 return scm_makdbl (bg
* SCM_REALPART (y
),
3666 SCM_SLOPPY_COMPLEXP (y
) ? bg
* SCM_IMAG (y
) : 0.0);
3669 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3671 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3681 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3689 else if (!(SCM_SLOPPY_INEXACTP (y
)))
3692 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3695 if (!SCM_SLOPPY_INEXACTP (y
))
3698 SCM_WTA_DISPATCH_2 (g_product
, x
, y
, SCM_ARGn
, s_product
);
3701 if (SCM_SLOPPY_COMPLEXP (x
))
3703 if (SCM_SLOPPY_COMPLEXP (y
))
3704 return scm_makdbl (SCM_REAL (x
) * SCM_REAL (y
)
3705 - SCM_IMAG (x
) * SCM_IMAG (y
),
3706 SCM_REAL (x
) * SCM_IMAG (y
)
3707 + SCM_IMAG (x
) * SCM_REAL (y
));
3709 return scm_makdbl (SCM_REAL (x
) * SCM_REALPART (y
),
3710 SCM_IMAG (x
) * SCM_REALPART (y
));
3712 return scm_makdbl (SCM_REALPART (x
) * SCM_REALPART (y
),
3713 SCM_SLOPPY_COMPLEXP (y
)
3714 ? SCM_REALPART (x
) * SCM_IMAG (y
)
3720 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3726 if (SCM_MAKINUM (1L) == x
)
3729 #ifndef SCM_DIGSTOOBIG
3730 long z
= scm_pseudolong (SCM_INUM (x
));
3731 return scm_mulbig ((SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3732 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3733 SCM_BIGSIGN (y
) ? (x
> 0) : (x
< 0));
3735 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3736 scm_longdigs (SCM_INUM (x
), zdigs
);
3737 return scm_mulbig (zdigs
, SCM_DIGSPERLONG
,
3738 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3739 SCM_BIGSIGN (y
) ? (x
> 0) : (x
< 0));
3743 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3745 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3748 return scm_makdbl (SCM_INUM (x
) * SCM_REALPART (y
),
3749 SCM_SLOPPY_COMPLEXP (y
) ? SCM_INUM (x
) * SCM_IMAG (y
) : 0.0);
3758 y
= SCM_MAKINUM (k
);
3759 if (k
!= SCM_INUM (y
) || k
/ i
!= j
)
3762 int sgn
= (i
< 0) ^ (j
< 0);
3763 #ifndef SCM_DIGSTOOBIG
3764 i
= scm_pseudolong (i
);
3765 j
= scm_pseudolong (j
);
3766 return scm_mulbig ((SCM_BIGDIG
*) & i
, SCM_DIGSPERLONG
,
3767 (SCM_BIGDIG
*) & j
, SCM_DIGSPERLONG
, sgn
);
3768 #else /* SCM_DIGSTOOBIG */
3769 SCM_BIGDIG idigs
[SCM_DIGSPERLONG
];
3770 SCM_BIGDIG jdigs
[SCM_DIGSPERLONG
];
3771 scm_longdigs (i
, idigs
);
3772 scm_longdigs (j
, jdigs
);
3773 return scm_mulbig (idigs
, SCM_DIGSPERLONG
,
3774 jdigs
, SCM_DIGSPERLONG
,
3779 return scm_makdbl (((double) i
) * ((double) j
), 0.0);
3788 scm_num2dbl (SCM a
, const char *why
)
3791 return (double) SCM_INUM (a
);
3792 SCM_ASSERT (SCM_NIMP (a
), a
, "wrong type argument", why
);
3793 if (SCM_SLOPPY_REALP (a
))
3794 return (SCM_REALPART (a
));
3796 return scm_big2dbl (a
);
3798 SCM_ASSERT (0, a
, "wrong type argument", why
);
3800 unreachable, hopefully.
3802 return (double) 0.0; /* ugh. */
3803 /* return SCM_UNSPECIFIED; */
3807 SCM_GPROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
, g_divide
);
3810 scm_divide (SCM x
, SCM y
)
3815 if (!(SCM_NIMP (x
)))
3819 SCM_GASSERT0 (!SCM_UNBNDP (x
),
3820 g_divide
, scm_makfrom0str (s_divide
), SCM_WNA
, 0);
3822 SCM_WTA_DISPATCH_1 (g_divide
, x
, SCM_ARG1
, s_divide
);
3827 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARG1
, s_divide
);
3834 return scm_makdbl (1.0 / scm_big2dbl (x
), 0.0);
3836 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx
);
3837 if (SCM_SLOPPY_REALP (x
))
3838 return scm_makdbl (1.0 / SCM_REALPART (x
), 0.0);
3842 return scm_makdbl (r
/ d
, -i
/ d
);
3849 long int z
= SCM_INUM (y
);
3850 #ifndef SCM_RECKLESS
3852 scm_num_overflow (s_divide
);
3860 SCM w
= scm_copybig (x
, SCM_BIGSIGN (x
) ? (y
> 0) : (y
< 0));
3861 return (scm_divbigdig (SCM_BDIGITS (w
), SCM_NUMDIGS (w
),
3863 ? scm_makdbl (scm_big2dbl (x
) / SCM_INUM (y
), 0.0)
3866 #ifndef SCM_DIGSTOOBIG
3867 /*ugh! Does anyone know what this is supposed to do?*/
3868 z
= scm_pseudolong (z
);
3869 z
= SCM_INUM(scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3870 (SCM_BIGDIG
*) & z
, SCM_DIGSPERLONG
,
3871 SCM_BIGSIGN (x
) ? (y
> 0) : (y
< 0), 3));
3874 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3875 scm_longdigs (z
, zdigs
);
3876 z
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3877 zdigs
, SCM_DIGSPERLONG
,
3878 SCM_BIGSIGN (x
) ? (y
> 0) : (y
< 0), 3);
3881 return z
? SCM_PACK (z
) : scm_makdbl (scm_big2dbl (x
) / SCM_INUM (y
), 0.0);
3883 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3886 SCM z
= scm_divbigbig (SCM_BDIGITS (x
), SCM_NUMDIGS (x
),
3887 SCM_BDIGITS (y
), SCM_NUMDIGS (y
),
3888 SCM_BIGSIGN (x
) ^ SCM_BIGSIGN (y
), 3);
3889 return z
? z
: scm_makdbl (scm_big2dbl (x
) / scm_big2dbl (y
),
3892 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3893 if (SCM_SLOPPY_REALP (y
))
3894 return scm_makdbl (scm_big2dbl (x
) / SCM_REALPART (y
), 0.0);
3895 a
= scm_big2dbl (x
);
3899 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x
), badx2
);
3906 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3909 d
= scm_big2dbl (y
);
3912 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3914 SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y
), bady
);
3916 if (SCM_SLOPPY_REALP (y
))
3918 d
= SCM_REALPART (y
);
3920 return scm_makdbl (SCM_REALPART (x
) / d
,
3921 SCM_SLOPPY_COMPLEXP (x
) ? SCM_IMAG (x
) / d
: 0.0);
3923 a
= SCM_REALPART (x
);
3924 if (SCM_SLOPPY_REALP (x
))
3929 return scm_makdbl ((a
* r
+ SCM_IMAG (x
) * i
) / d
,
3930 (SCM_IMAG (x
) * r
- a
* i
) / d
);
3934 if ((SCM_MAKINUM (1L) == x
) || (SCM_MAKINUM (-1L) == x
))
3936 return scm_makdbl (1.0 / ((double) SCM_INUM (x
)), 0.0);
3941 SCM_ASRTGO (SCM_NIMP (y
), bady
);
3943 return scm_makdbl (SCM_INUM (x
) / scm_big2dbl (y
), 0.0);
3944 if (!(SCM_SLOPPY_INEXACTP (y
)))
3947 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3950 if (!SCM_SLOPPY_INEXACTP (y
))
3953 SCM_WTA_DISPATCH_2 (g_divide
, x
, y
, SCM_ARGn
, s_divide
);
3956 if (SCM_SLOPPY_REALP (y
))
3957 return scm_makdbl (SCM_INUM (x
) / SCM_REALPART (y
), 0.0);
3963 return scm_makdbl ((a
* r
) / d
, (-a
* i
) / d
);
3966 long z
= SCM_INUM (y
);
3967 if ((0 == z
) || SCM_INUM (x
) % z
)
3969 z
= SCM_INUM (x
) / z
;
3970 if (SCM_FIXABLE (z
))
3971 return SCM_MAKINUM (z
);
3973 return scm_long2big (z
);
3976 return scm_makdbl (((double) SCM_INUM (x
)) / ((double) SCM_INUM (y
)), 0.0);
3983 SCM_GPROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
, g_asinh
);
3986 scm_asinh (double x
)
3988 return log (x
+ sqrt (x
* x
+ 1));
3994 SCM_GPROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
, g_acosh
);
3997 scm_acosh (double x
)
3999 return log (x
+ sqrt (x
* x
- 1));
4005 SCM_GPROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
, g_atanh
);
4008 scm_atanh (double x
)
4010 return 0.5 * log ((1 + x
) / (1 - x
));
4016 SCM_GPROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
, g_truncate
);
4019 scm_truncate (double x
)
4028 SCM_GPROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
, g_round
);
4031 scm_round (double x
)
4033 double plus_half
= x
+ 0.5;
4034 double result
= floor (plus_half
);
4035 /* Adjust so that the scm_round is towards even. */
4036 return (plus_half
== result
&& plus_half
/ 2 != floor (plus_half
/ 2))
4037 ? result
- 1 : result
;
4042 SCM_GPROC1 (s_exact_to_inexact
, "exact->inexact", scm_tc7_cxr
, (SCM (*)()) scm_exact_to_inexact
, g_exact_to_inexact
);
4045 scm_exact_to_inexact (double z
)
4051 SCM_GPROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
, g_i_floor
);
4052 SCM_GPROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
, g_i_ceil
);
4053 SCM_GPROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)()) sqrt
, g_i_sqrt
);
4054 SCM_GPROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)()) fabs
, g_i_abs
);
4055 SCM_GPROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)()) exp
, g_i_exp
);
4056 SCM_GPROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)()) log
, g_i_log
);
4057 SCM_GPROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)()) sin
, g_i_sin
);
4058 SCM_GPROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)()) cos
, g_i_cos
);
4059 SCM_GPROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)()) tan
, g_i_tan
);
4060 SCM_GPROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)()) asin
, g_i_asin
);
4061 SCM_GPROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)()) acos
, g_i_acos
);
4062 SCM_GPROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)()) atan
, g_i_atan
);
4063 SCM_GPROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)()) sinh
, g_i_sinh
);
4064 SCM_GPROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)()) cosh
, g_i_cosh
);
4065 SCM_GPROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)()) tanh
, g_i_tanh
);
4072 static void scm_two_doubles (SCM z1
,
4074 const char *sstring
,
4078 scm_two_doubles (SCM z1
, SCM z2
, const char *sstring
, struct dpair
*xy
)
4081 xy
->x
= SCM_INUM (z1
);
4085 SCM_ASRTGO (SCM_NIMP (z1
), badz1
);
4087 xy
->x
= scm_big2dbl (z1
);
4090 #ifndef SCM_RECKLESS
4091 if (!SCM_SLOPPY_REALP (z1
))
4092 badz1
:scm_wta (z1
, (char *) SCM_ARG1
, sstring
);
4094 xy
->x
= SCM_REALPART (z1
);
4098 SCM_ASSERT (SCM_SLOPPY_REALP (z1
), z1
, SCM_ARG1
, sstring
);
4099 xy
->x
= SCM_REALPART (z1
);
4104 xy
->y
= SCM_INUM (z2
);
4108 SCM_ASRTGO (SCM_NIMP (z2
), badz2
);
4110 xy
->y
= scm_big2dbl (z2
);
4113 #ifndef SCM_RECKLESS
4114 if (!(SCM_SLOPPY_REALP (z2
)))
4115 badz2
:scm_wta (z2
, (char *) SCM_ARG2
, sstring
);
4117 xy
->y
= SCM_REALPART (z2
);
4121 SCM_ASSERT (SCM_SLOPPY_REALP (z2
), z2
, SCM_ARG2
, sstring
);
4122 xy
->y
= SCM_REALPART (z2
);
4131 SCM_DEFINE (scm_sys_expt
, "$expt", 2, 0, 0,
4134 #define FUNC_NAME s_scm_sys_expt
4137 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4138 return scm_makdbl (pow (xy
.x
, xy
.y
), 0.0);
4144 SCM_DEFINE (scm_sys_atan2
, "$atan2", 2, 0, 0,
4147 #define FUNC_NAME s_scm_sys_atan2
4150 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4151 return scm_makdbl (atan2 (xy
.x
, xy
.y
), 0.0);
4157 SCM_DEFINE (scm_make_rectangular
, "make-rectangular", 2, 0, 0,
4160 #define FUNC_NAME s_scm_make_rectangular
4163 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4164 return scm_makdbl (xy
.x
, xy
.y
);
4170 SCM_DEFINE (scm_make_polar
, "make-polar", 2, 0, 0,
4173 #define FUNC_NAME s_scm_make_polar
4176 scm_two_doubles (z1
, z2
, FUNC_NAME
, &xy
);
4177 return scm_makdbl (xy
.x
* cos (xy
.y
), xy
.x
* sin (xy
.y
));
4184 SCM_GPROC (s_real_part
, "real-part", 1, 0, 0, scm_real_part
, g_real_part
);
4187 scm_real_part (SCM z
)
4192 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4195 if (!(SCM_SLOPPY_INEXACTP (z
)))
4198 SCM_WTA_DISPATCH_1 (g_real_part
, z
, SCM_ARG1
, s_real_part
);
4201 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
4202 g_real_part
, z
, SCM_ARG1
, s_real_part
);
4204 if (SCM_SLOPPY_COMPLEXP (z
))
4205 return scm_makdbl (SCM_REAL (z
), 0.0);
4212 SCM_GPROC (s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
, g_imag_part
);
4215 scm_imag_part (SCM z
)
4220 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4223 if (!(SCM_SLOPPY_INEXACTP (z
)))
4226 SCM_WTA_DISPATCH_1 (g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4229 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
4230 g_imag_part
, z
, SCM_ARG1
, s_imag_part
);
4232 if (SCM_SLOPPY_COMPLEXP (z
))
4233 return scm_makdbl (SCM_IMAG (z
), 0.0);
4239 SCM_GPROC (s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
, g_magnitude
);
4242 scm_magnitude (SCM z
)
4247 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4250 if (!(SCM_SLOPPY_INEXACTP (z
)))
4253 SCM_WTA_DISPATCH_1 (g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4256 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
),
4257 g_magnitude
, z
, SCM_ARG1
, s_magnitude
);
4259 if (SCM_SLOPPY_COMPLEXP (z
))
4261 double i
= SCM_IMAG (z
), r
= SCM_REAL (z
);
4262 return scm_makdbl (sqrt (i
* i
+ r
* r
), 0.0);
4264 return scm_makdbl (fabs (SCM_REALPART (z
)), 0.0);
4270 SCM_GPROC (s_angle
, "angle", 1, 0, 0, scm_angle
, g_angle
);
4278 x
= (z
>= SCM_INUM0
) ? 1.0 : -1.0;
4282 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4285 x
= (SCM_BIGSIGN (z
)) ? -1.0 : 1.0;
4288 if (!(SCM_SLOPPY_INEXACTP (z
)))
4291 SCM_WTA_DISPATCH_1 (g_angle
, z
, SCM_ARG1
, s_angle
);
4294 SCM_GASSERT1 (SCM_SLOPPY_INEXACTP (z
), g_angle
, z
, SCM_ARG1
, s_angle
);
4296 if (SCM_SLOPPY_REALP (z
))
4298 x
= SCM_REALPART (z
);
4304 return scm_makdbl (atan2 (y
, x
), 0.0);
4308 SCM_DEFINE (scm_inexact_to_exact
, "inexact->exact", 1, 0, 0,
4311 #define FUNC_NAME s_scm_inexact_to_exact
4316 SCM_ASRTGO (SCM_NIMP (z
), badz
);
4319 #ifndef SCM_RECKLESS
4320 if (!(SCM_SLOPPY_REALP (z
)))
4327 SCM_VALIDATE_REAL (1,z
);
4331 double u
= floor (SCM_REALPART (z
) + 0.5);
4332 if ((u
<= SCM_MOST_POSITIVE_FIXNUM
) && (-u
<= -SCM_MOST_NEGATIVE_FIXNUM
))
4334 /* Negation is a workaround for HP700 cc bug */
4335 SCM ans
= SCM_MAKINUM ((long) u
);
4336 if (SCM_INUM (ans
) == (long) u
)
4339 SCM_ASRTGO (isfinite (u
), badz
); /* problem? */
4340 return scm_dbl2big (u
);
4343 return SCM_MAKINUM ((long) floor (SCM_REALPART (z
) + 0.5));
4351 /* d must be integer */
4354 scm_dbl2big (double d
)
4360 double u
= (d
< 0) ? -d
: d
;
4361 while (0 != floor (u
))
4366 ans
= scm_mkbig (i
, d
< 0);
4367 digits
= SCM_BDIGITS (ans
);
4375 #ifndef SCM_RECKLESS
4377 scm_num_overflow ("dbl2big");
4388 scm_sizet i
= SCM_NUMDIGS (b
);
4389 SCM_BIGDIG
*digits
= SCM_BDIGITS (b
);
4391 ans
= digits
[i
] + SCM_BIGRAD
* ans
;
4392 if (SCM_BIGSIGN (b
))
4400 scm_long2num (long sl
)
4402 if (!SCM_FIXABLE (sl
))
4405 return scm_long2big (sl
);
4407 return scm_makdbl ((double) sl
, 0.0);
4410 return SCM_MAKINUM (sl
);
4414 #ifdef HAVE_LONG_LONGS
4417 scm_long_long2num (long_long sl
)
4419 if (!SCM_FIXABLE (sl
))
4422 return scm_long_long2big (sl
);
4424 return scm_makdbl ((double) sl
, 0.0);
4429 /* we know that sl fits into an inum */
4430 return SCM_MAKINUM ((scm_bits_t
) sl
);
4438 scm_ulong2num (unsigned long sl
)
4440 if (!SCM_POSFIXABLE (sl
))
4443 return scm_ulong2big (sl
);
4445 return scm_makdbl ((double) sl
, 0.0);
4448 return SCM_MAKINUM (sl
);
4453 scm_num2long (SCM num
, char *pos
, const char *s_caller
)
4457 if (SCM_INUMP (num
))
4459 res
= SCM_INUM (num
);
4462 SCM_ASRTGO (SCM_NIMP (num
), wrong_type_arg
);
4463 if (SCM_SLOPPY_REALP (num
))
4465 volatile double u
= SCM_REALPART (num
);
4475 unsigned long oldres
= 0;
4477 /* can't use res directly in case num is -2^31. */
4478 unsigned long pos_res
= 0;
4480 for (l
= SCM_NUMDIGS (num
); l
--;)
4482 pos_res
= SCM_BIGUP (pos_res
) + SCM_BDIGITS (num
)[l
];
4483 /* check for overflow. */
4484 if (pos_res
< oldres
)
4488 if (SCM_BIGSIGN (num
))
4504 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4506 scm_out_of_range (s_caller
, num
);
4511 #ifdef HAVE_LONG_LONGS
4514 scm_num2long_long (SCM num
, char *pos
, const char *s_caller
)
4518 if (SCM_INUMP (num
))
4520 res
= SCM_INUM (num
);
4523 SCM_ASRTGO (SCM_NIMP (num
), wrong_type_arg
);
4524 if (SCM_SLOPPY_REALP (num
))
4526 double u
= SCM_REALPART (num
);
4529 if ((res
< 0 && u
> 0) || (res
> 0 && u
< 0)) /* check for overflow. */
4537 unsigned long long oldres
= 0;
4539 /* can't use res directly in case num is -2^63. */
4540 unsigned long long pos_res
= 0;
4542 for (l
= SCM_NUMDIGS (num
); l
--;)
4544 pos_res
= SCM_LONGLONGBIGUP (pos_res
) + SCM_BDIGITS (num
)[l
];
4545 /* check for overflow. */
4546 if (pos_res
< oldres
)
4550 if (SCM_BIGSIGN (num
))
4566 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4568 scm_out_of_range (s_caller
, num
);
4575 scm_num2ulong (SCM num
, char *pos
, const char *s_caller
)
4579 if (SCM_INUMP (num
))
4581 if (SCM_INUM (num
) < 0)
4583 res
= SCM_INUM (num
);
4586 SCM_ASRTGO (SCM_NIMP (num
), wrong_type_arg
);
4587 if (SCM_SLOPPY_REALP (num
))
4589 double u
= SCM_REALPART (num
);
4599 unsigned long oldres
= 0;
4603 for (l
= SCM_NUMDIGS (num
); l
--;)
4605 res
= SCM_BIGUP (res
) + SCM_BDIGITS (num
)[l
];
4614 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
4616 scm_out_of_range (s_caller
, num
);
4622 add1 (double f
, double *fsum
)
4633 scm_add_feature ("complex");
4634 scm_add_feature ("inexact");
4635 SCM_NEWREAL (scm_flo0
, 0.0);
4637 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4639 { /* determine floating point precision */
4641 double fsum
= 1.0 + f
;
4645 if (++scm_dblprec
> 20)
4649 scm_dblprec
= scm_dblprec
- 1;
4651 #endif /* DBL_DIG */
4652 #include "numbers.x"