1 /* Copyright (C) 1995,1996, 1997 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. */
51 #define DIGITS '0':case '1':case '2':case '3':case '4':\
52 case '5':case '6':case '7':case '8':case '9'
55 /* IS_INF tests its floating point number for infiniteness
58 # define IS_INF(x) ((x)==(x)/2)
61 /* MAXEXP is the maximum double precision expontent
62 * FLTMAX is less than or scm_equal the largest single precision float
69 # endif /* ndef GO32 */
70 # endif /* def STDC_HEADERS */
71 # ifdef DBL_MAX_10_EXP
72 # define MAXEXP DBL_MAX_10_EXP
74 # define MAXEXP 308 /* IEEE doubles */
75 # endif /* def DBL_MAX_10_EXP */
77 # define FLTMAX FLT_MAX
80 # endif /* def FLT_MAX */
81 #endif /* def SCM_FLOATS */
85 SCM_PROC(s_exact_p
, "exact?", 1, 0, 0, scm_exact_p
);
91 if SCM_INUMP(x
) return SCM_BOOL_T
;
93 if (SCM_NIMP(x
) && SCM_BIGP(x
)) return SCM_BOOL_T
;
98 SCM_PROC(s_odd_p
, "odd?", 1, 0, 0, scm_odd_p
);
106 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_odd_p
);
107 return (1 & SCM_BDIGITS(n
)[0]) ? SCM_BOOL_T
: SCM_BOOL_F
;
110 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_odd_p
);
112 return (4 & (int)n
) ? SCM_BOOL_T
: SCM_BOOL_F
;
115 SCM_PROC(s_even_p
, "even?", 1, 0, 0, scm_even_p
);
123 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_even_p
);
124 return (1 & SCM_BDIGITS(n
)[0]) ? SCM_BOOL_F
: SCM_BOOL_T
;
127 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_even_p
);
129 return (4 & (int)n
) ? SCM_BOOL_F
: SCM_BOOL_T
;
132 SCM_PROC(s_abs
, "abs", 1, 0, 0, scm_abs
);
140 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_abs
);
141 if (SCM_TYP16(x
)==scm_tc16_bigpos
) return x
;
142 return scm_copybig(x
, 0);
145 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_abs
);
147 if (SCM_INUM(x
) >= 0) return x
;
149 if (!SCM_POSFIXABLE(x
))
151 return scm_long2big(x
);
153 scm_num_overflow (s_abs
);
155 return SCM_MAKINUM(x
);
158 SCM_PROC(s_quotient
, "quotient", 2, 0, 0, scm_quotient
);
169 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_quotient
);
171 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
172 return scm_divbigbig(SCM_BDIGITS(x
),
176 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
),
183 if (z
< SCM_BIGRAD
) {
184 w
= scm_copybig(x
, SCM_BIGSIGN(x
) ? (y
>0) : (y
<0));
185 scm_divbigdig(SCM_BDIGITS(w
), SCM_NUMDIGS(w
), (SCM_BIGDIG
)z
);
186 return scm_normbig(w
);
188 #ifndef SCM_DIGSTOOBIG
189 w
= scm_pseudolong(z
);
190 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), (SCM_BIGDIG
*)&w
, SCM_DIGSPERLONG
,
191 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 2);
193 { SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
194 scm_longdigs(z
, zdigs
);
195 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), zdigs
, SCM_DIGSPERLONG
,
196 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 2);
202 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
203 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_quotient
);
208 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_quotient
);
209 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_quotient
);
211 if ((z
= SCM_INUM(y
))==0)
212 ov
: scm_num_overflow (s_quotient
);
217 long t
= ((y
<0) ? -SCM_INUM(x
) : SCM_INUM(x
))%SCM_INUM(y
);
219 long t
= SCM_INUM(x
)%SCM_INUM(y
);
230 return scm_long2big(z
);
232 scm_num_overflow (s_quotient
);
234 return SCM_MAKINUM(z
);
237 SCM_PROC(s_remainder
, "remainder", 2, 0, 0, scm_remainder
);
247 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_remainder
);
249 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
250 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
253 if (!(z
= SCM_INUM(y
))) goto ov
;
254 return scm_divbigint(x
, z
, SCM_BIGSIGN(x
), 0);
258 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
259 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_remainder
);
264 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_remainder
);
265 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_remainder
);
267 if (!(z
= SCM_INUM(y
)))
268 ov
: scm_num_overflow (s_remainder
);
277 else z
+= SCM_INUM(y
);
278 else if (x
< 0) z
-= SCM_INUM(y
);
280 return SCM_MAKINUM(z
);
283 SCM_PROC(s_modulo
, "modulo", 2, 0, 0, scm_modulo
);
293 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_modulo
);
295 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
296 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
297 SCM_BIGSIGN(y
), (SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
)) ? 1 : 0);
299 if (!(z
= SCM_INUM(y
))) goto ov
;
300 return scm_divbigint(x
, z
, y
< 0, (SCM_BIGSIGN(x
) ? (y
> 0) : (y
< 0)) ? 1 : 0);
304 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
305 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_modulo
);
307 return (SCM_BIGSIGN(y
) ? (x
>0) : (x
<0)) ? scm_sum(x
, y
) : x
;
310 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_modulo
);
311 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_modulo
);
313 if (!(yy
= SCM_INUM(y
)))
314 ov
: scm_num_overflow (s_modulo
);
317 z
= ((yy
<0) ? -z
: z
)%yy
;
321 return SCM_MAKINUM(((yy
<0) ? (z
>0) : (z
<0)) ? z
+yy
: z
);
324 SCM_PROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
);
331 register long u
, v
, k
, t
;
332 if SCM_UNBNDP(y
) return SCM_UNBNDP(x
) ? SCM_INUM0
: x
;
337 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_gcd
);
338 if SCM_BIGSIGN(x
) x
= scm_copybig(x
, 0);
341 SCM_ASSERT(SCM_NIMP(y
) && SCM_BIGP(y
), y
, SCM_ARG2
, s_gcd
);
342 if SCM_BIGSIGN(y
) y
= scm_copybig(y
, 0);
343 switch (scm_bigcomp(x
, y
)) {
345 swaprec
: t
= scm_remainder(x
, y
); x
= y
; y
= t
; goto tailrec
;
347 case 1: y
= scm_remainder(y
, x
); goto newy
;
349 /* instead of the switch, we could just return scm_gcd(y, scm_modulo(x, y)); */
351 if (SCM_INUM0
==y
) return x
; goto swaprec
;
353 if SCM_NINUMP(y
) { t
=x
; x
=y
; y
=t
; goto big_gcd
;}
355 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_gcd
);
356 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_gcd
);
362 else if (0==v
) goto getout
;
363 if (0==u
) {u
= v
; goto getout
;}
364 for (k
= 1;!(1 & ((int)u
|(int)v
));k
<<= 1, u
>>= 1, v
>>= 1);
365 if (1 & (int)u
) t
= -v
;
371 if (!(1 & (int)t
)) goto b3
;
374 if ((t
= u
-v
)) goto b3
;
377 if (!SCM_POSFIXABLE(u
))
379 return scm_long2big(u
);
381 scm_num_overflow (s_gcd
);
383 return SCM_MAKINUM(u
);
386 SCM_PROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
);
395 n2
= SCM_MAKINUM(1L);
396 if SCM_UNBNDP(n1
) return n2
;
399 if (SCM_INUM0
==d
) return d
;
400 return scm_abs(scm_product(n1
, scm_quotient(n2
, d
)));
405 # define scm_long2num SCM_MAKINUM
410 SCM_PROC1 (s_logand
, "logand", scm_tc7_asubr
, scm_logand
);
420 return SCM_MAKINUM (-1);
423 return scm_long2num (scm_num2long(n1
, (char *)SCM_ARG1
, s_logand
)
424 & scm_num2long(n2
, (char *)SCM_ARG2
, s_logand
));
427 SCM_PROC1 (s_logior
, "logior", scm_tc7_asubr
, scm_logior
);
440 return scm_long2num(scm_num2long(n1
, (char *)SCM_ARG1
, s_logior
)
441 | scm_num2long(n2
, (char *)SCM_ARG2
, s_logior
));
444 SCM_PROC1 (s_logxor
, "logxor", scm_tc7_asubr
, scm_logxor
);
457 return scm_long2num(scm_num2long(n1
, (char *)SCM_ARG1
, s_logxor
)
458 ^ scm_num2long(n2
, (char *)SCM_ARG2
, s_logxor
));
461 SCM_PROC(s_logtest
, "logtest", 2, 0, 0, scm_logtest
);
468 return ((scm_num2long (n1
, (char *)SCM_ARG1
, s_logtest
)
469 & scm_num2long (n2
, (char *)SCM_ARG2
, s_logtest
))
470 ? SCM_BOOL_T
: SCM_BOOL_F
);
474 SCM_PROC(s_logbit_p
, "logbit?", 2, 0, 0, scm_logbit_p
);
481 return (((1 << scm_num2long (n1
, (char *)SCM_ARG1
, s_logtest
))
482 & scm_num2long (n2
, (char *)SCM_ARG2
, s_logtest
))
483 ? SCM_BOOL_T
: SCM_BOOL_F
);
488 SCM_PROC1 (s_logand
, "logand", scm_tc7_asubr
, scm_logand
);
498 return SCM_MAKINUM (-1);
501 return SCM_MAKINUM(SCM_INUM(n1
) & SCM_INUM(n2
));
504 SCM_PROC1 (s_logior
, "logior", scm_tc7_asubr
, scm_logior
);
517 return SCM_MAKINUM(SCM_INUM(n1
) | SCM_INUM(n2
));
520 SCM_PROC1 (s_logxor
, "logxor", scm_tc7_asubr
, scm_logxor
);
533 return SCM_MAKINUM(SCM_INUM(n1
) ^ SCM_INUM(n2
));
536 SCM_PROC(s_logtest
, "logtest", 2, 0, 0, scm_logtest
);
543 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logtest
);
544 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logtest
);
545 return (SCM_INUM(n1
) & SCM_INUM(n2
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
548 SCM_PROC(s_logbit_p
, "logbit?", 2, 0, 0, scm_logbit_p
);
555 SCM_ASSERT(SCM_INUMP(n1
) && SCM_INUM(n1
) >= 0, n1
, SCM_ARG1
, s_logbit_p
);
556 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logbit_p
);
557 return ((1 << SCM_INUM(n1
)) & SCM_INUM(n2
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
561 SCM_PROC(s_lognot
, "lognot", 1, 0, 0, scm_lognot
);
567 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_lognot
);
568 return scm_difference(SCM_MAKINUM(-1L), n
);
571 SCM_PROC(s_integer_expt
, "integer-expt", 2, 0, 0, scm_integer_expt
);
574 scm_integer_expt(z1
, z2
)
578 SCM acc
= SCM_MAKINUM(1L);
580 if (SCM_INUM0
==z1
|| acc
==z1
) return z1
;
581 else if (SCM_MAKINUM(-1L)==z1
) return SCM_BOOL_F
==scm_even_p(z2
)?z1
:acc
;
583 SCM_ASSERT(SCM_INUMP(z2
), z2
, SCM_ARG2
, s_integer_expt
);
587 z1
= scm_divide(z1
, SCM_UNDEFINED
);
590 if (0==z2
) return acc
;
591 if (1==z2
) return scm_product(acc
, z1
);
592 if (z2
& 1) acc
= scm_product(acc
, z1
);
593 z1
= scm_product(z1
, z1
);
598 SCM_PROC(s_ash
, "ash", 2, 0, 0, scm_ash
);
605 SCM res
= SCM_INUM(n
);
606 SCM_ASSERT(SCM_INUMP(cnt
), cnt
, SCM_ARG2
, s_ash
);
609 res
= scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(-SCM_INUM(cnt
)));
610 if (SCM_NFALSEP(scm_negative_p(n
)))
611 return scm_sum(SCM_MAKINUM(-1L), scm_quotient(scm_sum(SCM_MAKINUM(1L), n
), res
));
612 else return scm_quotient(n
, res
);
614 else return scm_product(n
, scm_integer_expt(SCM_MAKINUM(2), cnt
));
616 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_ash
);
618 if (cnt
< 0) return SCM_MAKINUM(SCM_SRS(res
, -cnt
));
619 res
= SCM_MAKINUM(res
<<cnt
);
620 if (SCM_INUM(res
)>>cnt
!= SCM_INUM(n
))
621 scm_num_overflow (s_ash
);
626 SCM_PROC(s_bit_extract
, "bit-extract", 3, 0, 0, scm_bit_extract
);
629 scm_bit_extract(n
, start
, end
)
634 SCM_ASSERT(SCM_INUMP(start
), start
, SCM_ARG2
, s_bit_extract
);
635 SCM_ASSERT(SCM_INUMP(end
), end
, SCM_ARG3
, s_bit_extract
);
636 start
= SCM_INUM(start
); end
= SCM_INUM(end
);
637 SCM_ASSERT(end
>= start
, SCM_MAKINUM(end
), SCM_OUTOFRANGE
, s_bit_extract
);
641 scm_logand(scm_difference(scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(end
- start
)),
643 scm_ash(n
, SCM_MAKINUM(-start
)));
645 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_bit_extract
);
647 return SCM_MAKINUM((SCM_INUM(n
)>>start
) & ((1L<<(end
-start
))-1));
650 char scm_logtab
[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
651 SCM_PROC(s_logcount
, "logcount", 1, 0, 0, scm_logcount
);
657 register unsigned long c
= 0;
661 scm_sizet i
; SCM_BIGDIG
*ds
, d
;
662 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_logcount
);
663 if SCM_BIGSIGN(n
) return scm_logcount(scm_difference(SCM_MAKINUM(-1L), n
));
665 for(i
= SCM_NUMDIGS(n
); i
--; )
666 for(d
= ds
[i
]; d
; d
>>= 4) c
+= scm_logtab
[15 & d
];
667 return SCM_MAKINUM(c
);
670 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_logcount
);
672 if ((nn
= SCM_INUM(n
)) < 0) nn
= -1 - nn
;
673 for(; nn
; nn
>>= 4) c
+= scm_logtab
[15 & nn
];
674 return SCM_MAKINUM(c
);
677 char scm_ilentab
[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4};
678 SCM_PROC(s_integer_length
, "integer-length", 1, 0, 0, scm_integer_length
);
681 scm_integer_length(n
)
684 register unsigned long c
= 0;
690 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_integer_length
);
691 if SCM_BIGSIGN(n
) return scm_integer_length(scm_difference(SCM_MAKINUM(-1L), n
));
693 d
= ds
[c
= SCM_NUMDIGS(n
)-1];
694 for(c
*= SCM_BITSPERDIG
; d
; d
>>= 4) {c
+= 4; l
= scm_ilentab
[15 & d
];}
695 return SCM_MAKINUM(c
- 4 + l
);
698 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_integer_length
);
700 if ((nn
= SCM_INUM(n
)) < 0) nn
= -1 - nn
;
701 for(;nn
; nn
>>= 4) {c
+= 4; l
= scm_ilentab
[15 & nn
];}
702 return SCM_MAKINUM(c
- 4 + l
);
707 char s_bignum
[] = "bignum";
710 scm_mkbig(nlen
, sign
)
715 if (((v
<< 16) >> 16) != nlen
)
716 scm_wta(SCM_MAKINUM(nlen
), (char *)SCM_NALLOC
, s_bignum
);
719 SCM_SETCHARS(v
, scm_must_malloc((long)(nlen
*sizeof(SCM_BIGDIG
)), s_bignum
));
720 SCM_SETNUMDIGS(v
, nlen
, sign
?scm_tc16_bigneg
:scm_tc16_bigpos
);
731 unsigned long num
= 0;
732 SCM_BIGDIG
*tmp
= SCM_BDIGITS(b
);
733 while (l
--) num
= SCM_BIGUP(num
) + tmp
[l
];
734 if (SCM_TYP16(b
)==scm_tc16_bigpos
) {
735 if SCM_POSFIXABLE(num
) return SCM_MAKINUM(num
);
737 else if SCM_UNEGFIXABLE(num
) return SCM_MAKINUM(-num
);
742 char s_adjbig
[] = "scm_adjbig";
750 if (((nsiz
<< 16) >> 16) != nlen
) scm_wta(SCM_MAKINUM(nsiz
), (char *)SCM_NALLOC
, s_adjbig
);
752 SCM_SETCHARS(b
, (SCM_BIGDIG
*)scm_must_realloc((char *)SCM_CHARS(b
),
753 (long)(SCM_NUMDIGS(b
)*sizeof(SCM_BIGDIG
)),
754 (long)(nsiz
*sizeof(SCM_BIGDIG
)), s_adjbig
));
755 SCM_SETNUMDIGS(b
, nsiz
, SCM_TYP16(b
));
767 scm_sizet nlen
= SCM_NUMDIGS(b
);
769 int nlen
= SCM_NUMDIGS(b
); /* unsigned nlen breaks on Cray when nlen => 0 */
771 SCM_BIGDIG
*zds
= SCM_BDIGITS(b
);
772 while (nlen
-- && !zds
[nlen
]); nlen
++;
773 if (nlen
* SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
))
774 if SCM_INUMP(b
= scm_big2inum(b
, (scm_sizet
)nlen
)) return b
;
775 if (SCM_NUMDIGS(b
)==nlen
) return b
;
776 return scm_adjbig(b
, (scm_sizet
)nlen
);
786 scm_sizet i
= SCM_NUMDIGS(b
);
787 SCM ans
= scm_mkbig(i
, sign
);
788 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
789 while (i
--) dst
[i
] = src
[i
];
801 SCM ans
= scm_mkbig(SCM_DIGSPERLONG
, n
<0);
802 digits
= SCM_BDIGITS(ans
);
804 while (i
< SCM_DIGSPERLONG
) {
805 digits
[i
++] = SCM_BIGLO(n
);
806 n
= SCM_BIGDN((unsigned long)n
);
825 if ((long long)tn
== n
)
826 return scm_long2big (tn
);
832 for (tn
= n
, n_digits
= 0;
834 ++n_digits
, tn
= SCM_BIGDN ((ulong_long
)tn
))
839 ans
= scm_mkbig(n_digits
, n
<0);
840 digits
= SCM_BDIGITS(ans
);
843 while (i
< n_digits
) {
844 digits
[i
++] = SCM_BIGLO(n
);
845 n
= SCM_BIGDN((ulong_long
)n
);
861 ans
= scm_mkbig(2 * SCM_DIGSPERLONG
, 0);
862 digits
= SCM_BDIGITS(ans
);
865 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
867 digits
[i
] = SCM_BIGLO(n
);
868 n
= SCM_BIGDN((unsigned long)n
);
871 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
873 digits
[i
+ SCM_DIGSPERLONG
] = SCM_BIGLO(n
);
874 n
= SCM_BIGDN((unsigned long)n
);
887 SCM ans
= scm_mkbig(SCM_DIGSPERLONG
, 0);
888 digits
= SCM_BDIGITS(ans
);
889 while (i
< SCM_DIGSPERLONG
) {
890 digits
[i
++] = SCM_BIGLO(n
);
903 int xsign
= SCM_BIGSIGN(x
);
904 int ysign
= SCM_BIGSIGN(y
);
905 scm_sizet xlen
, ylen
;
906 if (ysign
< xsign
) return 1;
907 if (ysign
> xsign
) return -1;
908 if ((ylen
= SCM_NUMDIGS(y
)) > (xlen
= SCM_NUMDIGS(x
))) return (xsign
) ? -1 : 1;
909 if (ylen
< xlen
) return (xsign
) ? 1 : -1;
910 while(xlen
-- && (SCM_BDIGITS(y
)[xlen
]==SCM_BDIGITS(x
)[xlen
]));
911 if (-1==xlen
) return 0;
912 return (SCM_BDIGITS(y
)[xlen
] > SCM_BDIGITS(x
)[xlen
]) ?
913 (xsign
? -1 : 1) : (xsign
? 1 : -1);
916 #ifndef SCM_DIGSTOOBIG
925 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
929 while (i
< SCM_DIGSPERLONG
) {p
.bd
[i
++] = SCM_BIGLO(x
); x
= SCM_BIGDN(x
);}
930 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
938 scm_longdigs(x
, digs
)
944 while (i
< SCM_DIGSPERLONG
) {digs
[i
++] = SCM_BIGLO(x
); x
= SCM_BIGDN(x
);}
951 scm_addbig(x
, nx
, xsgn
, bigy
, sgny
)
958 /* Assumes nx <= SCM_NUMDIGS(bigy) */
959 /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */
961 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
962 SCM z
= scm_copybig(bigy
, SCM_BIGSIGN(bigy
) ^ sgny
);
963 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
964 if (xsgn
^ SCM_BIGSIGN(z
)) {
966 num
+= (long) zds
[i
] - x
[i
];
967 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
968 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
972 SCM_SETCAR (z
, SCM_CAR (z
) ^ 0x0100);
974 num
+= (SCM_BIGRAD
-1) - zds
[i
];
975 zds
[i
++] = SCM_BIGLO(num
);
976 num
= SCM_BIGDN(num
);
979 else while (i
< ny
) {
981 if (num
< 0) {zds
[i
++] = num
+ SCM_BIGRAD
; num
= -1;}
982 else {zds
[i
++] = SCM_BIGLO(num
); num
= 0;}
986 num
+= (long) zds
[i
] + x
[i
];
987 zds
[i
++] = SCM_BIGLO(num
);
988 num
= SCM_BIGDN(num
);
993 zds
[i
++] = SCM_BIGLO(num
);
994 num
= SCM_BIGDN(num
);
997 if (num
) {z
= scm_adjbig(z
, ny
+1); SCM_BDIGITS(z
)[ny
] = num
; return z
;}
999 return scm_normbig(z
);
1004 scm_mulbig(x
, nx
, y
, ny
, sgn
)
1011 scm_sizet i
= 0, j
= nx
+ ny
;
1012 unsigned long n
= 0;
1013 SCM z
= scm_mkbig(j
, sgn
);
1014 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
1015 while (j
--) zds
[j
] = 0;
1020 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1021 zds
[i
+ j
++] = SCM_BIGLO(n
);
1024 if (n
) {zds
[i
+ j
] = n
; n
= 0;}
1027 return scm_normbig(z
);
1031 /* Sun's compiler complains about the fact that this function has an
1032 ANSI prototype in numbers.h, but a K&R declaration here, and the
1033 two specify different promotions for the third argument. I'm going
1034 to turn this into an ANSI declaration, and see if anyone complains
1035 about it not being K&R. */
1038 scm_divbigdig(SCM_BIGDIG
*ds
,
1042 register unsigned long t2
= 0;
1044 t2
= SCM_BIGUP(t2
) + ds
[h
];
1054 scm_divbigint(x
, z
, sgn
, mode
)
1061 if (z
< SCM_BIGRAD
) {
1062 register unsigned long t2
= 0;
1063 register SCM_BIGDIG
*ds
= SCM_BDIGITS(x
);
1064 scm_sizet nd
= SCM_NUMDIGS(x
);
1065 while(nd
--) t2
= (SCM_BIGUP(t2
) + ds
[nd
]) % z
;
1066 if (mode
&& t2
) t2
= z
- t2
;
1067 return SCM_MAKINUM(sgn
? -t2
: t2
);
1070 #ifndef SCM_DIGSTOOBIG
1071 unsigned long t2
= scm_pseudolong(z
);
1072 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), (SCM_BIGDIG
*)&t2
,
1073 SCM_DIGSPERLONG
, sgn
, mode
);
1075 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1076 scm_longdigs(z
, t2
);
1077 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), t2
, SCM_DIGSPERLONG
, sgn
, mode
);
1084 scm_divbigbig(x
, nx
, y
, ny
, sgn
, modes
)
1092 /* modes description
1096 3 quotient but returns 0 if division is not exact. */
1097 scm_sizet i
= 0, j
= 0;
1099 unsigned long t2
= 0;
1101 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1102 /* algorithm requires nx >= ny */
1105 case 0: /* remainder -- just return x */
1106 z
= scm_mkbig(nx
, sgn
); zds
= SCM_BDIGITS(z
);
1107 do {zds
[i
] = x
[i
];} while (++i
< nx
);
1109 case 1: /* scm_modulo -- return y-x */
1110 z
= scm_mkbig(ny
, sgn
); zds
= SCM_BDIGITS(z
);
1112 num
+= (long) y
[i
] - x
[i
];
1113 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
1114 else {zds
[i
] = num
; num
= 0;}
1118 if (num
< 0) {zds
[i
++] = num
+ SCM_BIGRAD
; num
= -1;}
1119 else {zds
[i
++] = num
; num
= 0;}
1122 case 2: return SCM_INUM0
; /* quotient is zero */
1123 case 3: return 0; /* the division is not exact */
1126 z
= scm_mkbig(nx
==ny
? nx
+2 : nx
+1, sgn
); zds
= SCM_BDIGITS(z
);
1127 if (nx
==ny
) zds
[nx
+1] = 0;
1128 while(!y
[ny
-1]) ny
--; /* in case y came in as a psuedolong */
1129 if (y
[ny
-1] < (SCM_BIGRAD
>>1)) { /* normalize operands */
1130 d
= SCM_BIGRAD
/(y
[ny
-1]+1);
1131 newy
= scm_mkbig(ny
, 0); yds
= SCM_BDIGITS(newy
);
1133 {t2
+= (unsigned long) y
[j
]*d
; yds
[j
++] = SCM_BIGLO(t2
); t2
= SCM_BIGDN(t2
);}
1134 y
= yds
; j
= 0; t2
= 0;
1136 {t2
+= (unsigned long) x
[j
]*d
; zds
[j
++] = SCM_BIGLO(t2
); t2
= SCM_BIGDN(t2
);}
1139 else {zds
[j
= nx
] = 0; while (j
--) zds
[j
] = x
[j
];}
1140 j
= nx
==ny
? nx
+1 : nx
; /* dividend needs more digits than divisor */
1141 do { /* loop over digits of quotient */
1142 if (zds
[j
]==y
[ny
-1]) qhat
= SCM_BIGRAD
-1;
1143 else qhat
= (SCM_BIGUP(zds
[j
]) + zds
[j
-1])/y
[ny
-1];
1144 if (!qhat
) continue;
1145 i
= 0; num
= 0; t2
= 0;
1146 do { /* multiply and subtract */
1147 t2
+= (unsigned long) y
[i
] * qhat
;
1148 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO(t2
);
1149 if (num
< 0) {zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
; num
= -1;}
1150 else {zds
[j
- ny
+ i
] = num
; num
= 0;}
1153 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1154 while (num
) { /* "add back" required */
1155 i
= 0; num
= 0; qhat
--;
1157 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1158 zds
[j
- ny
+ i
] = SCM_BIGLO(num
);
1159 num
= SCM_BIGDN(num
);
1163 if (modes
& 2) zds
[j
] = qhat
;
1164 } while (--j
>= ny
);
1166 case 3: /* check that remainder==0 */
1167 for(j
= ny
;j
&& !zds
[j
-1];--j
) ; if (j
) return 0;
1168 case 2: /* move quotient down in z */
1169 j
= (nx
==ny
? nx
+2 : nx
+1) - ny
;
1170 for (i
= 0;i
< j
;i
++) zds
[i
] = zds
[i
+ny
];
1173 case 1: /* subtract for scm_modulo */
1174 i
= 0; num
= 0; j
= 0;
1175 do {num
+= y
[i
] - zds
[i
];
1177 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
1178 else {zds
[i
] = num
; num
= 0;}
1180 if (!j
) return SCM_INUM0
;
1181 case 0: /* just normalize remainder */
1182 if (d
) scm_divbigdig(zds
, ny
, d
);
1185 for(j
= ny
;j
&& !zds
[j
-1];--j
) ;
1186 if (j
* SCM_BITSPERDIG
<= sizeof(SCM
)*SCM_CHAR_BIT
)
1187 if SCM_INUMP(z
= scm_big2inum(z
, j
)) return z
;
1188 return scm_adjbig(z
, j
);
1196 /*** NUMBERS -> STRINGS ***/
1199 static double fx
[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1200 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1201 5e-11,5e-12,5e-13,5e-14,5e-15,
1202 5e-16,5e-17,5e-18,5e-19,5e-20};
1207 static scm_sizet idbl2str
SCM_P ((double f
, char *a
));
1214 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1218 if (f
== 0.0) goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
1219 if (f
< 0.0) {f
= -f
;a
[ch
++]='-';}
1224 if (ch
== 0) a
[ch
++]='+';
1225 funny
: a
[ch
++]='#'; a
[ch
++]='.'; a
[ch
++]='#'; return ch
;
1227 # ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1228 make-uniform-vector, from causing infinite loops. */
1229 while (f
< 1.0) {f
*= 10.0; if (exp
-- < DBL_MIN_10_EXP
) goto funny
;}
1230 while (f
> 10.0) {f
*= 0.10; if (exp
++ > DBL_MAX_10_EXP
) goto funny
;}
1232 while (f
< 1.0) {f
*= 10.0; exp
--;}
1233 while (f
> 10.0) {f
/= 10.0; exp
++;}
1235 if (f
+fx
[wp
] >= 10.0) {f
= 1.0; exp
++;}
1242 efmt
= (exp
< -3) || (exp
> wp
+2);
1250 while (++dpt
) a
[ch
++] = '0';
1263 if (f
< fx
[wp
]) break;
1264 if (f
+fx
[wp
] >= 1.0) {
1269 if (!(--dpt
)) a
[ch
++] = '.';
1275 if ((dpt
> 4) && (exp
> 6))
1277 d
= (a
[0]=='-'?2:1);
1278 for (i
= ch
++; i
> d
; i
--)
1286 while (--dpt
) a
[ch
++] = '0';
1290 if (a
[ch
-1]=='.') a
[ch
++]='0'; /* trailing zero */
1297 for (i
= 10; i
<= exp
; i
*= 10);
1298 for (i
/= 10; i
; i
/= 10) {
1299 a
[ch
++] = exp
/i
+ '0';
1307 static scm_sizet iflo2str
SCM_P ((SCM flt
, char *str
));
1316 if SCM_SINGP(flt
) i
= idbl2str(SCM_FLO(flt
), str
);
1319 i
= idbl2str(SCM_REAL(flt
), str
);
1321 if(0 <= SCM_IMAG(flt
)) /* jeh */
1322 str
[i
++] = '+'; /* jeh */
1323 i
+= idbl2str(SCM_IMAG(flt
), &str
[i
]);
1328 #endif /* SCM_FLOATS */
1332 scm_iint2str(num
, rad
, p
)
1338 register int i
= 1, d
;
1339 register long n
= num
;
1340 if (n
< 0) {n
= -n
; i
++;}
1341 for (n
/= rad
;n
> 0;n
/= rad
) i
++;
1344 if (n
< 0) {n
= -n
; *p
++ = '-'; i
--;}
1348 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
1356 static SCM big2str
SCM_P ((SCM b
, register unsigned int radix
));
1361 register unsigned int radix
;
1363 SCM t
= scm_copybig(b
, 0); /* sign of temp doesn't matter */
1364 register SCM_BIGDIG
*ds
= SCM_BDIGITS(t
);
1365 scm_sizet i
= SCM_NUMDIGS(t
);
1366 scm_sizet j
= radix
==16 ? (SCM_BITSPERDIG
*i
)/4+2
1367 : radix
>= 10 ? (SCM_BITSPERDIG
*i
*241L)/800+2
1368 : (SCM_BITSPERDIG
*i
)+2;
1370 scm_sizet radct
= 0;
1371 scm_sizet ch
; /* jeh */
1372 SCM_BIGDIG radpow
= 1, radmod
= 0;
1373 SCM ss
= scm_makstr((long)j
, 0);
1374 char *s
= SCM_CHARS(ss
), c
;
1375 while ((long) radpow
* radix
< SCM_BIGRAD
) {
1379 s
[0] = scm_tc16_bigneg
==SCM_TYP16(b
) ? '-' : '+';
1380 while ((i
|| radmod
) && j
) {
1382 radmod
= (SCM_BIGDIG
)scm_divbigdig(ds
, i
, radpow
);
1386 c
= radmod
% radix
; radmod
/= radix
; k
--;
1387 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
1389 ch
= s
[0] == '-' ? 1 : 0; /* jeh */
1390 if (ch
< j
) { /* jeh */
1391 for(i
= j
;j
< SCM_LENGTH(ss
);j
++) s
[ch
+j
-i
] = s
[j
]; /* jeh */
1392 scm_vector_set_length_x(ss
, (SCM
)SCM_MAKINUM(ch
+SCM_LENGTH(ss
)-i
)); /* jeh */
1399 SCM_PROC(s_number_to_string
, "number->string", 1, 1, 0, scm_number_to_string
);
1402 scm_number_to_string(x
, radix
)
1406 if SCM_UNBNDP(radix
) radix
=SCM_MAKINUM(10L);
1407 else SCM_ASSERT(SCM_INUMP(radix
), radix
, SCM_ARG2
, s_number_to_string
);
1410 char num_buf
[SCM_FLOBUFLEN
];
1412 SCM_ASRTGO(SCM_NIMP(x
), badx
);
1413 if SCM_BIGP(x
) return big2str(x
, (unsigned int)SCM_INUM(radix
));
1415 if (!(SCM_INEXP(x
)))
1416 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_number_to_string
);
1419 SCM_ASSERT(SCM_NIMP(x
) && SCM_INEXP(x
), x
, SCM_ARG1
, s_number_to_string
);
1421 return scm_makfromstr(num_buf
, iflo2str(x
, num_buf
), 0);
1426 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_number_to_string
);
1427 return big2str(x
, (unsigned int)SCM_INUM(radix
));
1430 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_number_to_string
);
1434 char num_buf
[SCM_INTBUFLEN
];
1435 return scm_makfromstr(num_buf
,
1436 scm_iint2str(SCM_INUM(x
), (int)SCM_INUM(radix
), num_buf
), 0);
1441 /* These print routines are stubbed here so that scm_repl.c doesn't need
1442 SCM_FLOATS or SCM_BIGDIGs conditionals */
1445 scm_floprint(sexp
, port
, pstate
)
1448 scm_print_state
*pstate
;
1451 char num_buf
[SCM_FLOBUFLEN
];
1452 scm_lfwrite (num_buf
, iflo2str(sexp
, num_buf
), port
);
1454 scm_ipruk("float", sexp
, port
);
1462 scm_bigprint(exp
, port
, pstate
)
1465 scm_print_state
*pstate
;
1468 exp
= big2str(exp
, (unsigned int)10);
1469 scm_lfwrite (SCM_CHARS(exp
), (scm_sizet
)SCM_LENGTH(exp
), port
);
1471 scm_ipruk("bignum", exp
, port
);
1475 /*** END nums->strs ***/
1477 /*** STRINGS -> NUMBERS ***/
1479 static SCM scm_small_istr2int
SCM_P ((char *str
, long len
, long radix
));
1482 scm_small_istr2int(str
, len
, radix
)
1487 register long n
= 0, ln
;
1491 if (0 >= len
) return SCM_BOOL_F
; /* zero scm_length */
1492 switch (*str
) { /* leading sign */
1493 case '-': lead_neg
= 1;
1494 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1498 switch (c
= str
[i
++]) {
1502 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1505 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1508 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1511 /* Negation is a workaround for HP700 cc bug */
1512 if (n
> ln
|| (-n
> -SCM_MOST_NEGATIVE_FIXNUM
)) goto ovfl
;
1515 return SCM_BOOL_F
; /* not a digit */
1518 if (!lead_neg
) if ((n
= -n
) > SCM_MOST_POSITIVE_FIXNUM
) goto ovfl
;
1519 return SCM_MAKINUM(n
);
1520 ovfl
: /* overflow scheme integer */
1527 scm_istr2int(str
, len
, radix
)
1533 register scm_sizet k
, blen
= 1;
1537 register SCM_BIGDIG
*ds
;
1538 register unsigned long t2
;
1540 if (0 >= len
) return SCM_BOOL_F
; /* zero scm_length */
1542 /* Short numbers we parse directly into an int, to avoid the overhead
1543 of creating a bignum. */
1545 return scm_small_istr2int (str
, len
, radix
);
1547 if (16==radix
) j
= 1+(4*len
*sizeof(char))/(SCM_BITSPERDIG
);
1548 else if (10 <= radix
)
1549 j
= 1+(84*len
*sizeof(char))/(SCM_BITSPERDIG
*25);
1550 else j
= 1+(len
*sizeof(char))/(SCM_BITSPERDIG
);
1551 switch (str
[0]) { /* leading sign */
1553 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1555 res
= scm_mkbig(j
, '-'==str
[0]);
1556 ds
= SCM_BDIGITS(res
);
1557 for (k
= j
;k
--;) ds
[k
] = 0;
1559 switch (c
= str
[i
++]) {
1563 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1566 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1569 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1574 /* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/
1576 ds
[k
++] = SCM_BIGLO(t2
);
1580 scm_num_overflow ("bignum");
1581 if (t2
) {blen
++; goto moretodo
;}
1584 return SCM_BOOL_F
; /* not a digit */
1587 if (blen
* SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
))
1588 if SCM_INUMP(res
= scm_big2inum(res
, blen
)) return res
;
1589 if (j
==blen
) return res
;
1590 return scm_adjbig(res
, blen
);
1596 scm_istr2flo(str
, len
, radix
)
1601 register int c
, i
= 0;
1603 double res
= 0.0, tmp
= 0.0;
1608 if (i
>= len
) return SCM_BOOL_F
; /* zero scm_length */
1610 switch (*str
) { /* leading sign */
1611 case '-': lead_sgn
= -1.0; i
++; break;
1612 case '+': lead_sgn
= 1.0; i
++; break;
1613 default : lead_sgn
= 0.0;
1615 if (i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1617 if (str
[i
]=='i' || str
[i
]=='I') { /* handle `+i' and `-i' */
1618 if (lead_sgn
==0.0) return SCM_BOOL_F
; /* must have leading sign */
1619 if (++i
< len
) return SCM_BOOL_F
; /* `i' not last character */
1620 return scm_makdbl(0.0, lead_sgn
);
1622 do { /* check initial digits */
1623 switch (c
= str
[i
]) {
1627 case 'D': case 'E': case 'F':
1628 if (radix
==10) goto out1
; /* must be exponent */
1629 case 'A': case 'B': case 'C':
1632 case 'd': case 'e': case 'f':
1633 if (radix
==10) goto out1
;
1634 case 'a': case 'b': case 'c':
1637 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1638 res
= res
* radix
+ c
;
1639 flg
= 1; /* res is valid */
1644 } while (++i
< len
);
1647 /* if true, then we did see a digit above, and res is valid */
1648 if (i
==len
) goto done
;
1650 /* By here, must have seen a digit,
1651 or must have next char be a `.' with radix==10 */
1653 if (!(str
[i
]=='.' && radix
==10))
1656 while (str
[i
]=='#') { /* optional sharps */
1658 if (++i
==len
) goto done
;
1663 switch (c
= str
[i
]) {
1667 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1670 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1673 if (c
>= radix
) return SCM_BOOL_F
;
1674 tmp
= tmp
* radix
+ c
;
1681 if (tmp
==0.0) return SCM_BOOL_F
; /* `slash zero' not allowed */
1683 while (str
[i
]=='#') { /* optional sharps */
1685 if (++i
==len
) break;
1691 if (str
[i
]=='.') { /* decimal point notation */
1692 if (radix
!= 10) return SCM_BOOL_F
; /* must be radix 10 */
1694 switch (c
= str
[i
]) {
1697 res
= res
*10.0 + c
-'0';
1705 if (!flg
) return SCM_BOOL_F
; /* no digits before or after decimal point */
1706 if (i
==len
) goto adjust
;
1707 while (str
[i
]=='#') { /* ignore remaining sharps */
1708 if (++i
==len
) goto adjust
;
1712 switch (str
[i
]) { /* exponent */
1717 case 's': case 'S': {
1718 int expsgn
= 1, expon
= 0;
1719 if (radix
!= 10) return SCM_BOOL_F
; /* only in radix 10 */
1720 if (++i
==len
) return SCM_BOOL_F
; /* bad exponent */
1722 case '-': expsgn
=(-1);
1723 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad exponent */
1725 if (str
[i
] < '0' || str
[i
] > '9') return SCM_BOOL_F
; /* bad exponent */
1727 switch (c
= str
[i
]) {
1729 expon
= expon
*10 + c
-'0';
1730 if (expon
> MAXEXP
) return SCM_BOOL_F
; /* exponent too large */
1735 } while (++i
< len
);
1737 point
+= expsgn
*expon
;
1743 while (point
--) res
*= 10.0;
1746 while (point
++) res
*= 0.1;
1748 while (point
++) res
/= 10.0;
1752 /* at this point, we have a legitimate floating point result */
1753 if (lead_sgn
==-1.0) res
= -res
;
1754 if (i
==len
) return scm_makdbl(res
, 0.0);
1756 if (str
[i
]=='i' || str
[i
]=='I') { /* pure imaginary number */
1757 if (lead_sgn
==0.0) return SCM_BOOL_F
; /* must have leading sign */
1758 if (++i
< len
) return SCM_BOOL_F
; /* `i' not last character */
1759 return scm_makdbl(0.0, res
);
1763 case '-': lead_sgn
= -1.0; break;
1764 case '+': lead_sgn
= 1.0; break;
1765 case '@': { /* polar input for complex number */
1766 /* get a `real' for scm_angle */
1767 second
= scm_istr2flo(&str
[i
], (long)(len
-i
), radix
);
1768 if (!(SCM_INEXP(second
))) return SCM_BOOL_F
; /* not `real' */
1769 if (SCM_CPLXP(second
)) return SCM_BOOL_F
; /* not `real' */
1770 tmp
= SCM_REALPART(second
);
1771 return scm_makdbl(res
*cos(tmp
), res
*sin(tmp
));
1773 default: return SCM_BOOL_F
;
1776 /* at this point, last char must be `i' */
1777 if (str
[len
-1] != 'i' && str
[len
-1] != 'I') return SCM_BOOL_F
;
1778 /* handles `x+i' and `x-i' */
1779 if (i
==(len
-1)) return scm_makdbl(res
, lead_sgn
);
1780 /* get a `ureal' for complex part */
1781 second
= scm_istr2flo(&str
[i
], (long)((len
-i
)-1), radix
);
1782 if (!(SCM_INEXP(second
))) return SCM_BOOL_F
; /* not `ureal' */
1783 if (SCM_CPLXP(second
)) return SCM_BOOL_F
; /* not `ureal' */
1784 tmp
= SCM_REALPART(second
);
1785 if (tmp
< 0.0) return SCM_BOOL_F
; /* not `ureal' */
1786 return scm_makdbl(res
, (lead_sgn
*tmp
));
1788 #endif /* SCM_FLOATS */
1793 scm_istring2number(str
, len
, radix
)
1800 char ex_p
= 0, rx_p
= 0; /* Only allow 1 exactness and 1 radix prefix */
1803 if (*str
=='+' || *str
=='-') /* Catches lone `+' and `-' for speed */
1806 while ((len
-i
) >= 2 && str
[i
]=='#' && ++i
)
1808 case 'b': case 'B': if (rx_p
++) return SCM_BOOL_F
; radix
= 2; break;
1809 case 'o': case 'O': if (rx_p
++) return SCM_BOOL_F
; radix
= 8; break;
1810 case 'd': case 'D': if (rx_p
++) return SCM_BOOL_F
; radix
= 10; break;
1811 case 'x': case 'X': if (rx_p
++) return SCM_BOOL_F
; radix
= 16; break;
1812 case 'i': case 'I': if (ex_p
++) return SCM_BOOL_F
; ex
= 2; break;
1813 case 'e': case 'E': if (ex_p
++) return SCM_BOOL_F
; ex
= 1; break;
1814 default: return SCM_BOOL_F
;
1819 return scm_istr2int(&str
[i
], len
-i
, radix
);
1821 res
= scm_istr2int(&str
[i
], len
-i
, radix
);
1822 if SCM_NFALSEP(res
) return res
;
1824 case 2: return scm_istr2flo(&str
[i
], len
-i
, radix
);
1831 SCM_PROC(s_string_to_number
, "string->number", 1, 1, 0, scm_string_to_number
);
1834 scm_string_to_number(str
, radix
)
1839 if SCM_UNBNDP(radix
) radix
=SCM_MAKINUM(10L);
1840 else SCM_ASSERT(SCM_INUMP(radix
), radix
, SCM_ARG2
, s_string_to_number
);
1841 SCM_ASSERT(SCM_NIMP(str
) && SCM_ROSTRINGP(str
), str
, SCM_ARG1
, s_string_to_number
);
1842 answer
= scm_istring2number(SCM_ROCHARS(str
), SCM_ROLENGTH(str
), SCM_INUM(radix
));
1843 return scm_return_first (answer
, str
);
1845 /*** END strs->nums ***/
1855 if ((y
==0.0) && (x
==0.0)) return scm_flo0
;
1861 # ifndef SCM_SINGLESONLY
1862 if ((-FLTMAX
< x
) && (x
< FLTMAX
) && (fx
==x
))
1865 SCM_SETCAR (z
, scm_tc_flo
);
1870 # endif/* def SCM_SINGLES */
1871 SCM_SETCDR (z
, (SCM
)scm_must_malloc(1L*sizeof(double), "real"));
1872 SCM_SETCAR (z
, scm_tc_dblr
);
1875 SCM_SETCDR (z
, (SCM
)scm_must_malloc(2L*sizeof(double), "complex"));
1876 SCM_SETCAR (z
, scm_tc_dblc
);
1893 if (0==scm_bigcomp(x
, y
)) return SCM_BOOL_T
;
1906 if (SCM_REALPART(x
) != SCM_REALPART(y
)) return SCM_BOOL_F
;
1907 if (!(SCM_CPLXP(x
) && (SCM_IMAG(x
) != SCM_IMAG(y
)))) return SCM_BOOL_T
;
1915 SCM_PROC(s_number_p
, "number?", 1, 0, 0, scm_number_p
);
1916 SCM_PROC(s_complex_p
, "complex?", 1, 0, 0, scm_number_p
);
1922 if SCM_INUMP(x
) return SCM_BOOL_T
;
1924 if (SCM_NIMP(x
) && SCM_NUMP(x
)) return SCM_BOOL_T
;
1927 if (SCM_NIMP(x
) && SCM_NUMP(x
)) return SCM_BOOL_T
;
1936 SCM_PROC(s_real_p
, "real?", 1, 0, 0, scm_real_p
);
1937 SCM_PROC(s_rational_p
, "rational?", 1, 0, 0, scm_real_p
);
1958 SCM_PROC(s_int_p
, "integer?", 1, 0, 0, scm_integer_p
);
1965 if SCM_INUMP(x
) return SCM_BOOL_T
;
1966 if SCM_IMP(x
) return SCM_BOOL_F
;
1968 if SCM_BIGP(x
) return SCM_BOOL_T
;
1970 if (!SCM_INEXP(x
)) return SCM_BOOL_F
;
1971 if (SCM_CPLXP(x
)) return SCM_BOOL_F
;
1972 r
= SCM_REALPART(x
);
1973 if (r
==floor(r
)) return SCM_BOOL_T
;
1979 #endif /* SCM_FLOATS */
1981 SCM_PROC(s_inexact_p
, "inexact?", 1, 0, 0, scm_inexact_p
);
1988 if (SCM_NIMP(x
) && SCM_INEXP(x
)) return SCM_BOOL_T
;
1996 SCM_PROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
);
2009 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_eq_p
);
2012 if SCM_INUMP(y
) return SCM_BOOL_F
;
2013 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2014 if SCM_BIGP(y
) return (0==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2015 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2017 return (SCM_REALP(y
) && (scm_big2dbl(x
)==SCM_REALPART(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2019 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2021 SCM_ASSERT(SCM_NIMP(x
) && SCM_INEXP(x
), x
, SCM_ARG1
, s_eq_p
);
2023 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto realint
;}
2025 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2026 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
2027 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2029 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2031 if (SCM_REALPART(x
) != SCM_REALPART(y
)) return SCM_BOOL_F
;
2033 return (SCM_CPLXP(y
) && (SCM_IMAG(x
)==SCM_IMAG(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2034 return SCM_CPLXP(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
2038 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2039 if SCM_BIGP(y
) return SCM_BOOL_F
;
2041 if (!(SCM_INEXP(y
)))
2042 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2046 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2047 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2051 return (SCM_REALP(y
) && (((double)SCM_INUM(x
))==SCM_REALPART(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2056 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_eq_p
);
2057 if SCM_INUMP(y
) return SCM_BOOL_F
;
2058 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2059 return (0==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2063 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2064 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2069 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_eq_p
);
2070 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_eq_p
);
2073 return ((long)x
==(long)y
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2078 SCM_PROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
);
2090 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_less_p
);
2093 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2094 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2095 if SCM_BIGP(y
) return (1==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2096 SCM_ASRTGO(SCM_REALP(y
), bady
);
2097 return (scm_big2dbl(x
) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2099 SCM_ASRTGO(SCM_REALP(x
), badx
);
2101 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_less_p
);
2104 return (SCM_REALPART(x
) < ((double)SCM_INUM(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2106 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2107 if SCM_BIGP(y
) return (SCM_REALPART(x
) < scm_big2dbl(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2108 SCM_ASRTGO(SCM_REALP(y
), bady
);
2110 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2112 return (SCM_REALPART(x
) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2116 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2117 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
2119 if (!(SCM_REALP(y
)))
2120 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2124 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2125 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2128 return (((double)SCM_INUM(x
)) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2133 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_less_p
);
2134 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2135 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2136 return (1==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2140 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2141 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2143 return SCM_BIGSIGN(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
2146 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_less_p
);
2147 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_less_p
);
2150 return ((long)x
< (long)y
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2154 SCM_PROC1 (s_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
);
2161 return scm_less_p(y
, x
);
2166 SCM_PROC1 (s_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
);
2173 return SCM_BOOL_NOT(scm_less_p(y
, x
));
2178 SCM_PROC1 (s_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
);
2185 return SCM_BOOL_NOT(scm_less_p(x
, y
));
2190 SCM_PROC(s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
);
2199 SCM_ASRTGO(SCM_NIMP(z
), badz
);
2200 if SCM_BIGP(z
) return SCM_BOOL_F
;
2202 if (!(SCM_INEXP(z
)))
2203 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_zero_p
);
2206 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_zero_p
);
2208 return (z
==scm_flo0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2213 SCM_ASSERT(SCM_NIMP(z
) && SCM_BIGP(z
), z
, SCM_ARG1
, s_zero_p
);
2217 SCM_ASSERT(SCM_INUMP(z
), z
, SCM_ARG1
, s_zero_p
);
2220 return (z
==SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2225 SCM_PROC(s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
);
2234 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2235 if SCM_BIGP(x
) return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_T
: SCM_BOOL_F
;
2237 if (!(SCM_REALP(x
)))
2238 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_positive_p
);
2241 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_positive_p
);
2243 return (SCM_REALPART(x
) > 0.0) ? SCM_BOOL_T
: SCM_BOOL_F
;
2248 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_positive_p
);
2249 return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_T
: SCM_BOOL_F
;
2252 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_positive_p
);
2255 return (x
> SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2260 SCM_PROC(s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
);
2269 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2270 if SCM_BIGP(x
) return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_F
: SCM_BOOL_T
;
2272 if (!(SCM_REALP(x
)))
2273 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_negative_p
);
2276 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_negative_p
);
2278 return (SCM_REALPART(x
) < 0.0) ? SCM_BOOL_T
: SCM_BOOL_F
;
2283 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_negative_p
);
2284 return (SCM_TYP16(x
)==scm_tc16_bigneg
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2287 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_negative_p
);
2290 return (x
< SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2294 SCM_PROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
);
2306 if (!(SCM_NUMBERP(x
)))
2307 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_max
);
2314 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2316 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? y
: x
;
2317 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2318 if SCM_BIGP(y
) return (1==scm_bigcomp(x
, y
)) ? y
: x
;
2319 SCM_ASRTGO(SCM_REALP(y
), bady
);
2321 return (z
< SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2323 SCM_ASRTGO(SCM_REALP(x
), badx
);
2325 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_max
);
2328 return (SCM_REALPART(x
) < (z
= SCM_INUM(y
))) ? scm_makdbl(z
, 0.0) : x
;
2330 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2332 return (SCM_REALPART(x
) < (z
= scm_big2dbl(y
))) ? scm_makdbl(z
, 0.0) : x
;
2333 SCM_ASRTGO(SCM_REALP(y
), bady
);
2335 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2337 return (SCM_REALPART(x
) < SCM_REALPART(y
)) ? y
: x
;
2341 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2342 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? x
: y
;
2344 if (!(SCM_REALP(y
)))
2345 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2349 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2350 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2353 return ((z
= SCM_INUM(x
)) < SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2358 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_max
);
2359 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? y
: x
;
2360 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2361 return (1==scm_bigcomp(x
, y
)) ? y
: x
;
2365 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2366 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2368 return SCM_BIGSIGN(y
) ? x
: y
;
2371 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_max
);
2372 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_max
);
2375 return ((long)x
< (long)y
) ? y
: x
;
2381 SCM_PROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
);
2393 if (!(SCM_NUMBERP(x
)))
2394 badx
:scm_wta(x
, (char *)SCM_ARG1
, s_min
);
2401 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2403 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? x
: y
;
2404 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2405 if SCM_BIGP(y
) return (-1==scm_bigcomp(x
, y
)) ? y
: x
;
2406 SCM_ASRTGO(SCM_REALP(y
), bady
);
2408 return (z
> SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2410 SCM_ASRTGO(SCM_REALP(x
), badx
);
2412 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_min
);
2414 if SCM_INUMP(y
) return (SCM_REALPART(x
) > (z
= SCM_INUM(y
))) ? scm_makdbl(z
, 0.0) : x
;
2416 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2417 if SCM_BIGP(y
) return (SCM_REALPART(x
) > (z
= scm_big2dbl(y
))) ? scm_makdbl(z
, 0.0) : x
;
2418 SCM_ASRTGO(SCM_REALP(y
), bady
);
2420 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2422 return (SCM_REALPART(x
) > SCM_REALPART(y
)) ? y
: x
;
2426 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2427 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? y
: x
;
2429 if (!(SCM_REALP(y
)))
2430 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2434 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2435 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2438 return ((z
= SCM_INUM(x
)) > SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2443 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_min
);
2444 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? x
: y
;
2445 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2446 return (-1==scm_bigcomp(x
, y
)) ? y
: x
;
2450 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2451 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2453 return SCM_BIGSIGN(y
) ? y
: x
;
2456 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_min
);
2457 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_min
);
2460 return ((long)x
> (long)y
) ? y
: x
;
2466 SCM_PROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
);
2474 if SCM_UNBNDP(x
) return SCM_INUM0
;
2476 if (!(SCM_NUMBERP(x
)))
2477 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_sum
);
2485 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2487 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2488 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2490 if (SCM_NUMDIGS(x
) > SCM_NUMDIGS(y
)) {t
= x
; x
= y
; y
= t
;}
2491 return scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0);
2493 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2494 bigreal
: return scm_makdbl(scm_big2dbl(x
)+SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_IMAG(y
):0.0);
2496 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2498 SCM_ASRTGO(SCM_NIMP(x
) && SCM_INEXP(x
), badx
);
2500 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intreal
;}
2502 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2503 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
2505 else if (!(SCM_INEXP(y
)))
2506 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2510 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2511 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2515 if SCM_CPLXP(x
) i
= SCM_IMAG(x
);
2516 if SCM_CPLXP(y
) i
+= SCM_IMAG(y
);
2517 return scm_makdbl(SCM_REALPART(x
)+SCM_REALPART(y
), i
); }
2521 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2524 # ifndef SCM_DIGSTOOBIG
2525 long z
= scm_pseudolong(SCM_INUM(x
));
2526 return scm_addbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2528 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2529 scm_longdigs(SCM_INUM(x
), zdigs
);
2530 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2533 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2535 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2537 intreal
: return scm_makdbl(SCM_INUM(x
)+SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_IMAG(y
):0.0);
2543 SCM_ASRTGO(SCM_NIMP(x
) && SCM_BIGP(x
), badx
);
2544 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2545 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2546 if (SCM_NUMDIGS(x
) > SCM_NUMDIGS(y
)) {t
= x
; x
= y
; y
= t
;}
2547 return scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0);
2551 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2552 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2555 # ifndef SCM_DIGSTOOBIG
2556 long z
= scm_pseudolong(SCM_INUM(x
));
2557 return scm_addbig(&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2559 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2560 scm_longdigs(SCM_INUM(x
), zdigs
);
2561 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2566 SCM_ASRTGO(SCM_INUMP(x
), badx
);
2567 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_sum
);
2570 x
= SCM_INUM(x
)+SCM_INUM(y
);
2571 if SCM_FIXABLE(x
) return SCM_MAKINUM(x
);
2573 return scm_long2big(x
);
2576 return scm_makdbl((double)x
, 0.0);
2578 scm_num_overflow (s_sum
);
2579 return SCM_UNSPECIFIED
;
2587 SCM_PROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
);
2590 scm_difference(x
, y
)
2598 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_difference
);
2603 x
= scm_copybig(x
, !SCM_BIGSIGN(x
));
2604 return SCM_NUMDIGS(x
) * SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
) ?
2605 scm_big2inum(x
, SCM_NUMDIGS(x
)) : x
;
2608 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2609 return scm_makdbl(-SCM_REALPART(x
), SCM_CPLXP(x
)?-SCM_IMAG(x
):0.0);
2611 if SCM_INUMP(y
) return scm_sum(x
, SCM_MAKINUM(-SCM_INUM(y
)));
2613 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2615 if SCM_BIGP(y
) return (SCM_NUMDIGS(x
) < SCM_NUMDIGS(y
)) ?
2616 scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0x0100) :
2617 scm_addbig(SCM_BDIGITS(y
), SCM_NUMDIGS(y
), SCM_BIGSIGN(y
) ^ 0x0100, x
, 0);
2618 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2619 return scm_makdbl(scm_big2dbl(x
)-SCM_REALPART(y
), SCM_CPLXP(y
)?-SCM_IMAG(y
):0.0);
2621 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2622 if SCM_BIGP(y
) return scm_makdbl(SCM_REALPART(x
)-scm_big2dbl(y
), SCM_CPLXP(x
)?SCM_IMAG(x
):0.0);
2623 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2625 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2626 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2631 return scm_makdbl (SCM_REAL (x
) - SCM_REAL (y
),
2632 SCM_IMAG (x
) - SCM_IMAG (y
));
2634 return scm_makdbl (SCM_REAL (x
) - SCM_REALPART(y
), SCM_IMAG (x
));
2636 return scm_makdbl (SCM_REALPART (x
) - SCM_REALPART (y
),
2637 SCM_CPLXP(y
) ? - SCM_IMAG (y
) : 0.0);
2639 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2642 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2644 # ifndef SCM_DIGSTOOBIG
2645 long z
= scm_pseudolong(SCM_INUM(x
));
2646 return scm_addbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2648 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2649 scm_longdigs(SCM_INUM(x
), zdigs
);
2650 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2654 if (!(SCM_INEXP(y
)))
2655 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2659 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2660 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2663 return scm_makdbl(SCM_INUM(x
)-SCM_REALPART(y
), SCM_CPLXP(y
)?-SCM_IMAG(y
):0.0);
2668 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_difference
);
2670 x
= scm_copybig(x
, !SCM_BIGSIGN(x
));
2671 return SCM_NUMDIGS(x
) * SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
) ?
2672 scm_big2inum(x
, SCM_NUMDIGS(x
)) : x
;
2675 # ifndef SCM_DIGSTOOBIG
2676 long z
= scm_pseudolong(SCM_INUM(y
));
2677 return scm_addbig(&z
, SCM_DIGSPERLONG
, (y
< 0) ? 0 : 0x0100, x
, 0);
2679 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2680 scm_longdigs(SCM_INUM(x
), zdigs
);
2681 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (y
< 0) ? 0 : 0x0100, x
, 0);
2684 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2685 return (SCM_NUMDIGS(x
) < SCM_NUMDIGS(y
)) ?
2686 scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0x0100) :
2687 scm_addbig(SCM_BDIGITS(y
), SCM_NUMDIGS(y
), SCM_BIGSIGN(y
) ^ 0x0100, x
, 0);
2689 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2692 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2693 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2696 # ifndef SCM_DIGSTOOBIG
2697 long z
= scm_pseudolong(SCM_INUM(x
));
2698 return scm_addbig(&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2700 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2701 scm_longdigs(SCM_INUM(x
), zdigs
);
2702 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2707 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_difference
);
2708 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2709 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_difference
);
2712 x
= SCM_INUM(x
)-SCM_INUM(y
);
2714 if SCM_FIXABLE(x
) return SCM_MAKINUM(x
);
2716 return scm_long2big(x
);
2719 return scm_makdbl((double)x
, 0.0);
2721 scm_num_overflow (s_difference
);
2722 return SCM_UNSPECIFIED
;
2730 SCM_PROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
);
2738 if SCM_UNBNDP(x
) return SCM_MAKINUM(1L);
2740 if (!(SCM_NUMBERP(x
)))
2741 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_product
);
2749 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2751 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2752 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2753 if SCM_BIGP(y
) return scm_mulbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2754 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
));
2755 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2757 double bg
= scm_big2dbl(x
);
2758 return scm_makdbl(bg
*SCM_REALPART(y
), SCM_CPLXP(y
)?bg
*SCM_IMAG(y
):0.0); }
2760 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2762 SCM_ASRTGO(SCM_NIMP(x
) && SCM_INEXP(x
), badx
);
2764 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intreal
;}
2766 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2767 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
2769 else if (!(SCM_INEXP(y
)))
2770 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
2774 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2775 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
2781 return scm_makdbl (SCM_REAL (x
) * SCM_REAL (y
)
2782 - SCM_IMAG (x
) * SCM_IMAG (y
),
2783 SCM_REAL (x
) * SCM_IMAG (y
)
2784 + SCM_IMAG (x
) * SCM_REAL (y
));
2786 return scm_makdbl (SCM_REAL (x
) * SCM_REALPART (y
),
2787 SCM_IMAG (x
) * SCM_REALPART(y
));
2789 return scm_makdbl (SCM_REALPART (x
) * SCM_REALPART (y
),
2790 SCM_CPLXP (y
) ? SCM_REALPART (x
) * SCM_IMAG (y
) : 0.0);
2794 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2796 intbig
: if (SCM_INUM0
==x
) return x
; if (SCM_MAKINUM(1L)==x
) return y
;
2798 # ifndef SCM_DIGSTOOBIG
2799 long z
= scm_pseudolong(SCM_INUM(x
));
2800 return scm_mulbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2801 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
2803 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2804 scm_longdigs(SCM_INUM(x
), zdigs
);
2805 return scm_mulbig(zdigs
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2806 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
2810 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2812 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2814 intreal
: return scm_makdbl(SCM_INUM(x
)*SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_INUM(x
)*SCM_IMAG(y
):0.0);
2819 SCM_ASRTGO(SCM_NIMP(x
) && SCM_BIGP(x
), badx
);
2820 if SCM_INUMP(y
) {SCM t
= x
; x
= y
; y
= t
; goto intbig
;}
2821 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2822 return scm_mulbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2823 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
));
2827 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2828 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
2830 intbig
: if (SCM_INUM0
==x
) return x
; if (SCM_MAKINUM(1L)==x
) return y
;
2832 # ifndef SCM_DIGSTOOBIG
2833 long z
= scm_pseudolong(SCM_INUM(x
));
2834 return scm_mulbig(&z
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2835 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
2837 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2838 scm_longdigs(SCM_INUM(x
), zdigs
);
2839 return scm_mulbig(zdigs
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2840 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
2845 SCM_ASRTGO(SCM_INUMP(x
), badx
);
2846 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_product
);
2856 if (k
!= SCM_INUM(y
) || k
/i
!= j
)
2858 { int sgn
= (i
< 0) ^ (j
< 0);
2859 # ifndef SCM_DIGSTOOBIG
2860 i
= scm_pseudolong(i
);
2861 j
= scm_pseudolong(j
);
2862 return scm_mulbig((SCM_BIGDIG
*)&i
, SCM_DIGSPERLONG
,
2863 (SCM_BIGDIG
*)&j
, SCM_DIGSPERLONG
, sgn
);
2864 # else /* SCM_DIGSTOOBIG */
2865 SCM_BIGDIG idigs
[SCM_DIGSPERLONG
];
2866 SCM_BIGDIG jdigs
[SCM_DIGSPERLONG
];
2867 scm_longdigs(i
, idigs
);
2868 scm_longdigs(j
, jdigs
);
2869 return scm_mulbig(idigs
, SCM_DIGSPERLONG
, jdigs
, SCM_DIGSPERLONG
, sgn
);
2874 return scm_makdbl(((double)i
)*((double)j
), 0.0);
2876 scm_num_overflow (s_product
);
2886 scm_num2dbl (a
, why
)
2891 return (double) SCM_INUM (a
);
2893 SCM_ASSERT (SCM_NIMP (a
), a
, "wrong type argument", why
);
2895 return (SCM_REALPART (a
));
2898 return scm_big2dbl (a
);
2900 SCM_ASSERT (0, a
, "wrong type argument", why
);
2901 return SCM_UNSPECIFIED
;
2905 SCM_PROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
);
2917 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_divide
);
2921 if SCM_BIGP(x
) return scm_makdbl(1.0/scm_big2dbl(x
), 0.0);
2923 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2924 if SCM_REALP(x
) return scm_makdbl(1.0/SCM_REALPART(x
), 0.0);
2925 r
= SCM_REAL(x
); i
= SCM_IMAG(x
); d
= r
*r
+i
*i
;
2926 return scm_makdbl(r
/d
, -i
/d
);
2935 scm_num_overflow (s_divide
);
2939 if (z
< SCM_BIGRAD
) {
2940 SCM w
= scm_copybig(x
, SCM_BIGSIGN(x
) ? (y
>0) : (y
<0));
2941 return scm_divbigdig(SCM_BDIGITS(w
), SCM_NUMDIGS(w
), (SCM_BIGDIG
)z
) ?
2942 scm_makdbl(scm_big2dbl(x
)/SCM_INUM(y
), 0.0) : scm_normbig(w
);
2944 # ifndef SCM_DIGSTOOBIG
2945 z
= scm_pseudolong(z
);
2946 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), (SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
2947 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);
2949 { SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2950 scm_longdigs(z
, zdigs
);
2951 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), zdigs
, SCM_DIGSPERLONG
,
2952 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);}
2954 return z
? z
: scm_makdbl(scm_big2dbl(x
)/SCM_INUM(y
), 0.0);
2956 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2958 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2959 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
), 3);
2960 return z
? z
: scm_makdbl(scm_big2dbl(x
)/scm_big2dbl(y
), 0.0);
2962 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2963 if SCM_REALP(y
) return scm_makdbl(scm_big2dbl(x
)/SCM_REALPART(y
), 0.0);
2968 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2969 if SCM_INUMP(y
) {d
= SCM_INUM(y
); goto basic_div
;}
2971 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2972 if SCM_BIGP(y
) {d
= scm_big2dbl(y
); goto basic_div
;}
2973 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2975 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2978 d
= SCM_REALPART(y
);
2979 basic_div
: return scm_makdbl(SCM_REALPART(x
)/d
, SCM_CPLXP(x
)?SCM_IMAG(x
)/d
:0.0);
2981 a
= SCM_REALPART(x
);
2982 if SCM_REALP(x
) goto complex_div
;
2983 r
= SCM_REAL(y
); i
= SCM_IMAG(y
); d
= r
*r
+i
*i
;
2984 return scm_makdbl((a
*r
+SCM_IMAG(x
)*i
)/d
, (SCM_IMAG(x
)*r
-a
*i
)/d
);
2987 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
2988 return scm_makdbl(1.0/((double)SCM_INUM(x
)), 0.0);
2992 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2993 if SCM_BIGP(y
) return scm_makdbl(SCM_INUM(x
)/scm_big2dbl(y
), 0.0);
2995 if (!(SCM_INEXP(y
)))
2996 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
3000 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
3001 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
3005 return scm_makdbl(SCM_INUM(x
)/SCM_REALPART(y
), 0.0);
3008 r
= SCM_REAL(y
); i
= SCM_IMAG(y
); d
= r
*r
+i
*i
;
3009 return scm_makdbl((a
*r
)/d
, (-a
*i
)/d
);
3015 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_divide
);
3016 if SCM_UNBNDP(y
) goto ov
;
3022 if (z
< SCM_BIGRAD
) {
3023 SCM w
= scm_copybig(x
, SCM_BIGSIGN(x
) ? (y
>0) : (y
<0));
3024 if (scm_divbigdig(SCM_BDIGITS(w
), SCM_NUMDIGS(w
), (SCM_BIGDIG
)z
)) goto ov
;
3027 # ifndef SCM_DIGSTOOBIG
3028 z
= scm_pseudolong(z
);
3029 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), &z
, SCM_DIGSPERLONG
,
3030 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);
3032 { SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3033 scm_longdigs(z
, zdigs
);
3034 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), zdigs
, SCM_DIGSPERLONG
,
3035 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);}
3038 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
3039 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3040 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
), 3);
3046 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
3051 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
3052 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
3057 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_divide
);
3059 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
3062 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_divide
);
3066 long z
= SCM_INUM(y
);
3067 if ((0==z
) || SCM_INUM(x
)%z
) goto ov
;
3069 if SCM_FIXABLE(z
) return SCM_MAKINUM(z
);
3071 return scm_long2big(z
);
3074 ov
: return scm_makdbl(((double)SCM_INUM(x
))/((double)SCM_INUM(y
)), 0.0);
3076 ov
: scm_num_overflow (s_divide
);
3077 return SCM_UNSPECIFIED
;
3086 SCM_PROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
);
3092 return log(x
+sqrt(x
*x
+1));
3098 SCM_PROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
);
3104 return log(x
+sqrt(x
*x
-1));
3110 SCM_PROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
);
3116 return 0.5*log((1+x
)/(1-x
));
3122 SCM_PROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
);
3128 if (x
< 0.0) return -floor(-x
);
3134 SCM_PROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
);
3140 double plus_half
= x
+ 0.5;
3141 double result
= floor(plus_half
);
3142 /* Adjust so that the scm_round is towards even. */
3143 return (plus_half
== result
&& plus_half
/ 2 != floor(plus_half
/ 2))
3144 ? result
- 1 : result
;
3149 SCM_PROC1 (s_exact_to_inexact
, "exact->inexact", scm_tc7_cxr
, (SCM (*)()) scm_exact_to_inexact
);
3152 scm_exact_to_inexact(z
)
3159 SCM_PROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
);
3160 SCM_PROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
);
3161 SCM_PROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)())sqrt
);
3162 SCM_PROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)())fabs
);
3163 SCM_PROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)())exp
);
3164 SCM_PROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)())log
);
3165 SCM_PROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)())sin
);
3166 SCM_PROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)())cos
);
3167 SCM_PROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)())tan
);
3168 SCM_PROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)())asin
);
3169 SCM_PROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)())acos
);
3170 SCM_PROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)())atan
);
3171 SCM_PROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)())sinh
);
3172 SCM_PROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)())cosh
);
3173 SCM_PROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)())tanh
);
3175 struct dpair
{double x
, y
;};
3177 static void scm_two_doubles
SCM_P ((SCM z1
, SCM z2
, char *sstring
, struct dpair
*xy
));
3180 scm_two_doubles(z1
, z2
, sstring
, xy
)
3185 if SCM_INUMP(z1
) xy
->x
= SCM_INUM(z1
);
3188 SCM_ASRTGO(SCM_NIMP(z1
), badz1
);
3189 if SCM_BIGP(z1
) xy
->x
= scm_big2dbl(z1
);
3192 if (!(SCM_REALP(z1
)))
3193 badz1
: scm_wta(z1
, (char *)SCM_ARG1
, sstring
);
3195 xy
->x
= SCM_REALPART(z1
);}
3197 {SCM_ASSERT(SCM_NIMP(z1
) && SCM_REALP(z1
), z1
, SCM_ARG1
, sstring
);
3198 xy
->x
= SCM_REALPART(z1
);}
3201 if SCM_INUMP(z2
) xy
->y
= SCM_INUM(z2
);
3204 SCM_ASRTGO(SCM_NIMP(z2
), badz2
);
3205 if SCM_BIGP(z2
) xy
->y
= scm_big2dbl(z2
);
3208 if (!(SCM_REALP(z2
)))
3209 badz2
: scm_wta(z2
, (char *)SCM_ARG2
, sstring
);
3211 xy
->y
= SCM_REALPART(z2
);}
3213 {SCM_ASSERT(SCM_NIMP(z2
) && SCM_REALP(z2
), z2
, SCM_ARG2
, sstring
);
3214 xy
->y
= SCM_REALPART(z2
);}
3222 SCM_PROC(s_sys_expt
, "$expt", 2, 0, 0, scm_sys_expt
);
3225 scm_sys_expt(z1
, z2
)
3230 scm_two_doubles(z1
, z2
, s_sys_expt
, &xy
);
3231 return scm_makdbl(pow(xy
.x
, xy
.y
), 0.0);
3236 SCM_PROC(s_sys_atan2
, "$atan2", 2, 0, 0, scm_sys_atan2
);
3239 scm_sys_atan2(z1
, z2
)
3244 scm_two_doubles(z1
, z2
, s_sys_atan2
, &xy
);
3245 return scm_makdbl(atan2(xy
.x
, xy
.y
), 0.0);
3250 SCM_PROC(s_make_rectangular
, "make-rectangular", 2, 0, 0, scm_make_rectangular
);
3253 scm_make_rectangular(z1
, z2
)
3258 scm_two_doubles(z1
, z2
, s_make_rectangular
, &xy
);
3259 return scm_makdbl(xy
.x
, xy
.y
);
3264 SCM_PROC(s_make_polar
, "make-polar", 2, 0, 0, scm_make_polar
);
3267 scm_make_polar(z1
, z2
)
3272 scm_two_doubles(z1
, z2
, s_make_polar
, &xy
);
3273 return scm_makdbl(xy
.x
*cos(xy
.y
), xy
.x
*sin(xy
.y
));
3279 SCM_PROC(s_real_part
, "real-part", 1, 0, 0, scm_real_part
);
3287 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3288 if SCM_BIGP(z
) return z
;
3290 if (!(SCM_INEXP(z
)))
3291 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_real_part
);
3294 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_real_part
);
3296 if SCM_CPLXP(z
) return scm_makdbl(SCM_REAL(z
), 0.0);
3303 SCM_PROC(s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
);
3309 if SCM_INUMP(z
) return SCM_INUM0
;
3311 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3312 if SCM_BIGP(z
) return SCM_INUM0
;
3314 if (!(SCM_INEXP(z
)))
3315 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_imag_part
);
3318 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_imag_part
);
3320 if SCM_CPLXP(z
) return scm_makdbl(SCM_IMAG(z
), 0.0);
3326 SCM_PROC(s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
);
3332 if SCM_INUMP(z
) return scm_abs(z
);
3334 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3335 if SCM_BIGP(z
) return scm_abs(z
);
3337 if (!(SCM_INEXP(z
)))
3338 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_magnitude
);
3341 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_magnitude
);
3345 double i
= SCM_IMAG(z
), r
= SCM_REAL(z
);
3346 return scm_makdbl(sqrt(i
*i
+r
*r
), 0.0);
3348 return scm_makdbl(fabs(SCM_REALPART(z
)), 0.0);
3354 SCM_PROC(s_angle
, "angle", 1, 0, 0, scm_angle
);
3361 if SCM_INUMP(z
) {x
= (z
>=SCM_INUM0
) ? 1.0 : -1.0; goto do_angle
;}
3363 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3364 if SCM_BIGP(z
) {x
= (SCM_TYP16(z
)==scm_tc16_bigpos
) ? 1.0 : -1.0; goto do_angle
;}
3366 if (!(SCM_INEXP(z
))) {
3367 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_angle
);}
3370 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_angle
);
3374 x
= SCM_REALPART(z
);
3377 x
= SCM_REAL(z
); y
= SCM_IMAG(z
);
3379 return scm_makdbl(atan2(y
, x
), 0.0);
3383 SCM_PROC(s_inexact_to_exact
, "inexact->exact", 1, 0, 0, scm_inexact_to_exact
);
3386 scm_inexact_to_exact(z
)
3389 if SCM_INUMP(z
) return z
;
3391 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3392 if SCM_BIGP(z
) return z
;
3394 if (!(SCM_REALP(z
)))
3395 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_inexact_to_exact
);
3398 SCM_ASSERT(SCM_NIMP(z
) && SCM_REALP(z
), z
, SCM_ARG1
, s_inexact_to_exact
);
3402 double u
= floor(SCM_REALPART(z
)+0.5);
3403 if ((u
<= SCM_MOST_POSITIVE_FIXNUM
) && (-u
<= -SCM_MOST_NEGATIVE_FIXNUM
)) {
3404 /* Negation is a workaround for HP700 cc bug */
3405 SCM ans
= SCM_MAKINUM((long)u
);
3406 if (SCM_INUM(ans
)==(long)u
) return ans
;
3408 SCM_ASRTGO(!IS_INF(u
), badz
); /* problem? */
3409 return scm_dbl2big(u
);
3412 return SCM_MAKINUM((long)floor(SCM_REALPART(z
)+0.5));
3418 #else /* ~SCM_FLOATS */
3419 SCM_PROC(s_trunc
, "truncate", 1, 0, 0, scm_trunc
);
3425 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_truncate
);
3431 #endif /* SCM_FLOATS */
3435 /* d must be integer */
3445 double u
= (d
< 0)?-d
:d
;
3446 while (0 != floor(u
)) {u
/= SCM_BIGRAD
;i
++;}
3447 ans
= scm_mkbig(i
, d
< 0);
3448 digits
= SCM_BDIGITS(ans
);
3457 scm_num_overflow ("dbl2big");
3470 scm_sizet i
= SCM_NUMDIGS(b
);
3471 SCM_BIGDIG
*digits
= SCM_BDIGITS(b
);
3472 while (i
--) ans
= digits
[i
] + SCM_BIGRAD
*ans
;
3473 if (scm_tc16_bigneg
==SCM_TYP16(b
)) return -ans
;
3484 if (!SCM_FIXABLE(sl
)) {
3486 return scm_long2big(sl
);
3489 return scm_makdbl((double) sl
, 0.0);
3495 return SCM_MAKINUM(sl
);
3502 scm_long_long2num(sl
)
3505 if (!SCM_FIXABLE(sl
)) {
3507 return scm_long_long2big(sl
);
3510 return scm_makdbl((double) sl
, 0.0);
3516 return SCM_MAKINUM(sl
);
3526 if (!SCM_POSFIXABLE(sl
)) {
3528 return scm_ulong2big(sl
);
3531 return scm_makdbl((double) sl
, 0.0);
3537 return SCM_MAKINUM(sl
);
3542 scm_num2long(num
, pos
, s_caller
)
3550 res
= SCM_INUM(num
);
3553 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3557 double u
= SCM_REALPART(num
);
3559 if ((double)res
== u
)
3566 if (SCM_BIGP(num
)) {
3571 for(l
= SCM_NUMDIGS(num
);l
--;)
3573 res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
3578 if (SCM_TYP16 (num
) == scm_tc16_bigpos
)
3584 errout
: scm_wta(num
, pos
, s_caller
);
3585 return SCM_UNSPECIFIED
;
3593 num2long(num
, pos
, s_caller
)
3600 res
= SCM_INUM((long)num
);
3603 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3606 double u
= SCM_REALPART(num
);
3607 if (((SCM_MOST_NEGATIVE_FIXNUM
* 4) <= u
)
3608 && (u
<= (SCM_MOST_POSITIVE_FIXNUM
* 4 + 3))) {
3616 scm_sizet l
= SCM_NUMDIGS(num
);
3617 SCM_ASRTGO(SCM_DIGSPERLONG
>= l
, errout
);
3619 for(;l
--;) res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
3623 errout
: scm_wta(num
, pos
, s_caller
);
3624 return SCM_UNSPECIFIED
;
3631 scm_num2long_long(num
, pos
, s_caller
)
3638 res
= SCM_INUM((long_long
)num
);
3641 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3644 double u
= SCM_REALPART(num
);
3645 if (((SCM_MOST_NEGATIVE_FIXNUM
* 4) <= u
)
3646 && (u
<= (SCM_MOST_POSITIVE_FIXNUM
* 4 + 3))) {
3654 scm_sizet l
= SCM_NUMDIGS(num
);
3655 SCM_ASRTGO(SCM_DIGSPERLONGLONG
>= l
, errout
);
3657 for(;l
--;) res
= SCM_LONGLONGBIGUP(res
) + SCM_BDIGITS(num
)[l
];
3661 errout
: scm_wta(num
, pos
, s_caller
);
3662 return SCM_UNSPECIFIED
;
3669 scm_num2ulong(num
, pos
, s_caller
)
3677 res
= SCM_INUM((unsigned long)num
);
3680 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3684 double u
= SCM_REALPART(num
);
3685 if ((0 <= u
) && (u
<= (unsigned long)~0L))
3693 if (SCM_BIGP(num
)) {
3694 unsigned long oldres
;
3698 for(l
= SCM_NUMDIGS(num
);l
--;)
3700 res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
3708 errout
: scm_wta(num
, pos
, s_caller
);
3709 return SCM_UNSPECIFIED
;
3715 static void add1
SCM_P ((double f
, double *fsum
));
3716 static void add1(f
, fsum
)
3730 SCM_NEWCELL(scm_flo0
);
3732 SCM_SETCAR (scm_flo0
, scm_tc_flo
);
3733 SCM_FLO(scm_flo0
) = 0.0;
3735 SCM_SETCDR (scm_flo0
, (SCM
)scm_must_malloc(1L*sizeof(double), "real"));
3736 SCM_REAL(scm_flo0
) = 0.0;
3737 SCM_SETCAR (scm_flo0
, scm_tc_dblr
);
3740 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
3742 { /* determine floating point precision */
3744 double fsum
= 1.0+f
;
3745 while (fsum
!= 1.0) {
3747 if (++scm_dblprec
> 20) break;
3750 scm_dblprec
= scm_dblprec
-1;
3752 # endif /* DBL_DIG */
3754 #include "numbers.x"