1 /* Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
20 * The exception is that, if you link the GUILE library with other files
21 * to produce an executable, this does not by itself cause the
22 * resulting executable to be covered by the GNU General Public License.
23 * Your use of that executable is in no way restricted on account of
24 * linking the GUILE library code into it.
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
29 * This exception applies only to the code released by the
30 * Free Software Foundation under the name GUILE. If you copy
31 * code from other Free Software Foundation releases into a copy of
32 * GUILE, as the General Public License permits, the exception does
33 * not apply to the code that you add in this way. To avoid misleading
34 * anyone as to the status of such modified files, you must delete
35 * this exception notice from them.
37 * If you write modifications of your own for GUILE, it is your choice
38 * whether to permit this exception to apply to your modifications.
39 * 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
);
417 return scm_long2num(scm_num2long(n1
, (char *)SCM_ARG1
, s_logand
)
418 & scm_num2long(n2
, (char *)SCM_ARG2
, s_logand
));
421 SCM_PROC1 (s_logior
, "logior", scm_tc7_asubr
, scm_logior
);
428 return scm_long2num(scm_num2long(n1
, (char *)SCM_ARG1
, s_logior
)
429 | scm_num2long(n2
, (char *)SCM_ARG2
, s_logior
));
432 SCM_PROC1 (s_logxor
, "logxor", scm_tc7_asubr
, scm_logxor
);
439 return scm_long2num(scm_num2long(n1
, (char *)SCM_ARG1
, s_logxor
)
440 ^ scm_num2long(n2
, (char *)SCM_ARG2
, s_logxor
));
443 SCM_PROC(s_logtest
, "logtest", 2, 0, 0, scm_logtest
);
450 return ((scm_num2long (n1
, (char *)SCM_ARG1
, s_logtest
)
451 & scm_num2long (n2
, (char *)SCM_ARG2
, s_logtest
))
452 ? SCM_BOOL_T
: SCM_BOOL_F
);
456 SCM_PROC(s_logbit_p
, "logbit?", 2, 0, 0, scm_logbit_p
);
463 return (((1 << scm_num2long (n1
, (char *)SCM_ARG1
, s_logtest
))
464 & scm_num2long (n2
, (char *)SCM_ARG2
, s_logtest
))
465 ? SCM_BOOL_T
: SCM_BOOL_F
);
470 SCM_PROC1 (s_logand
, "logand", scm_tc7_asubr
, scm_logand
);
477 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logand
);
478 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logand
);
479 return SCM_MAKINUM(SCM_INUM(n1
) & SCM_INUM(n2
));
482 SCM_PROC1 (s_logior
, "logior", scm_tc7_asubr
, scm_logior
);
489 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logior
);
490 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logior
);
491 return SCM_MAKINUM(SCM_INUM(n1
) | SCM_INUM(n2
));
494 SCM_PROC1 (s_logxor
, "logxor", scm_tc7_asubr
, scm_logxor
);
501 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logxor
);
502 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logxor
);
503 return SCM_MAKINUM(SCM_INUM(n1
) ^ SCM_INUM(n2
));
506 SCM_PROC(s_logtest
, "logtest", 2, 0, 0, scm_logtest
);
513 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logtest
);
514 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logtest
);
515 return (SCM_INUM(n1
) & SCM_INUM(n2
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
518 SCM_PROC(s_logbit_p
, "logbit?", 2, 0, 0, scm_logbit_p
);
525 SCM_ASSERT(SCM_INUMP(n1
) && SCM_INUM(n1
) >= 0, n1
, SCM_ARG1
, s_logbit_p
);
526 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logbit_p
);
527 return ((1 << SCM_INUM(n1
)) & SCM_INUM(n2
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
531 SCM_PROC(s_lognot
, "lognot", 1, 0, 0, scm_lognot
);
537 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_lognot
);
538 return scm_difference(SCM_MAKINUM(-1L), n
);
541 SCM_PROC(s_integer_expt
, "integer-expt", 2, 0, 0, scm_integer_expt
);
544 scm_integer_expt(z1
, z2
)
548 SCM acc
= SCM_MAKINUM(1L);
550 if (SCM_INUM0
==z1
|| acc
==z1
) return z1
;
551 else if (SCM_MAKINUM(-1L)==z1
) return SCM_BOOL_F
==scm_even_p(z2
)?z1
:acc
;
553 SCM_ASSERT(SCM_INUMP(z2
), z2
, SCM_ARG2
, s_integer_expt
);
557 z1
= scm_divide(z1
, SCM_UNDEFINED
);
560 if (0==z2
) return acc
;
561 if (1==z2
) return scm_product(acc
, z1
);
562 if (z2
& 1) acc
= scm_product(acc
, z1
);
563 z1
= scm_product(z1
, z1
);
568 SCM_PROC(s_ash
, "ash", 2, 0, 0, scm_ash
);
575 SCM res
= SCM_INUM(n
);
576 SCM_ASSERT(SCM_INUMP(cnt
), cnt
, SCM_ARG2
, s_ash
);
579 res
= scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(-SCM_INUM(cnt
)));
580 if (SCM_NFALSEP(scm_negative_p(n
)))
581 return scm_sum(SCM_MAKINUM(-1L), scm_quotient(scm_sum(SCM_MAKINUM(1L), n
), res
));
582 else return scm_quotient(n
, res
);
584 else return scm_product(n
, scm_integer_expt(SCM_MAKINUM(2), cnt
));
586 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_ash
);
588 if (cnt
< 0) return SCM_MAKINUM(SCM_SRS(res
, -cnt
));
589 res
= SCM_MAKINUM(res
<<cnt
);
590 if (SCM_INUM(res
)>>cnt
!= SCM_INUM(n
))
591 scm_num_overflow (s_ash
);
596 SCM_PROC(s_bit_extract
, "bit-extract", 3, 0, 0, scm_bit_extract
);
599 scm_bit_extract(n
, start
, end
)
604 SCM_ASSERT(SCM_INUMP(start
), start
, SCM_ARG2
, s_bit_extract
);
605 SCM_ASSERT(SCM_INUMP(end
), end
, SCM_ARG3
, s_bit_extract
);
606 start
= SCM_INUM(start
); end
= SCM_INUM(end
);
607 SCM_ASSERT(end
>= start
, SCM_MAKINUM(end
), SCM_OUTOFRANGE
, s_bit_extract
);
611 scm_logand(scm_difference(scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(end
- start
)),
613 scm_ash(n
, SCM_MAKINUM(-start
)));
615 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_bit_extract
);
617 return SCM_MAKINUM((SCM_INUM(n
)>>start
) & ((1L<<(end
-start
))-1));
620 char scm_logtab
[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
621 SCM_PROC(s_logcount
, "logcount", 1, 0, 0, scm_logcount
);
627 register unsigned long c
= 0;
631 scm_sizet i
; SCM_BIGDIG
*ds
, d
;
632 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_logcount
);
633 if SCM_BIGSIGN(n
) return scm_logcount(scm_difference(SCM_MAKINUM(-1L), n
));
635 for(i
= SCM_NUMDIGS(n
); i
--; )
636 for(d
= ds
[i
]; d
; d
>>= 4) c
+= scm_logtab
[15 & d
];
637 return SCM_MAKINUM(c
);
640 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_logcount
);
642 if ((nn
= SCM_INUM(n
)) < 0) nn
= -1 - nn
;
643 for(; nn
; nn
>>= 4) c
+= scm_logtab
[15 & nn
];
644 return SCM_MAKINUM(c
);
647 char scm_ilentab
[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4};
648 SCM_PROC(s_integer_length
, "integer-length", 1, 0, 0, scm_integer_length
);
651 scm_integer_length(n
)
654 register unsigned long c
= 0;
660 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_integer_length
);
661 if SCM_BIGSIGN(n
) return scm_integer_length(scm_difference(SCM_MAKINUM(-1L), n
));
663 d
= ds
[c
= SCM_NUMDIGS(n
)-1];
664 for(c
*= SCM_BITSPERDIG
; d
; d
>>= 4) {c
+= 4; l
= scm_ilentab
[15 & d
];}
665 return SCM_MAKINUM(c
- 4 + l
);
668 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_integer_length
);
670 if ((nn
= SCM_INUM(n
)) < 0) nn
= -1 - nn
;
671 for(;nn
; nn
>>= 4) {c
+= 4; l
= scm_ilentab
[15 & nn
];}
672 return SCM_MAKINUM(c
- 4 + l
);
677 char s_bignum
[] = "bignum";
680 scm_mkbig(nlen
, sign
)
685 if (((v
<< 16) >> 16) != nlen
)
686 scm_wta(SCM_MAKINUM(nlen
), (char *)SCM_NALLOC
, s_bignum
);
689 SCM_SETCHARS(v
, scm_must_malloc((long)(nlen
*sizeof(SCM_BIGDIG
)), s_bignum
));
690 SCM_SETNUMDIGS(v
, nlen
, sign
?scm_tc16_bigneg
:scm_tc16_bigpos
);
701 unsigned long num
= 0;
702 SCM_BIGDIG
*tmp
= SCM_BDIGITS(b
);
703 while (l
--) num
= SCM_BIGUP(num
) + tmp
[l
];
704 if (SCM_TYP16(b
)==scm_tc16_bigpos
) {
705 if SCM_POSFIXABLE(num
) return SCM_MAKINUM(num
);
707 else if SCM_UNEGFIXABLE(num
) return SCM_MAKINUM(-num
);
712 char s_adjbig
[] = "scm_adjbig";
720 if (((nsiz
<< 16) >> 16) != nlen
) scm_wta(SCM_MAKINUM(nsiz
), (char *)SCM_NALLOC
, s_adjbig
);
722 SCM_SETCHARS(b
, (SCM_BIGDIG
*)scm_must_realloc((char *)SCM_CHARS(b
),
723 (long)(SCM_NUMDIGS(b
)*sizeof(SCM_BIGDIG
)),
724 (long)(nsiz
*sizeof(SCM_BIGDIG
)), s_adjbig
));
725 SCM_SETNUMDIGS(b
, nsiz
, SCM_TYP16(b
));
737 scm_sizet nlen
= SCM_NUMDIGS(b
);
739 int nlen
= SCM_NUMDIGS(b
); /* unsigned nlen breaks on Cray when nlen => 0 */
741 SCM_BIGDIG
*zds
= SCM_BDIGITS(b
);
742 while (nlen
-- && !zds
[nlen
]); nlen
++;
743 if (nlen
* SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
))
744 if SCM_INUMP(b
= scm_big2inum(b
, (scm_sizet
)nlen
)) return b
;
745 if (SCM_NUMDIGS(b
)==nlen
) return b
;
746 return scm_adjbig(b
, (scm_sizet
)nlen
);
756 scm_sizet i
= SCM_NUMDIGS(b
);
757 SCM ans
= scm_mkbig(i
, sign
);
758 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
759 while (i
--) dst
[i
] = src
[i
];
771 SCM ans
= scm_mkbig(SCM_DIGSPERLONG
, n
<0);
772 digits
= SCM_BDIGITS(ans
);
774 while (i
< SCM_DIGSPERLONG
) {
775 digits
[i
++] = SCM_BIGLO(n
);
776 n
= SCM_BIGDN((unsigned long)n
);
795 if ((long long)tn
== n
)
796 return scm_long2big (tn
);
802 for (tn
= n
, n_digits
= 0;
804 ++n_digits
, tn
= SCM_BIGDN ((ulong_long
)tn
))
809 ans
= scm_mkbig(n_digits
, n
<0);
810 digits
= SCM_BDIGITS(ans
);
813 while (i
< n_digits
) {
814 digits
[i
++] = SCM_BIGLO(n
);
815 n
= SCM_BIGDN((ulong_long
)n
);
831 ans
= scm_mkbig(2 * SCM_DIGSPERLONG
, 0);
832 digits
= SCM_BDIGITS(ans
);
835 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
837 digits
[i
] = SCM_BIGLO(n
);
838 n
= SCM_BIGDN((unsigned long)n
);
841 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
843 digits
[i
+ SCM_DIGSPERLONG
] = SCM_BIGLO(n
);
844 n
= SCM_BIGDN((unsigned long)n
);
857 SCM ans
= scm_mkbig(SCM_DIGSPERLONG
, 0);
858 digits
= SCM_BDIGITS(ans
);
859 while (i
< SCM_DIGSPERLONG
) {
860 digits
[i
++] = SCM_BIGLO(n
);
873 int xsign
= SCM_BIGSIGN(x
);
874 int ysign
= SCM_BIGSIGN(y
);
875 scm_sizet xlen
, ylen
;
876 if (ysign
< xsign
) return 1;
877 if (ysign
> xsign
) return -1;
878 if ((ylen
= SCM_NUMDIGS(y
)) > (xlen
= SCM_NUMDIGS(x
))) return (xsign
) ? -1 : 1;
879 if (ylen
< xlen
) return (xsign
) ? 1 : -1;
880 while(xlen
-- && (SCM_BDIGITS(y
)[xlen
]==SCM_BDIGITS(x
)[xlen
]));
881 if (-1==xlen
) return 0;
882 return (SCM_BDIGITS(y
)[xlen
] > SCM_BDIGITS(x
)[xlen
]) ?
883 (xsign
? -1 : 1) : (xsign
? 1 : -1);
886 #ifndef SCM_DIGSTOOBIG
895 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
899 while (i
< SCM_DIGSPERLONG
) {p
.bd
[i
++] = SCM_BIGLO(x
); x
= SCM_BIGDN(x
);}
900 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
908 scm_longdigs(x
, digs
)
914 while (i
< SCM_DIGSPERLONG
) {digs
[i
++] = SCM_BIGLO(x
); x
= SCM_BIGDN(x
);}
921 scm_addbig(x
, nx
, xsgn
, bigy
, sgny
)
928 /* Assumes nx <= SCM_NUMDIGS(bigy) */
929 /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */
931 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
932 SCM z
= scm_copybig(bigy
, SCM_BIGSIGN(bigy
) ^ sgny
);
933 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
934 if (xsgn
^ SCM_BIGSIGN(z
)) {
936 num
+= (long) zds
[i
] - x
[i
];
937 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
938 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
942 SCM_SETCAR (z
, SCM_CAR (z
) ^ 0x0100);
944 num
+= (SCM_BIGRAD
-1) - zds
[i
];
945 zds
[i
++] = SCM_BIGLO(num
);
946 num
= SCM_BIGDN(num
);
949 else while (i
< ny
) {
951 if (num
< 0) {zds
[i
++] = num
+ SCM_BIGRAD
; num
= -1;}
952 else {zds
[i
++] = SCM_BIGLO(num
); num
= 0;}
956 num
+= (long) zds
[i
] + x
[i
];
957 zds
[i
++] = SCM_BIGLO(num
);
958 num
= SCM_BIGDN(num
);
963 zds
[i
++] = SCM_BIGLO(num
);
964 num
= SCM_BIGDN(num
);
967 if (num
) {z
= scm_adjbig(z
, ny
+1); SCM_BDIGITS(z
)[ny
] = num
; return z
;}
969 return scm_normbig(z
);
974 scm_mulbig(x
, nx
, y
, ny
, sgn
)
981 scm_sizet i
= 0, j
= nx
+ ny
;
983 SCM z
= scm_mkbig(j
, sgn
);
984 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
985 while (j
--) zds
[j
] = 0;
990 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
991 zds
[i
+ j
++] = SCM_BIGLO(n
);
994 if (n
) {zds
[i
+ j
] = n
; n
= 0;}
997 return scm_normbig(z
);
1002 scm_divbigdig(ds
, h
, div
)
1007 register unsigned long t2
= 0;
1009 t2
= SCM_BIGUP(t2
) + ds
[h
];
1019 scm_divbigint(x
, z
, sgn
, mode
)
1026 if (z
< SCM_BIGRAD
) {
1027 register unsigned long t2
= 0;
1028 register SCM_BIGDIG
*ds
= SCM_BDIGITS(x
);
1029 scm_sizet nd
= SCM_NUMDIGS(x
);
1030 while(nd
--) t2
= (SCM_BIGUP(t2
) + ds
[nd
]) % z
;
1031 if (mode
&& t2
) t2
= z
- t2
;
1032 return SCM_MAKINUM(sgn
? -t2
: t2
);
1035 #ifndef SCM_DIGSTOOBIG
1036 unsigned long t2
= scm_pseudolong(z
);
1037 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), (SCM_BIGDIG
*)&t2
,
1038 SCM_DIGSPERLONG
, sgn
, mode
);
1040 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1041 scm_longdigs(z
, t2
);
1042 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), t2
, SCM_DIGSPERLONG
, sgn
, mode
);
1049 scm_divbigbig(x
, nx
, y
, ny
, sgn
, modes
)
1057 /* modes description
1061 3 quotient but returns 0 if division is not exact. */
1062 scm_sizet i
= 0, j
= 0;
1064 unsigned long t2
= 0;
1066 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1067 /* algorithm requires nx >= ny */
1070 case 0: /* remainder -- just return x */
1071 z
= scm_mkbig(nx
, sgn
); zds
= SCM_BDIGITS(z
);
1072 do {zds
[i
] = x
[i
];} while (++i
< nx
);
1074 case 1: /* scm_modulo -- return y-x */
1075 z
= scm_mkbig(ny
, sgn
); zds
= SCM_BDIGITS(z
);
1077 num
+= (long) y
[i
] - x
[i
];
1078 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
1079 else {zds
[i
] = num
; num
= 0;}
1083 if (num
< 0) {zds
[i
++] = num
+ SCM_BIGRAD
; num
= -1;}
1084 else {zds
[i
++] = num
; num
= 0;}
1087 case 2: return SCM_INUM0
; /* quotient is zero */
1088 case 3: return 0; /* the division is not exact */
1091 z
= scm_mkbig(nx
==ny
? nx
+2 : nx
+1, sgn
); zds
= SCM_BDIGITS(z
);
1092 if (nx
==ny
) zds
[nx
+1] = 0;
1093 while(!y
[ny
-1]) ny
--; /* in case y came in as a psuedolong */
1094 if (y
[ny
-1] < (SCM_BIGRAD
>>1)) { /* normalize operands */
1095 d
= SCM_BIGRAD
/(y
[ny
-1]+1);
1096 newy
= scm_mkbig(ny
, 0); yds
= SCM_BDIGITS(newy
);
1098 {t2
+= (unsigned long) y
[j
]*d
; yds
[j
++] = SCM_BIGLO(t2
); t2
= SCM_BIGDN(t2
);}
1099 y
= yds
; j
= 0; t2
= 0;
1101 {t2
+= (unsigned long) x
[j
]*d
; zds
[j
++] = SCM_BIGLO(t2
); t2
= SCM_BIGDN(t2
);}
1104 else {zds
[j
= nx
] = 0; while (j
--) zds
[j
] = x
[j
];}
1105 j
= nx
==ny
? nx
+1 : nx
; /* dividend needs more digits than divisor */
1106 do { /* loop over digits of quotient */
1107 if (zds
[j
]==y
[ny
-1]) qhat
= SCM_BIGRAD
-1;
1108 else qhat
= (SCM_BIGUP(zds
[j
]) + zds
[j
-1])/y
[ny
-1];
1109 if (!qhat
) continue;
1110 i
= 0; num
= 0; t2
= 0;
1111 do { /* multiply and subtract */
1112 t2
+= (unsigned long) y
[i
] * qhat
;
1113 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO(t2
);
1114 if (num
< 0) {zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
; num
= -1;}
1115 else {zds
[j
- ny
+ i
] = num
; num
= 0;}
1118 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1119 while (num
) { /* "add back" required */
1120 i
= 0; num
= 0; qhat
--;
1122 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1123 zds
[j
- ny
+ i
] = SCM_BIGLO(num
);
1124 num
= SCM_BIGDN(num
);
1128 if (modes
& 2) zds
[j
] = qhat
;
1129 } while (--j
>= ny
);
1131 case 3: /* check that remainder==0 */
1132 for(j
= ny
;j
&& !zds
[j
-1];--j
) ; if (j
) return 0;
1133 case 2: /* move quotient down in z */
1134 j
= (nx
==ny
? nx
+2 : nx
+1) - ny
;
1135 for (i
= 0;i
< j
;i
++) zds
[i
] = zds
[i
+ny
];
1138 case 1: /* subtract for scm_modulo */
1139 i
= 0; num
= 0; j
= 0;
1140 do {num
+= y
[i
] - zds
[i
];
1142 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
1143 else {zds
[i
] = num
; num
= 0;}
1145 if (!j
) return SCM_INUM0
;
1146 case 0: /* just normalize remainder */
1147 if (d
) scm_divbigdig(zds
, ny
, d
);
1150 for(j
= ny
;j
&& !zds
[j
-1];--j
) ;
1151 if (j
* SCM_BITSPERDIG
<= sizeof(SCM
)*SCM_CHAR_BIT
)
1152 if SCM_INUMP(z
= scm_big2inum(z
, j
)) return z
;
1153 return scm_adjbig(z
, j
);
1161 /*** NUMBERS -> STRINGS ***/
1164 static double fx
[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1165 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1166 5e-11,5e-12,5e-13,5e-14,5e-15,
1167 5e-16,5e-17,5e-18,5e-19,5e-20};
1172 static scm_sizet idbl2str
SCM_P ((double f
, char *a
));
1179 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1183 if (f
== 0.0) goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
1184 if (f
< 0.0) {f
= -f
;a
[ch
++]='-';}
1189 if (ch
== 0) a
[ch
++]='+';
1190 funny
: a
[ch
++]='#'; a
[ch
++]='.'; a
[ch
++]='#'; return ch
;
1192 # ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1193 make-uniform-vector, from causing infinite loops. */
1194 while (f
< 1.0) {f
*= 10.0; if (exp
-- < DBL_MIN_10_EXP
) goto funny
;}
1195 while (f
> 10.0) {f
*= 0.10; if (exp
++ > DBL_MAX_10_EXP
) goto funny
;}
1197 while (f
< 1.0) {f
*= 10.0; exp
--;}
1198 while (f
> 10.0) {f
/= 10.0; exp
++;}
1200 if (f
+fx
[wp
] >= 10.0) {f
= 1.0; exp
++;}
1207 efmt
= (exp
< -3) || (exp
> wp
+2);
1213 while (++dpt
) a
[ch
++] = '0';
1224 if (f
< fx
[wp
]) break;
1225 if (f
+fx
[wp
] >= 1.0) {
1230 if (!(--dpt
)) a
[ch
++] = '.';
1235 if ((dpt
> 4) && (exp
> 6)) {
1236 d
= (a
[0]=='-'?2:1);
1237 for (i
= ch
++; i
> d
; i
--)
1244 while (--dpt
) a
[ch
++] = '0';
1247 if (a
[ch
-1]=='.') a
[ch
++]='0'; /* trailing zero */
1254 for (i
= 10; i
<= exp
; i
*= 10);
1255 for (i
/= 10; i
; i
/= 10) {
1256 a
[ch
++] = exp
/i
+ '0';
1264 static scm_sizet iflo2str
SCM_P ((SCM flt
, char *str
));
1273 if SCM_SINGP(flt
) i
= idbl2str(SCM_FLO(flt
), str
);
1276 i
= idbl2str(SCM_REAL(flt
), str
);
1278 if(0 <= SCM_IMAG(flt
)) /* jeh */
1279 str
[i
++] = '+'; /* jeh */
1280 i
+= idbl2str(SCM_IMAG(flt
), &str
[i
]);
1285 #endif /* SCM_FLOATS */
1289 scm_iint2str(num
, rad
, p
)
1295 register int i
= 1, d
;
1296 register long n
= num
;
1297 if (n
< 0) {n
= -n
; i
++;}
1298 for (n
/= rad
;n
> 0;n
/= rad
) i
++;
1301 if (n
< 0) {n
= -n
; *p
++ = '-'; i
--;}
1305 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
1313 static SCM big2str
SCM_P ((SCM b
, register unsigned int radix
));
1318 register unsigned int radix
;
1320 SCM t
= scm_copybig(b
, 0); /* sign of temp doesn't matter */
1321 register SCM_BIGDIG
*ds
= SCM_BDIGITS(t
);
1322 scm_sizet i
= SCM_NUMDIGS(t
);
1323 scm_sizet j
= radix
==16 ? (SCM_BITSPERDIG
*i
)/4+2
1324 : radix
>= 10 ? (SCM_BITSPERDIG
*i
*241L)/800+2
1325 : (SCM_BITSPERDIG
*i
)+2;
1327 scm_sizet radct
= 0;
1328 scm_sizet ch
; /* jeh */
1329 SCM_BIGDIG radpow
= 1, radmod
= 0;
1330 SCM ss
= scm_makstr((long)j
, 0);
1331 char *s
= SCM_CHARS(ss
), c
;
1332 while ((long) radpow
* radix
< SCM_BIGRAD
) {
1336 s
[0] = scm_tc16_bigneg
==SCM_TYP16(b
) ? '-' : '+';
1337 while ((i
|| radmod
) && j
) {
1339 radmod
= (SCM_BIGDIG
)scm_divbigdig(ds
, i
, radpow
);
1343 c
= radmod
% radix
; radmod
/= radix
; k
--;
1344 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
1346 ch
= s
[0] == '-' ? 1 : 0; /* jeh */
1347 if (ch
< j
) { /* jeh */
1348 for(i
= j
;j
< SCM_LENGTH(ss
);j
++) s
[ch
+j
-i
] = s
[j
]; /* jeh */
1349 scm_vector_set_length_x(ss
, (SCM
)SCM_MAKINUM(ch
+SCM_LENGTH(ss
)-i
)); /* jeh */
1356 SCM_PROC(s_number_to_string
, "number->string", 1, 1, 0, scm_number_to_string
);
1359 scm_number_to_string(x
, radix
)
1363 if SCM_UNBNDP(radix
) radix
=SCM_MAKINUM(10L);
1364 else SCM_ASSERT(SCM_INUMP(radix
), radix
, SCM_ARG2
, s_number_to_string
);
1367 char num_buf
[SCM_FLOBUFLEN
];
1369 SCM_ASRTGO(SCM_NIMP(x
), badx
);
1370 if SCM_BIGP(x
) return big2str(x
, (unsigned int)SCM_INUM(radix
));
1372 if (!(SCM_INEXP(x
)))
1373 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_number_to_string
);
1376 SCM_ASSERT(SCM_NIMP(x
) && SCM_INEXP(x
), x
, SCM_ARG1
, s_number_to_string
);
1378 return scm_makfromstr(num_buf
, iflo2str(x
, num_buf
), 0);
1383 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_number_to_string
);
1384 return big2str(x
, (unsigned int)SCM_INUM(radix
));
1387 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_number_to_string
);
1391 char num_buf
[SCM_INTBUFLEN
];
1392 return scm_makfromstr(num_buf
,
1393 scm_iint2str(SCM_INUM(x
), (int)SCM_INUM(radix
), num_buf
), 0);
1398 /* These print routines are stubbed here so that scm_repl.c doesn't need
1399 SCM_FLOATS or SCM_BIGDIGs conditionals */
1402 scm_floprint(sexp
, port
, pstate
)
1405 scm_print_state
*pstate
;
1408 char num_buf
[SCM_FLOBUFLEN
];
1409 scm_gen_write (scm_regular_string
, num_buf
, iflo2str(sexp
, num_buf
), port
);
1411 scm_ipruk("float", sexp
, port
);
1419 scm_bigprint(exp
, port
, pstate
)
1422 scm_print_state
*pstate
;
1425 exp
= big2str(exp
, (unsigned int)10);
1426 scm_gen_write (scm_regular_string
, SCM_CHARS(exp
), (scm_sizet
)SCM_LENGTH(exp
), port
);
1428 scm_ipruk("bignum", exp
, port
);
1432 /*** END nums->strs ***/
1434 /*** STRINGS -> NUMBERS ***/
1436 static SCM scm_small_istr2int
SCM_P ((char *str
, long len
, long radix
));
1439 scm_small_istr2int(str
, len
, radix
)
1444 register long n
= 0, ln
;
1448 if (0 >= len
) return SCM_BOOL_F
; /* zero scm_length */
1449 switch (*str
) { /* leading sign */
1450 case '-': lead_neg
= 1;
1451 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1455 switch (c
= str
[i
++]) {
1459 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1462 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1465 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1468 /* Negation is a workaround for HP700 cc bug */
1469 if (n
> ln
|| (-n
> -SCM_MOST_NEGATIVE_FIXNUM
)) goto ovfl
;
1472 return SCM_BOOL_F
; /* not a digit */
1475 if (!lead_neg
) if ((n
= -n
) > SCM_MOST_POSITIVE_FIXNUM
) goto ovfl
;
1476 return SCM_MAKINUM(n
);
1477 ovfl
: /* overflow scheme integer */
1484 scm_istr2int(str
, len
, radix
)
1490 register scm_sizet k
, blen
= 1;
1494 register SCM_BIGDIG
*ds
;
1495 register unsigned long t2
;
1497 if (0 >= len
) return SCM_BOOL_F
; /* zero scm_length */
1499 /* Short numbers we parse directly into an int, to avoid the overhead
1500 of creating a bignum. */
1502 return scm_small_istr2int (str
, len
, radix
);
1504 if (16==radix
) j
= 1+(4*len
*sizeof(char))/(SCM_BITSPERDIG
);
1505 else if (10 <= radix
)
1506 j
= 1+(84*len
*sizeof(char))/(SCM_BITSPERDIG
*25);
1507 else j
= 1+(len
*sizeof(char))/(SCM_BITSPERDIG
);
1508 switch (str
[0]) { /* leading sign */
1510 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1512 res
= scm_mkbig(j
, '-'==str
[0]);
1513 ds
= SCM_BDIGITS(res
);
1514 for (k
= j
;k
--;) ds
[k
] = 0;
1516 switch (c
= str
[i
++]) {
1520 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1523 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1526 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1531 /* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/
1533 ds
[k
++] = SCM_BIGLO(t2
);
1537 scm_num_overflow ("bignum");
1538 if (t2
) {blen
++; goto moretodo
;}
1541 return SCM_BOOL_F
; /* not a digit */
1544 if (blen
* SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
))
1545 if SCM_INUMP(res
= scm_big2inum(res
, blen
)) return res
;
1546 if (j
==blen
) return res
;
1547 return scm_adjbig(res
, blen
);
1553 scm_istr2flo(str
, len
, radix
)
1558 register int c
, i
= 0;
1560 double res
= 0.0, tmp
= 0.0;
1565 if (i
>= len
) return SCM_BOOL_F
; /* zero scm_length */
1567 switch (*str
) { /* leading sign */
1568 case '-': lead_sgn
= -1.0; i
++; break;
1569 case '+': lead_sgn
= 1.0; i
++; break;
1570 default : lead_sgn
= 0.0;
1572 if (i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1574 if (str
[i
]=='i' || str
[i
]=='I') { /* handle `+i' and `-i' */
1575 if (lead_sgn
==0.0) return SCM_BOOL_F
; /* must have leading sign */
1576 if (++i
< len
) return SCM_BOOL_F
; /* `i' not last character */
1577 return scm_makdbl(0.0, lead_sgn
);
1579 do { /* check initial digits */
1580 switch (c
= str
[i
]) {
1584 case 'D': case 'E': case 'F':
1585 if (radix
==10) goto out1
; /* must be exponent */
1586 case 'A': case 'B': case 'C':
1589 case 'd': case 'e': case 'f':
1590 if (radix
==10) goto out1
;
1591 case 'a': case 'b': case 'c':
1594 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1595 res
= res
* radix
+ c
;
1596 flg
= 1; /* res is valid */
1601 } while (++i
< len
);
1604 /* if true, then we did see a digit above, and res is valid */
1605 if (i
==len
) goto done
;
1607 /* By here, must have seen a digit,
1608 or must have next char be a `.' with radix==10 */
1610 if (!(str
[i
]=='.' && radix
==10))
1613 while (str
[i
]=='#') { /* optional sharps */
1615 if (++i
==len
) goto done
;
1620 switch (c
= str
[i
]) {
1624 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1627 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1630 if (c
>= radix
) return SCM_BOOL_F
;
1631 tmp
= tmp
* radix
+ c
;
1638 if (tmp
==0.0) return SCM_BOOL_F
; /* `slash zero' not allowed */
1640 while (str
[i
]=='#') { /* optional sharps */
1642 if (++i
==len
) break;
1648 if (str
[i
]=='.') { /* decimal point notation */
1649 if (radix
!= 10) return SCM_BOOL_F
; /* must be radix 10 */
1651 switch (c
= str
[i
]) {
1654 res
= res
*10.0 + c
-'0';
1662 if (!flg
) return SCM_BOOL_F
; /* no digits before or after decimal point */
1663 if (i
==len
) goto adjust
;
1664 while (str
[i
]=='#') { /* ignore remaining sharps */
1665 if (++i
==len
) goto adjust
;
1669 switch (str
[i
]) { /* exponent */
1674 case 's': case 'S': {
1675 int expsgn
= 1, expon
= 0;
1676 if (radix
!= 10) return SCM_BOOL_F
; /* only in radix 10 */
1677 if (++i
==len
) return SCM_BOOL_F
; /* bad exponent */
1679 case '-': expsgn
=(-1);
1680 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad exponent */
1682 if (str
[i
] < '0' || str
[i
] > '9') return SCM_BOOL_F
; /* bad exponent */
1684 switch (c
= str
[i
]) {
1686 expon
= expon
*10 + c
-'0';
1687 if (expon
> MAXEXP
) return SCM_BOOL_F
; /* exponent too large */
1692 } while (++i
< len
);
1694 point
+= expsgn
*expon
;
1700 while (point
--) res
*= 10.0;
1703 while (point
++) res
*= 0.1;
1705 while (point
++) res
/= 10.0;
1709 /* at this point, we have a legitimate floating point result */
1710 if (lead_sgn
==-1.0) res
= -res
;
1711 if (i
==len
) return scm_makdbl(res
, 0.0);
1713 if (str
[i
]=='i' || str
[i
]=='I') { /* pure imaginary number */
1714 if (lead_sgn
==0.0) return SCM_BOOL_F
; /* must have leading sign */
1715 if (++i
< len
) return SCM_BOOL_F
; /* `i' not last character */
1716 return scm_makdbl(0.0, res
);
1720 case '-': lead_sgn
= -1.0; break;
1721 case '+': lead_sgn
= 1.0; break;
1722 case '@': { /* polar input for complex number */
1723 /* get a `real' for scm_angle */
1724 second
= scm_istr2flo(&str
[i
], (long)(len
-i
), radix
);
1725 if (!(SCM_INEXP(second
))) return SCM_BOOL_F
; /* not `real' */
1726 if (SCM_CPLXP(second
)) return SCM_BOOL_F
; /* not `real' */
1727 tmp
= SCM_REALPART(second
);
1728 return scm_makdbl(res
*cos(tmp
), res
*sin(tmp
));
1730 default: return SCM_BOOL_F
;
1733 /* at this point, last char must be `i' */
1734 if (str
[len
-1] != 'i' && str
[len
-1] != 'I') return SCM_BOOL_F
;
1735 /* handles `x+i' and `x-i' */
1736 if (i
==(len
-1)) return scm_makdbl(res
, lead_sgn
);
1737 /* get a `ureal' for complex part */
1738 second
= scm_istr2flo(&str
[i
], (long)((len
-i
)-1), radix
);
1739 if (!(SCM_INEXP(second
))) return SCM_BOOL_F
; /* not `ureal' */
1740 if (SCM_CPLXP(second
)) return SCM_BOOL_F
; /* not `ureal' */
1741 tmp
= SCM_REALPART(second
);
1742 if (tmp
< 0.0) return SCM_BOOL_F
; /* not `ureal' */
1743 return scm_makdbl(res
, (lead_sgn
*tmp
));
1745 #endif /* SCM_FLOATS */
1750 scm_istring2number(str
, len
, radix
)
1757 char ex_p
= 0, rx_p
= 0; /* Only allow 1 exactness and 1 radix prefix */
1760 if (*str
=='+' || *str
=='-') /* Catches lone `+' and `-' for speed */
1763 while ((len
-i
) >= 2 && str
[i
]=='#' && ++i
)
1765 case 'b': case 'B': if (rx_p
++) return SCM_BOOL_F
; radix
= 2; break;
1766 case 'o': case 'O': if (rx_p
++) return SCM_BOOL_F
; radix
= 8; break;
1767 case 'd': case 'D': if (rx_p
++) return SCM_BOOL_F
; radix
= 10; break;
1768 case 'x': case 'X': if (rx_p
++) return SCM_BOOL_F
; radix
= 16; break;
1769 case 'i': case 'I': if (ex_p
++) return SCM_BOOL_F
; ex
= 2; break;
1770 case 'e': case 'E': if (ex_p
++) return SCM_BOOL_F
; ex
= 1; break;
1771 default: return SCM_BOOL_F
;
1776 return scm_istr2int(&str
[i
], len
-i
, radix
);
1778 res
= scm_istr2int(&str
[i
], len
-i
, radix
);
1779 if SCM_NFALSEP(res
) return res
;
1781 case 2: return scm_istr2flo(&str
[i
], len
-i
, radix
);
1788 SCM_PROC(s_string_to_number
, "string->number", 1, 1, 0, scm_string_to_number
);
1791 scm_string_to_number(str
, radix
)
1796 if SCM_UNBNDP(radix
) radix
=SCM_MAKINUM(10L);
1797 else SCM_ASSERT(SCM_INUMP(radix
), radix
, SCM_ARG2
, s_string_to_number
);
1798 SCM_ASSERT(SCM_NIMP(str
) && SCM_ROSTRINGP(str
), str
, SCM_ARG1
, s_string_to_number
);
1799 answer
= scm_istring2number(SCM_ROCHARS(str
), SCM_ROLENGTH(str
), SCM_INUM(radix
));
1800 return scm_return_first (answer
, str
);
1802 /*** END strs->nums ***/
1812 if ((y
==0.0) && (x
==0.0)) return scm_flo0
;
1818 # ifndef SCM_SINGLESONLY
1819 if ((-FLTMAX
< x
) && (x
< FLTMAX
) && (fx
==x
))
1822 SCM_SETCAR (z
, scm_tc_flo
);
1827 # endif/* def SCM_SINGLES */
1828 SCM_SETCDR (z
, (SCM
)scm_must_malloc(1L*sizeof(double), "real"));
1829 SCM_SETCAR (z
, scm_tc_dblr
);
1832 SCM_SETCDR (z
, (SCM
)scm_must_malloc(2L*sizeof(double), "complex"));
1833 SCM_SETCAR (z
, scm_tc_dblc
);
1850 if (0==scm_bigcomp(x
, y
)) return SCM_BOOL_T
;
1863 if (SCM_REALPART(x
) != SCM_REALPART(y
)) return SCM_BOOL_F
;
1864 if (!(SCM_CPLXP(x
) && (SCM_IMAG(x
) != SCM_IMAG(y
)))) return SCM_BOOL_T
;
1872 SCM_PROC(s_number_p
, "number?", 1, 0, 0, scm_number_p
);
1873 SCM_PROC(s_complex_p
, "complex?", 1, 0, 0, scm_number_p
);
1879 if SCM_INUMP(x
) return SCM_BOOL_T
;
1881 if (SCM_NIMP(x
) && SCM_NUMP(x
)) return SCM_BOOL_T
;
1884 if (SCM_NIMP(x
) && SCM_NUMP(x
)) return SCM_BOOL_T
;
1893 SCM_PROC(s_real_p
, "real?", 1, 0, 0, scm_real_p
);
1894 SCM_PROC(s_rational_p
, "rational?", 1, 0, 0, scm_real_p
);
1915 SCM_PROC(s_int_p
, "integer?", 1, 0, 0, scm_integer_p
);
1922 if SCM_INUMP(x
) return SCM_BOOL_T
;
1923 if SCM_IMP(x
) return SCM_BOOL_F
;
1925 if SCM_BIGP(x
) return SCM_BOOL_T
;
1927 if (!SCM_INEXP(x
)) return SCM_BOOL_F
;
1928 if (SCM_CPLXP(x
)) return SCM_BOOL_F
;
1929 r
= SCM_REALPART(x
);
1930 if (r
==floor(r
)) return SCM_BOOL_T
;
1936 #endif /* SCM_FLOATS */
1938 SCM_PROC(s_inexact_p
, "inexact?", 1, 0, 0, scm_inexact_p
);
1945 if (SCM_NIMP(x
) && SCM_INEXP(x
)) return SCM_BOOL_T
;
1953 SCM_PROC1 (s_eq_p
, "=", scm_tc7_rpsubr
, scm_num_eq_p
);
1966 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_eq_p
);
1969 if SCM_INUMP(y
) return SCM_BOOL_F
;
1970 SCM_ASRTGO(SCM_NIMP(y
), bady
);
1971 if SCM_BIGP(y
) return (0==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
1972 SCM_ASRTGO(SCM_INEXP(y
), bady
);
1974 return (SCM_REALP(y
) && (scm_big2dbl(x
)==SCM_REALPART(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
1976 SCM_ASRTGO(SCM_INEXP(x
), badx
);
1978 SCM_ASSERT(SCM_NIMP(x
) && SCM_INEXP(x
), x
, SCM_ARG1
, s_eq_p
);
1980 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto realint
;}
1982 SCM_ASRTGO(SCM_NIMP(y
), bady
);
1983 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
1984 SCM_ASRTGO(SCM_INEXP(y
), bady
);
1986 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
1988 if (SCM_REALPART(x
) != SCM_REALPART(y
)) return SCM_BOOL_F
;
1990 return (SCM_CPLXP(y
) && (SCM_IMAG(x
)==SCM_IMAG(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
1991 return SCM_CPLXP(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
1995 SCM_ASRTGO(SCM_NIMP(y
), bady
);
1996 if SCM_BIGP(y
) return SCM_BOOL_F
;
1998 if (!(SCM_INEXP(y
)))
1999 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2003 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2004 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2008 return (SCM_REALP(y
) && (((double)SCM_INUM(x
))==SCM_REALPART(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2013 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_eq_p
);
2014 if SCM_INUMP(y
) return SCM_BOOL_F
;
2015 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2016 return (0==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2020 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2021 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2026 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_eq_p
);
2027 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_eq_p
);
2030 return ((long)x
==(long)y
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2035 SCM_PROC1 (s_less_p
, "<", scm_tc7_rpsubr
, scm_less_p
);
2047 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_less_p
);
2050 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2051 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2052 if SCM_BIGP(y
) return (1==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2053 SCM_ASRTGO(SCM_REALP(y
), bady
);
2054 return (scm_big2dbl(x
) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2056 SCM_ASRTGO(SCM_REALP(x
), badx
);
2058 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_less_p
);
2061 return (SCM_REALPART(x
) < ((double)SCM_INUM(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2063 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2064 if SCM_BIGP(y
) return (SCM_REALPART(x
) < scm_big2dbl(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2065 SCM_ASRTGO(SCM_REALP(y
), bady
);
2067 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2069 return (SCM_REALPART(x
) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2073 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2074 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
2076 if (!(SCM_REALP(y
)))
2077 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2081 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2082 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2085 return (((double)SCM_INUM(x
)) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2090 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_less_p
);
2091 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2092 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2093 return (1==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2097 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2098 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2100 return SCM_BIGSIGN(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
2103 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_less_p
);
2104 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_less_p
);
2107 return ((long)x
< (long)y
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2111 SCM_PROC1 (s_gr_p
, ">", scm_tc7_rpsubr
, scm_gr_p
);
2118 return scm_less_p(y
, x
);
2123 SCM_PROC1 (s_leq_p
, "<=", scm_tc7_rpsubr
, scm_leq_p
);
2130 return SCM_BOOL_NOT(scm_less_p(y
, x
));
2135 SCM_PROC1 (s_geq_p
, ">=", scm_tc7_rpsubr
, scm_geq_p
);
2142 return SCM_BOOL_NOT(scm_less_p(x
, y
));
2147 SCM_PROC(s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
);
2156 SCM_ASRTGO(SCM_NIMP(z
), badz
);
2157 if SCM_BIGP(z
) return SCM_BOOL_F
;
2159 if (!(SCM_INEXP(z
)))
2160 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_zero_p
);
2163 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_zero_p
);
2165 return (z
==scm_flo0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2170 SCM_ASSERT(SCM_NIMP(z
) && SCM_BIGP(z
), z
, SCM_ARG1
, s_zero_p
);
2174 SCM_ASSERT(SCM_INUMP(z
), z
, SCM_ARG1
, s_zero_p
);
2177 return (z
==SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2182 SCM_PROC(s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
);
2191 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2192 if SCM_BIGP(x
) return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_T
: SCM_BOOL_F
;
2194 if (!(SCM_REALP(x
)))
2195 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_positive_p
);
2198 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_positive_p
);
2200 return (SCM_REALPART(x
) > 0.0) ? SCM_BOOL_T
: SCM_BOOL_F
;
2205 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_positive_p
);
2206 return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_T
: SCM_BOOL_F
;
2209 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_positive_p
);
2212 return (x
> SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2217 SCM_PROC(s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
);
2226 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2227 if SCM_BIGP(x
) return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_F
: SCM_BOOL_T
;
2229 if (!(SCM_REALP(x
)))
2230 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_negative_p
);
2233 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_negative_p
);
2235 return (SCM_REALPART(x
) < 0.0) ? SCM_BOOL_T
: SCM_BOOL_F
;
2240 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_negative_p
);
2241 return (SCM_TYP16(x
)==scm_tc16_bigneg
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2244 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_negative_p
);
2247 return (x
< SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2251 SCM_PROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
);
2263 if (!(SCM_NUMBERP(x
)))
2264 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_max
);
2271 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2273 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? y
: x
;
2274 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2275 if SCM_BIGP(y
) return (1==scm_bigcomp(x
, y
)) ? y
: x
;
2276 SCM_ASRTGO(SCM_REALP(y
), bady
);
2278 return (z
< SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2280 SCM_ASRTGO(SCM_REALP(x
), badx
);
2282 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_max
);
2285 return (SCM_REALPART(x
) < (z
= SCM_INUM(y
))) ? scm_makdbl(z
, 0.0) : x
;
2287 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2289 return (SCM_REALPART(x
) < (z
= scm_big2dbl(y
))) ? scm_makdbl(z
, 0.0) : x
;
2290 SCM_ASRTGO(SCM_REALP(y
), bady
);
2292 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2294 return (SCM_REALPART(x
) < SCM_REALPART(y
)) ? y
: x
;
2298 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2299 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? x
: y
;
2301 if (!(SCM_REALP(y
)))
2302 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2306 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2307 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2310 return ((z
= SCM_INUM(x
)) < SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2315 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_max
);
2316 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? y
: x
;
2317 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2318 return (1==scm_bigcomp(x
, y
)) ? y
: x
;
2322 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2323 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2325 return SCM_BIGSIGN(y
) ? x
: y
;
2328 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_max
);
2329 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_max
);
2332 return ((long)x
< (long)y
) ? y
: x
;
2338 SCM_PROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
);
2350 if (!(SCM_NUMBERP(x
)))
2351 badx
:scm_wta(x
, (char *)SCM_ARG1
, s_min
);
2358 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2360 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? x
: y
;
2361 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2362 if SCM_BIGP(y
) return (-1==scm_bigcomp(x
, y
)) ? y
: x
;
2363 SCM_ASRTGO(SCM_REALP(y
), bady
);
2365 return (z
> SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2367 SCM_ASRTGO(SCM_REALP(x
), badx
);
2369 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_min
);
2371 if SCM_INUMP(y
) return (SCM_REALPART(x
) > (z
= SCM_INUM(y
))) ? scm_makdbl(z
, 0.0) : x
;
2373 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2374 if SCM_BIGP(y
) return (SCM_REALPART(x
) > (z
= scm_big2dbl(y
))) ? scm_makdbl(z
, 0.0) : x
;
2375 SCM_ASRTGO(SCM_REALP(y
), bady
);
2377 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2379 return (SCM_REALPART(x
) > SCM_REALPART(y
)) ? y
: x
;
2383 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2384 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? y
: x
;
2386 if (!(SCM_REALP(y
)))
2387 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2391 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2392 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2395 return ((z
= SCM_INUM(x
)) > SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2400 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_min
);
2401 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? x
: y
;
2402 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2403 return (-1==scm_bigcomp(x
, y
)) ? y
: x
;
2407 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2408 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2410 return SCM_BIGSIGN(y
) ? y
: x
;
2413 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_min
);
2414 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_min
);
2417 return ((long)x
> (long)y
) ? y
: x
;
2423 SCM_PROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
);
2431 if SCM_UNBNDP(x
) return SCM_INUM0
;
2433 if (!(SCM_NUMBERP(x
)))
2434 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_sum
);
2442 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2444 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2445 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2447 if (SCM_NUMDIGS(x
) > SCM_NUMDIGS(y
)) {t
= x
; x
= y
; y
= t
;}
2448 return scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0);
2450 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2451 bigreal
: return scm_makdbl(scm_big2dbl(x
)+SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_IMAG(y
):0.0);
2453 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2455 SCM_ASRTGO(SCM_NIMP(x
) && SCM_INEXP(x
), badx
);
2457 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intreal
;}
2459 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2460 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
2462 else if (!(SCM_INEXP(y
)))
2463 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2467 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2468 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2472 if SCM_CPLXP(x
) i
= SCM_IMAG(x
);
2473 if SCM_CPLXP(y
) i
+= SCM_IMAG(y
);
2474 return scm_makdbl(SCM_REALPART(x
)+SCM_REALPART(y
), i
); }
2478 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2481 # ifndef SCM_DIGSTOOBIG
2482 long z
= scm_pseudolong(SCM_INUM(x
));
2483 return scm_addbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2485 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2486 scm_longdigs(SCM_INUM(x
), zdigs
);
2487 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2490 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2492 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2494 intreal
: return scm_makdbl(SCM_INUM(x
)+SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_IMAG(y
):0.0);
2500 SCM_ASRTGO(SCM_NIMP(x
) && SCM_BIGP(x
), badx
);
2501 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2502 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2503 if (SCM_NUMDIGS(x
) > SCM_NUMDIGS(y
)) {t
= x
; x
= y
; y
= t
;}
2504 return scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0);
2508 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2509 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2512 # ifndef SCM_DIGSTOOBIG
2513 long z
= scm_pseudolong(SCM_INUM(x
));
2514 return scm_addbig(&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2516 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2517 scm_longdigs(SCM_INUM(x
), zdigs
);
2518 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2523 SCM_ASRTGO(SCM_INUMP(x
), badx
);
2524 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_sum
);
2527 x
= SCM_INUM(x
)+SCM_INUM(y
);
2528 if SCM_FIXABLE(x
) return SCM_MAKINUM(x
);
2530 return scm_long2big(x
);
2533 return scm_makdbl((double)x
, 0.0);
2535 scm_num_overflow (s_sum
);
2536 return SCM_UNSPECIFIED
;
2544 SCM_PROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
);
2547 scm_difference(x
, y
)
2555 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_difference
);
2560 x
= scm_copybig(x
, !SCM_BIGSIGN(x
));
2561 return SCM_NUMDIGS(x
) * SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
) ?
2562 scm_big2inum(x
, SCM_NUMDIGS(x
)) : x
;
2565 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2566 return scm_makdbl(-SCM_REALPART(x
), SCM_CPLXP(x
)?-SCM_IMAG(x
):0.0);
2568 if SCM_INUMP(y
) return scm_sum(x
, SCM_MAKINUM(-SCM_INUM(y
)));
2570 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2572 if SCM_BIGP(y
) return (SCM_NUMDIGS(x
) < SCM_NUMDIGS(y
)) ?
2573 scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0x0100) :
2574 scm_addbig(SCM_BDIGITS(y
), SCM_NUMDIGS(y
), SCM_BIGSIGN(y
) ^ 0x0100, x
, 0);
2575 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2576 return scm_makdbl(scm_big2dbl(x
)-SCM_REALPART(y
), SCM_CPLXP(y
)?-SCM_IMAG(y
):0.0);
2578 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2579 if SCM_BIGP(y
) return scm_makdbl(SCM_REALPART(x
)-scm_big2dbl(y
), SCM_CPLXP(x
)?SCM_IMAG(x
):0.0);
2580 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2582 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2583 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2587 return scm_makdbl(SCM_REAL(x
)-SCM_REAL(y
), SCM_IMAG(x
)-SCM_IMAG(y
));
2589 return scm_makdbl(SCM_REAL(x
)-SCM_REALPART(y
), SCM_IMAG(x
));
2590 return scm_makdbl(SCM_REALPART(x
)-SCM_REALPART(y
), SCM_CPLXP(y
)?-SCM_IMAG(y
):0.0);
2592 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2595 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2597 # ifndef SCM_DIGSTOOBIG
2598 long z
= scm_pseudolong(SCM_INUM(x
));
2599 return scm_addbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2601 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2602 scm_longdigs(SCM_INUM(x
), zdigs
);
2603 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2607 if (!(SCM_INEXP(y
)))
2608 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2612 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2613 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2616 return scm_makdbl(SCM_INUM(x
)-SCM_REALPART(y
), SCM_CPLXP(y
)?-SCM_IMAG(y
):0.0);
2621 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_difference
);
2623 x
= scm_copybig(x
, !SCM_BIGSIGN(x
));
2624 return SCM_NUMDIGS(x
) * SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
) ?
2625 scm_big2inum(x
, SCM_NUMDIGS(x
)) : x
;
2628 # ifndef SCM_DIGSTOOBIG
2629 long z
= scm_pseudolong(SCM_INUM(y
));
2630 return scm_addbig(&z
, SCM_DIGSPERLONG
, (y
< 0) ? 0 : 0x0100, x
, 0);
2632 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2633 scm_longdigs(SCM_INUM(x
), zdigs
);
2634 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (y
< 0) ? 0 : 0x0100, x
, 0);
2637 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2638 return (SCM_NUMDIGS(x
) < SCM_NUMDIGS(y
)) ?
2639 scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0x0100) :
2640 scm_addbig(SCM_BDIGITS(y
), SCM_NUMDIGS(y
), SCM_BIGSIGN(y
) ^ 0x0100, x
, 0);
2642 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2645 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2646 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2649 # ifndef SCM_DIGSTOOBIG
2650 long z
= scm_pseudolong(SCM_INUM(x
));
2651 return scm_addbig(&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2653 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2654 scm_longdigs(SCM_INUM(x
), zdigs
);
2655 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2660 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_difference
);
2661 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2662 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_difference
);
2665 x
= SCM_INUM(x
)-SCM_INUM(y
);
2667 if SCM_FIXABLE(x
) return SCM_MAKINUM(x
);
2669 return scm_long2big(x
);
2672 return scm_makdbl((double)x
, 0.0);
2674 scm_num_overflow (s_difference
);
2675 return SCM_UNSPECIFIED
;
2683 SCM_PROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
);
2691 if SCM_UNBNDP(x
) return SCM_MAKINUM(1L);
2693 if (!(SCM_NUMBERP(x
)))
2694 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_product
);
2702 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2704 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2705 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2706 if SCM_BIGP(y
) return scm_mulbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2707 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
));
2708 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2710 double bg
= scm_big2dbl(x
);
2711 return scm_makdbl(bg
*SCM_REALPART(y
), SCM_CPLXP(y
)?bg
*SCM_IMAG(y
):0.0); }
2713 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2715 SCM_ASRTGO(SCM_NIMP(x
) && SCM_INEXP(x
), badx
);
2717 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intreal
;}
2719 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2720 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
2722 else if (!(SCM_INEXP(y
)))
2723 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
2727 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2728 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
2733 return scm_makdbl(SCM_REAL(x
)*SCM_REAL(y
)-SCM_IMAG(x
)*SCM_IMAG(y
),
2734 SCM_REAL(x
)*SCM_IMAG(y
)+SCM_IMAG(x
)*SCM_REAL(y
));
2736 return scm_makdbl(SCM_REAL(x
)*SCM_REALPART(y
), SCM_IMAG(x
)*SCM_REALPART(y
));
2737 return scm_makdbl(SCM_REALPART(x
)*SCM_REALPART(y
),
2738 SCM_CPLXP(y
)?SCM_REALPART(x
)*SCM_IMAG(y
):0.0);
2742 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2744 intbig
: if (SCM_INUM0
==x
) return x
; if (SCM_MAKINUM(1L)==x
) return y
;
2746 # ifndef SCM_DIGSTOOBIG
2747 long z
= scm_pseudolong(SCM_INUM(x
));
2748 return scm_mulbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2749 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
2751 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2752 scm_longdigs(SCM_INUM(x
), zdigs
);
2753 return scm_mulbig(zdigs
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2754 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
2758 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2760 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2762 intreal
: return scm_makdbl(SCM_INUM(x
)*SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_INUM(x
)*SCM_IMAG(y
):0.0);
2767 SCM_ASRTGO(SCM_NIMP(x
) && SCM_BIGP(x
), badx
);
2768 if SCM_INUMP(y
) {SCM t
= x
; x
= y
; y
= t
; goto intbig
;}
2769 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2770 return scm_mulbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2771 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
));
2775 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2776 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
2778 intbig
: if (SCM_INUM0
==x
) return x
; if (SCM_MAKINUM(1L)==x
) return y
;
2780 # ifndef SCM_DIGSTOOBIG
2781 long z
= scm_pseudolong(SCM_INUM(x
));
2782 return scm_mulbig(&z
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2783 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
2785 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2786 scm_longdigs(SCM_INUM(x
), zdigs
);
2787 return scm_mulbig(zdigs
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2788 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
2793 SCM_ASRTGO(SCM_INUMP(x
), badx
);
2794 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_product
);
2804 if (k
!= SCM_INUM(y
) || k
/i
!= j
)
2806 { int sgn
= (i
< 0) ^ (j
< 0);
2807 # ifndef SCM_DIGSTOOBIG
2808 i
= scm_pseudolong(i
);
2809 j
= scm_pseudolong(j
);
2810 return scm_mulbig((SCM_BIGDIG
*)&i
, SCM_DIGSPERLONG
,
2811 (SCM_BIGDIG
*)&j
, SCM_DIGSPERLONG
, sgn
);
2812 # else /* SCM_DIGSTOOBIG */
2813 SCM_BIGDIG idigs
[SCM_DIGSPERLONG
];
2814 SCM_BIGDIG jdigs
[SCM_DIGSPERLONG
];
2815 scm_longdigs(i
, idigs
);
2816 scm_longdigs(j
, jdigs
);
2817 return scm_mulbig(idigs
, SCM_DIGSPERLONG
, jdigs
, SCM_DIGSPERLONG
, sgn
);
2822 return scm_makdbl(((double)i
)*((double)j
), 0.0);
2824 scm_num_overflow (s_product
);
2834 scm_num2dbl (a
, why
)
2839 return (double) SCM_INUM (a
);
2841 SCM_ASSERT (SCM_NIMP (a
), a
, "wrong type argument", why
);
2843 return (SCM_REALPART (a
));
2846 return scm_big2dbl (a
);
2848 SCM_ASSERT (0, a
, "wrong type argument", why
);
2849 return SCM_UNSPECIFIED
;
2853 SCM_PROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
);
2865 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_divide
);
2869 if SCM_BIGP(x
) return scm_makdbl(1.0/scm_big2dbl(x
), 0.0);
2871 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2872 if SCM_REALP(x
) return scm_makdbl(1.0/SCM_REALPART(x
), 0.0);
2873 r
= SCM_REAL(x
); i
= SCM_IMAG(x
); d
= r
*r
+i
*i
;
2874 return scm_makdbl(r
/d
, -i
/d
);
2883 scm_num_overflow (s_divide
);
2887 if (z
< SCM_BIGRAD
) {
2888 SCM w
= scm_copybig(x
, SCM_BIGSIGN(x
) ? (y
>0) : (y
<0));
2889 return scm_divbigdig(SCM_BDIGITS(w
), SCM_NUMDIGS(w
), (SCM_BIGDIG
)z
) ?
2890 scm_makdbl(scm_big2dbl(x
)/SCM_INUM(y
), 0.0) : scm_normbig(w
);
2892 # ifndef SCM_DIGSTOOBIG
2893 z
= scm_pseudolong(z
);
2894 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), (SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
2895 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);
2897 { SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2898 scm_longdigs(z
, zdigs
);
2899 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), zdigs
, SCM_DIGSPERLONG
,
2900 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);}
2902 return z
? z
: scm_makdbl(scm_big2dbl(x
)/SCM_INUM(y
), 0.0);
2904 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2906 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2907 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
), 3);
2908 return z
? z
: scm_makdbl(scm_big2dbl(x
)/scm_big2dbl(y
), 0.0);
2910 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2911 if SCM_REALP(y
) return scm_makdbl(scm_big2dbl(x
)/SCM_REALPART(y
), 0.0);
2916 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2917 if SCM_INUMP(y
) {d
= SCM_INUM(y
); goto basic_div
;}
2919 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2920 if SCM_BIGP(y
) {d
= scm_big2dbl(y
); goto basic_div
;}
2921 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2923 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2926 d
= SCM_REALPART(y
);
2927 basic_div
: return scm_makdbl(SCM_REALPART(x
)/d
, SCM_CPLXP(x
)?SCM_IMAG(x
)/d
:0.0);
2929 a
= SCM_REALPART(x
);
2930 if SCM_REALP(x
) goto complex_div
;
2931 r
= SCM_REAL(y
); i
= SCM_IMAG(y
); d
= r
*r
+i
*i
;
2932 return scm_makdbl((a
*r
+SCM_IMAG(x
)*i
)/d
, (SCM_IMAG(x
)*r
-a
*i
)/d
);
2935 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
2936 return scm_makdbl(1.0/((double)SCM_INUM(x
)), 0.0);
2940 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2941 if SCM_BIGP(y
) return scm_makdbl(SCM_INUM(x
)/scm_big2dbl(y
), 0.0);
2943 if (!(SCM_INEXP(y
)))
2944 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
2948 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2949 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
2953 return scm_makdbl(SCM_INUM(x
)/SCM_REALPART(y
), 0.0);
2956 r
= SCM_REAL(y
); i
= SCM_IMAG(y
); d
= r
*r
+i
*i
;
2957 return scm_makdbl((a
*r
)/d
, (-a
*i
)/d
);
2963 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_divide
);
2964 if SCM_UNBNDP(y
) goto ov
;
2970 if (z
< SCM_BIGRAD
) {
2971 SCM w
= scm_copybig(x
, SCM_BIGSIGN(x
) ? (y
>0) : (y
<0));
2972 if (scm_divbigdig(SCM_BDIGITS(w
), SCM_NUMDIGS(w
), (SCM_BIGDIG
)z
)) goto ov
;
2975 # ifndef SCM_DIGSTOOBIG
2976 z
= scm_pseudolong(z
);
2977 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), &z
, SCM_DIGSPERLONG
,
2978 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);
2980 { SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2981 scm_longdigs(z
, zdigs
);
2982 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), zdigs
, SCM_DIGSPERLONG
,
2983 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);}
2986 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2987 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2988 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
), 3);
2994 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
2999 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
3000 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
3005 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_divide
);
3007 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
3010 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_divide
);
3014 long z
= SCM_INUM(y
);
3015 if ((0==z
) || SCM_INUM(x
)%z
) goto ov
;
3017 if SCM_FIXABLE(z
) return SCM_MAKINUM(z
);
3019 return scm_long2big(z
);
3022 ov
: return scm_makdbl(((double)SCM_INUM(x
))/((double)SCM_INUM(y
)), 0.0);
3024 ov
: scm_num_overflow (s_divide
);
3025 return SCM_UNSPECIFIED
;
3034 SCM_PROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
);
3040 return log(x
+sqrt(x
*x
+1));
3046 SCM_PROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
);
3052 return log(x
+sqrt(x
*x
-1));
3058 SCM_PROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
);
3064 return 0.5*log((1+x
)/(1-x
));
3070 SCM_PROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
);
3076 if (x
< 0.0) return -floor(-x
);
3082 SCM_PROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
);
3088 double plus_half
= x
+ 0.5;
3089 double result
= floor(plus_half
);
3090 /* Adjust so that the scm_round is towards even. */
3091 return (plus_half
== result
&& plus_half
/ 2 != floor(plus_half
/ 2))
3092 ? result
- 1 : result
;
3097 SCM_PROC1 (s_exact_to_inexact
, "exact->inexact", scm_tc7_cxr
, (SCM (*)()) scm_exact_to_inexact
);
3100 scm_exact_to_inexact(z
)
3107 SCM_PROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
);
3108 SCM_PROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
);
3109 SCM_PROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)())sqrt
);
3110 SCM_PROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)())fabs
);
3111 SCM_PROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)())exp
);
3112 SCM_PROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)())log
);
3113 SCM_PROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)())sin
);
3114 SCM_PROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)())cos
);
3115 SCM_PROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)())tan
);
3116 SCM_PROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)())asin
);
3117 SCM_PROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)())acos
);
3118 SCM_PROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)())atan
);
3119 SCM_PROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)())sinh
);
3120 SCM_PROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)())cosh
);
3121 SCM_PROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)())tanh
);
3123 struct dpair
{double x
, y
;};
3125 static void scm_two_doubles
SCM_P ((SCM z1
, SCM z2
, char *sstring
, struct dpair
*xy
));
3128 scm_two_doubles(z1
, z2
, sstring
, xy
)
3133 if SCM_INUMP(z1
) xy
->x
= SCM_INUM(z1
);
3136 SCM_ASRTGO(SCM_NIMP(z1
), badz1
);
3137 if SCM_BIGP(z1
) xy
->x
= scm_big2dbl(z1
);
3140 if (!(SCM_REALP(z1
)))
3141 badz1
: scm_wta(z1
, (char *)SCM_ARG1
, sstring
);
3143 xy
->x
= SCM_REALPART(z1
);}
3145 {SCM_ASSERT(SCM_NIMP(z1
) && SCM_REALP(z1
), z1
, SCM_ARG1
, sstring
);
3146 xy
->x
= SCM_REALPART(z1
);}
3149 if SCM_INUMP(z2
) xy
->y
= SCM_INUM(z2
);
3152 SCM_ASRTGO(SCM_NIMP(z2
), badz2
);
3153 if SCM_BIGP(z2
) xy
->y
= scm_big2dbl(z2
);
3156 if (!(SCM_REALP(z2
)))
3157 badz2
: scm_wta(z2
, (char *)SCM_ARG2
, sstring
);
3159 xy
->y
= SCM_REALPART(z2
);}
3161 {SCM_ASSERT(SCM_NIMP(z2
) && SCM_REALP(z2
), z2
, SCM_ARG2
, sstring
);
3162 xy
->y
= SCM_REALPART(z2
);}
3170 SCM_PROC(s_sys_expt
, "$expt", 2, 0, 0, scm_sys_expt
);
3173 scm_sys_expt(z1
, z2
)
3178 scm_two_doubles(z1
, z2
, s_sys_expt
, &xy
);
3179 return scm_makdbl(pow(xy
.x
, xy
.y
), 0.0);
3184 SCM_PROC(s_sys_atan2
, "$atan2", 2, 0, 0, scm_sys_atan2
);
3187 scm_sys_atan2(z1
, z2
)
3192 scm_two_doubles(z1
, z2
, s_sys_atan2
, &xy
);
3193 return scm_makdbl(atan2(xy
.x
, xy
.y
), 0.0);
3198 SCM_PROC(s_make_rectangular
, "make-rectangular", 2, 0, 0, scm_make_rectangular
);
3201 scm_make_rectangular(z1
, z2
)
3206 scm_two_doubles(z1
, z2
, s_make_rectangular
, &xy
);
3207 return scm_makdbl(xy
.x
, xy
.y
);
3212 SCM_PROC(s_make_polar
, "make-polar", 2, 0, 0, scm_make_polar
);
3215 scm_make_polar(z1
, z2
)
3220 scm_two_doubles(z1
, z2
, s_make_polar
, &xy
);
3221 return scm_makdbl(xy
.x
*cos(xy
.y
), xy
.x
*sin(xy
.y
));
3227 SCM_PROC(s_real_part
, "real-part", 1, 0, 0, scm_real_part
);
3235 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3236 if SCM_BIGP(z
) return z
;
3238 if (!(SCM_INEXP(z
)))
3239 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_real_part
);
3242 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_real_part
);
3244 if SCM_CPLXP(z
) return scm_makdbl(SCM_REAL(z
), 0.0);
3251 SCM_PROC(s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
);
3257 if SCM_INUMP(z
) return SCM_INUM0
;
3259 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3260 if SCM_BIGP(z
) return SCM_INUM0
;
3262 if (!(SCM_INEXP(z
)))
3263 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_imag_part
);
3266 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_imag_part
);
3268 if SCM_CPLXP(z
) return scm_makdbl(SCM_IMAG(z
), 0.0);
3274 SCM_PROC(s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
);
3280 if SCM_INUMP(z
) return scm_abs(z
);
3282 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3283 if SCM_BIGP(z
) return scm_abs(z
);
3285 if (!(SCM_INEXP(z
)))
3286 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_magnitude
);
3289 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_magnitude
);
3293 double i
= SCM_IMAG(z
), r
= SCM_REAL(z
);
3294 return scm_makdbl(sqrt(i
*i
+r
*r
), 0.0);
3296 return scm_makdbl(fabs(SCM_REALPART(z
)), 0.0);
3302 SCM_PROC(s_angle
, "angle", 1, 0, 0, scm_angle
);
3309 if SCM_INUMP(z
) {x
= (z
>=SCM_INUM0
) ? 1.0 : -1.0; goto do_angle
;}
3311 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3312 if SCM_BIGP(z
) {x
= (SCM_TYP16(z
)==scm_tc16_bigpos
) ? 1.0 : -1.0; goto do_angle
;}
3314 if (!(SCM_INEXP(z
))) {
3315 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_angle
);}
3318 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_angle
);
3322 x
= SCM_REALPART(z
);
3325 x
= SCM_REAL(z
); y
= SCM_IMAG(z
);
3327 return scm_makdbl(atan2(y
, x
), 0.0);
3331 SCM_PROC(s_inexact_to_exact
, "inexact->exact", 1, 0, 0, scm_inexact_to_exact
);
3334 scm_inexact_to_exact(z
)
3337 if SCM_INUMP(z
) return z
;
3339 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3340 if SCM_BIGP(z
) return z
;
3342 if (!(SCM_REALP(z
)))
3343 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_inexact_to_exact
);
3346 SCM_ASSERT(SCM_NIMP(z
) && SCM_REALP(z
), z
, SCM_ARG1
, s_inexact_to_exact
);
3350 double u
= floor(SCM_REALPART(z
)+0.5);
3351 if ((u
<= SCM_MOST_POSITIVE_FIXNUM
) && (-u
<= -SCM_MOST_NEGATIVE_FIXNUM
)) {
3352 /* Negation is a workaround for HP700 cc bug */
3353 SCM ans
= SCM_MAKINUM((long)u
);
3354 if (SCM_INUM(ans
)==(long)u
) return ans
;
3356 SCM_ASRTGO(!IS_INF(u
), badz
); /* problem? */
3357 return scm_dbl2big(u
);
3360 return SCM_MAKINUM((long)floor(SCM_REALPART(z
)+0.5));
3366 #else /* ~SCM_FLOATS */
3367 SCM_PROC(s_trunc
, "truncate", 1, 0, 0, scm_trunc
);
3373 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_truncate
);
3379 #endif /* SCM_FLOATS */
3383 /* d must be integer */
3393 double u
= (d
< 0)?-d
:d
;
3394 while (0 != floor(u
)) {u
/= SCM_BIGRAD
;i
++;}
3395 ans
= scm_mkbig(i
, d
< 0);
3396 digits
= SCM_BDIGITS(ans
);
3405 scm_num_overflow ("dbl2big");
3418 scm_sizet i
= SCM_NUMDIGS(b
);
3419 SCM_BIGDIG
*digits
= SCM_BDIGITS(b
);
3420 while (i
--) ans
= digits
[i
] + SCM_BIGRAD
*ans
;
3421 if (scm_tc16_bigneg
==SCM_TYP16(b
)) return -ans
;
3432 if (!SCM_FIXABLE(sl
)) {
3434 return scm_long2big(sl
);
3437 return scm_makdbl((double) sl
, 0.0);
3443 return SCM_MAKINUM(sl
);
3450 scm_long_long2num(sl
)
3453 if (!SCM_FIXABLE(sl
)) {
3455 return scm_long_long2big(sl
);
3458 return scm_makdbl((double) sl
, 0.0);
3464 return SCM_MAKINUM(sl
);
3474 if (!SCM_POSFIXABLE(sl
)) {
3476 return scm_ulong2big(sl
);
3479 return scm_makdbl((double) sl
, 0.0);
3485 return SCM_MAKINUM(sl
);
3490 scm_num2long(num
, pos
, s_caller
)
3498 res
= SCM_INUM(num
);
3501 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3505 double u
= SCM_REALPART(num
);
3507 if ((double)res
== u
)
3514 if (SCM_BIGP(num
)) {
3519 for(l
= SCM_NUMDIGS(num
);l
--;)
3521 res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
3526 if (SCM_TYP16 (num
) == scm_tc16_bigpos
)
3532 errout
: scm_wta(num
, pos
, s_caller
);
3533 return SCM_UNSPECIFIED
;
3541 num2long(num
, pos
, s_caller
)
3548 res
= SCM_INUM((long)num
);
3551 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3554 double u
= SCM_REALPART(num
);
3555 if (((SCM_MOST_NEGATIVE_FIXNUM
* 4) <= u
)
3556 && (u
<= (SCM_MOST_POSITIVE_FIXNUM
* 4 + 3))) {
3564 scm_sizet l
= SCM_NUMDIGS(num
);
3565 SCM_ASRTGO(SCM_DIGSPERLONG
>= l
, errout
);
3567 for(;l
--;) res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
3571 errout
: scm_wta(num
, pos
, s_caller
);
3572 return SCM_UNSPECIFIED
;
3579 scm_num2long_long(num
, pos
, s_caller
)
3586 res
= SCM_INUM((long_long
)num
);
3589 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3592 double u
= SCM_REALPART(num
);
3593 if (((SCM_MOST_NEGATIVE_FIXNUM
* 4) <= u
)
3594 && (u
<= (SCM_MOST_POSITIVE_FIXNUM
* 4 + 3))) {
3602 scm_sizet l
= SCM_NUMDIGS(num
);
3603 SCM_ASRTGO(SCM_DIGSPERLONGLONG
>= l
, errout
);
3605 for(;l
--;) res
= SCM_LONGLONGBIGUP(res
) + SCM_BDIGITS(num
)[l
];
3609 errout
: scm_wta(num
, pos
, s_caller
);
3610 return SCM_UNSPECIFIED
;
3617 scm_num2ulong(num
, pos
, s_caller
)
3625 res
= SCM_INUM((unsigned long)num
);
3628 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3632 double u
= SCM_REALPART(num
);
3633 if ((0 <= u
) && (u
<= (unsigned long)~0L))
3641 if (SCM_BIGP(num
)) {
3642 unsigned long oldres
;
3646 for(l
= SCM_NUMDIGS(num
);l
--;)
3648 res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
3656 errout
: scm_wta(num
, pos
, s_caller
);
3657 return SCM_UNSPECIFIED
;
3663 static void add1
SCM_P ((double f
, double *fsum
));
3664 static void add1(f
, fsum
)
3678 SCM_NEWCELL(scm_flo0
);
3680 SCM_SETCAR (scm_flo0
, scm_tc_flo
);
3681 SCM_FLO(scm_flo0
) = 0.0;
3683 SCM_SETCDR (scm_flo0
, (SCM
)scm_must_malloc(1L*sizeof(double), "real"));
3684 SCM_REAL(scm_flo0
) = 0.0;
3685 SCM_SETCAR (scm_flo0
, scm_tc_dblr
);
3688 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
3690 { /* determine floating point precision */
3692 double fsum
= 1.0+f
;
3693 while (fsum
!= 1.0) {
3695 if (++scm_dblprec
> 20) break;
3698 scm_dblprec
= scm_dblprec
-1;
3700 # endif /* DBL_DIG */
3702 #include "numbers.x"