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
);
95 if SCM_INUMP(x
) return SCM_BOOL_T
;
97 if (SCM_NIMP(x
) && SCM_BIGP(x
)) return SCM_BOOL_T
;
102 SCM_PROC(s_odd_p
, "odd?", 1, 0, 0, scm_odd_p
);
114 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_odd_p
);
115 return (1 & SCM_BDIGITS(n
)[0]) ? SCM_BOOL_T
: SCM_BOOL_F
;
118 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_odd_p
);
120 return (4 & (int)n
) ? SCM_BOOL_T
: SCM_BOOL_F
;
123 SCM_PROC(s_even_p
, "even?", 1, 0, 0, scm_even_p
);
135 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_even_p
);
136 return (1 & SCM_BDIGITS(n
)[0]) ? SCM_BOOL_F
: SCM_BOOL_T
;
139 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_even_p
);
141 return (4 & (int)n
) ? SCM_BOOL_F
: SCM_BOOL_T
;
144 SCM_PROC(s_abs
, "abs", 1, 0, 0, scm_abs
);
156 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_abs
);
157 if (SCM_TYP16(x
)==scm_tc16_bigpos
) return x
;
158 return scm_copybig(x
, 0);
161 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_abs
);
163 if (SCM_INUM(x
) >= 0) return x
;
165 if (!SCM_POSFIXABLE(x
))
167 return scm_long2big(x
);
169 scm_num_overflow (s_abs
);
171 return SCM_MAKINUM(x
);
174 SCM_PROC(s_quotient
, "quotient", 2, 0, 0, scm_quotient
);
177 scm_quotient(SCM x
, SCM y
)
189 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_quotient
);
191 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
192 return scm_divbigbig(SCM_BDIGITS(x
),
196 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
),
203 if (z
< SCM_BIGRAD
) {
204 w
= scm_copybig(x
, SCM_BIGSIGN(x
) ? (y
>0) : (y
<0));
205 scm_divbigdig(SCM_BDIGITS(w
), SCM_NUMDIGS(w
), (SCM_BIGDIG
)z
);
206 return scm_normbig(w
);
208 #ifndef SCM_DIGSTOOBIG
209 w
= scm_pseudolong(z
);
210 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), (SCM_BIGDIG
*)&w
, SCM_DIGSPERLONG
,
211 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 2);
213 { SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
214 scm_longdigs(z
, zdigs
);
215 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), zdigs
, SCM_DIGSPERLONG
,
216 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 2);
222 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
223 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_quotient
);
228 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_quotient
);
229 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_quotient
);
231 if ((z
= SCM_INUM(y
))==0)
232 ov
: scm_num_overflow (s_quotient
);
237 long t
= ((y
<0) ? -SCM_INUM(x
) : SCM_INUM(x
))%SCM_INUM(y
);
239 long t
= SCM_INUM(x
)%SCM_INUM(y
);
250 return scm_long2big(z
);
252 scm_num_overflow (s_quotient
);
254 return SCM_MAKINUM(z
);
257 SCM_PROC(s_remainder
, "remainder", 2, 0, 0, scm_remainder
);
260 scm_remainder(SCM x
, SCM y
)
271 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_remainder
);
273 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
274 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
277 if (!(z
= SCM_INUM(y
))) goto ov
;
278 return scm_divbigint(x
, z
, SCM_BIGSIGN(x
), 0);
282 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
283 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_remainder
);
288 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_remainder
);
289 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_remainder
);
291 if (!(z
= SCM_INUM(y
)))
292 ov
: scm_num_overflow (s_remainder
);
301 else z
+= SCM_INUM(y
);
302 else if (x
< 0) z
-= SCM_INUM(y
);
304 return SCM_MAKINUM(z
);
307 SCM_PROC(s_modulo
, "modulo", 2, 0, 0, scm_modulo
);
310 scm_modulo(SCM x
, SCM y
)
321 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_modulo
);
323 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
324 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
325 SCM_BIGSIGN(y
), (SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
)) ? 1 : 0);
327 if (!(z
= SCM_INUM(y
))) goto ov
;
328 return scm_divbigint(x
, z
, y
< 0, (SCM_BIGSIGN(x
) ? (y
> 0) : (y
< 0)) ? 1 : 0);
332 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
333 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_modulo
);
335 return (SCM_BIGSIGN(y
) ? (x
>0) : (x
<0)) ? scm_sum(x
, y
) : x
;
338 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_modulo
);
339 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_modulo
);
341 if (!(yy
= SCM_INUM(y
)))
342 ov
: scm_num_overflow (s_modulo
);
345 z
= ((yy
<0) ? -z
: z
)%yy
;
349 return SCM_MAKINUM(((yy
<0) ? (z
>0) : (z
<0)) ? z
+yy
: z
);
352 SCM_PROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
);
355 scm_gcd(SCM x
, SCM y
)
363 register long u
, v
, k
, t
;
364 if SCM_UNBNDP(y
) return SCM_UNBNDP(x
) ? SCM_INUM0
: x
;
369 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_gcd
);
370 if SCM_BIGSIGN(x
) x
= scm_copybig(x
, 0);
373 SCM_ASSERT(SCM_NIMP(y
) && SCM_BIGP(y
), y
, SCM_ARG2
, s_gcd
);
374 if SCM_BIGSIGN(y
) y
= scm_copybig(y
, 0);
375 switch (scm_bigcomp(x
, y
)) {
377 swaprec
: t
= scm_remainder(x
, y
); x
= y
; y
= t
; goto tailrec
;
379 case 1: y
= scm_remainder(y
, x
); goto newy
;
381 /* instead of the switch, we could just return scm_gcd(y, scm_modulo(x, y)); */
383 if (SCM_INUM0
==y
) return x
; goto swaprec
;
385 if SCM_NINUMP(y
) { t
=x
; x
=y
; y
=t
; goto big_gcd
;}
387 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_gcd
);
388 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_gcd
);
394 else if (0==v
) goto getout
;
395 if (0==u
) {u
= v
; goto getout
;}
396 for (k
= 1;!(1 & ((int)u
|(int)v
));k
<<= 1, u
>>= 1, v
>>= 1);
397 if (1 & (int)u
) t
= -v
;
403 if (!(1 & (int)t
)) goto b3
;
406 if ((t
= u
-v
)) goto b3
;
409 if (!SCM_POSFIXABLE(u
))
411 return scm_long2big(u
);
413 scm_num_overflow (s_gcd
);
415 return SCM_MAKINUM(u
);
418 SCM_PROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
);
421 scm_lcm(SCM n1
, SCM n2
)
431 n2
= SCM_MAKINUM(1L);
432 if SCM_UNBNDP(n1
) return n2
;
435 if (SCM_INUM0
==d
) return d
;
436 return scm_abs(scm_product(n1
, scm_quotient(n2
, d
)));
441 # define scm_long2num SCM_MAKINUM
446 SCM_PROC1 (s_logand
, "logand", scm_tc7_asubr
, scm_logand
);
449 scm_logand(SCM n1
, SCM n2
)
457 return scm_long2num(scm_num2long(n1
, (char *)SCM_ARG1
, s_logand
)
458 & scm_num2long(n2
, (char *)SCM_ARG2
, s_logand
));
461 SCM_PROC1 (s_logior
, "logior", scm_tc7_asubr
, scm_logior
);
464 scm_logior(SCM n1
, SCM n2
)
472 return scm_long2num(scm_num2long(n1
, (char *)SCM_ARG1
, s_logior
)
473 | scm_num2long(n2
, (char *)SCM_ARG2
, s_logior
));
476 SCM_PROC1 (s_logxor
, "logxor", scm_tc7_asubr
, scm_logxor
);
479 scm_logxor(SCM n1
, SCM n2
)
487 return scm_long2num(scm_num2long(n1
, (char *)SCM_ARG1
, s_logxor
)
488 ^ scm_num2long(n2
, (char *)SCM_ARG2
, s_logxor
));
491 SCM_PROC(s_logtest
, "logtest", 2, 0, 0, scm_logtest
);
494 scm_logtest(SCM n1
, SCM n2
)
502 return ((scm_num2long (n1
, (char *)SCM_ARG1
, s_logtest
)
503 & scm_num2long (n2
, (char *)SCM_ARG2
, s_logtest
))
504 ? SCM_BOOL_T
: SCM_BOOL_F
);
508 SCM_PROC(s_logbit_p
, "logbit?", 2, 0, 0, scm_logbit_p
);
511 scm_logbit_p(SCM n1
, SCM n2
)
519 return (((1 << scm_num2long (n1
, (char *)SCM_ARG1
, s_logtest
))
520 & scm_num2long (n2
, (char *)SCM_ARG2
, s_logtest
))
521 ? SCM_BOOL_T
: SCM_BOOL_F
);
526 SCM_PROC1 (s_logand
, "logand", scm_tc7_asubr
, scm_logand
);
529 scm_logand(SCM n1
, SCM n2
)
537 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logand
);
538 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logand
);
539 return SCM_MAKINUM(SCM_INUM(n1
) & SCM_INUM(n2
));
542 SCM_PROC1 (s_logior
, "logior", scm_tc7_asubr
, scm_logior
);
545 scm_logior(SCM n1
, SCM n2
)
553 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logior
);
554 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logior
);
555 return SCM_MAKINUM(SCM_INUM(n1
) | SCM_INUM(n2
));
558 SCM_PROC1 (s_logxor
, "logxor", scm_tc7_asubr
, scm_logxor
);
561 scm_logxor(SCM n1
, SCM n2
)
569 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logxor
);
570 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logxor
);
571 return SCM_MAKINUM(SCM_INUM(n1
) ^ SCM_INUM(n2
));
574 SCM_PROC(s_logtest
, "logtest", 2, 0, 0, scm_logtest
);
577 scm_logtest(SCM n1
, SCM n2
)
585 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logtest
);
586 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logtest
);
587 return (SCM_INUM(n1
) & SCM_INUM(n2
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
590 SCM_PROC(s_logbit_p
, "logbit?", 2, 0, 0, scm_logbit_p
);
593 scm_logbit_p(SCM n1
, SCM n2
)
601 SCM_ASSERT(SCM_INUMP(n1
) && SCM_INUM(n1
) >= 0, n1
, SCM_ARG1
, s_logbit_p
);
602 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logbit_p
);
603 return ((1 << SCM_INUM(n1
)) & SCM_INUM(n2
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
607 SCM_PROC(s_lognot
, "lognot", 1, 0, 0, scm_lognot
);
617 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_lognot
);
618 return scm_difference(SCM_MAKINUM(-1L), n
);
621 SCM_PROC(s_integer_expt
, "integer-expt", 2, 0, 0, scm_integer_expt
);
624 scm_integer_expt(SCM z1
, SCM z2
)
627 scm_integer_expt(z1
, z2
)
632 SCM acc
= SCM_MAKINUM(1L);
634 if (SCM_INUM0
==z1
|| acc
==z1
) return z1
;
635 else if (SCM_MAKINUM(-1L)==z1
) return SCM_BOOL_F
==scm_even_p(z2
)?z1
:acc
;
637 SCM_ASSERT(SCM_INUMP(z2
), z2
, SCM_ARG2
, s_integer_expt
);
641 z1
= scm_divide(z1
, SCM_UNDEFINED
);
644 if (0==z2
) return acc
;
645 if (1==z2
) return scm_product(acc
, z1
);
646 if (z2
& 1) acc
= scm_product(acc
, z1
);
647 z1
= scm_product(z1
, z1
);
652 SCM_PROC(s_ash
, "ash", 2, 0, 0, scm_ash
);
655 scm_ash(SCM n
, SCM cnt
)
663 SCM res
= SCM_INUM(n
);
664 SCM_ASSERT(SCM_INUMP(cnt
), cnt
, SCM_ARG2
, s_ash
);
667 res
= scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(-SCM_INUM(cnt
)));
668 if (SCM_NFALSEP(scm_negative_p(n
)))
669 return scm_sum(SCM_MAKINUM(-1L), scm_quotient(scm_sum(SCM_MAKINUM(1L), n
), res
));
670 else return scm_quotient(n
, res
);
672 else return scm_product(n
, scm_integer_expt(SCM_MAKINUM(2), cnt
));
674 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_ash
);
676 if (cnt
< 0) return SCM_MAKINUM(SCM_SRS(res
, -cnt
));
677 res
= SCM_MAKINUM(res
<<cnt
);
678 if (SCM_INUM(res
)>>cnt
!= SCM_INUM(n
))
679 scm_num_overflow (s_ash
);
684 SCM_PROC(s_bit_extract
, "bit-extract", 3, 0, 0, scm_bit_extract
);
687 scm_bit_extract(SCM n
, SCM start
, SCM end
)
690 scm_bit_extract(n
, start
, end
)
696 SCM_ASSERT(SCM_INUMP(start
), start
, SCM_ARG2
, s_bit_extract
);
697 SCM_ASSERT(SCM_INUMP(end
), end
, SCM_ARG3
, s_bit_extract
);
698 start
= SCM_INUM(start
); end
= SCM_INUM(end
);
699 SCM_ASSERT(end
>= start
, SCM_MAKINUM(end
), SCM_OUTOFRANGE
, s_bit_extract
);
703 scm_logand(scm_difference(scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(end
- start
)),
705 scm_ash(n
, SCM_MAKINUM(-start
)));
707 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_bit_extract
);
709 return SCM_MAKINUM((SCM_INUM(n
)>>start
) & ((1L<<(end
-start
))-1));
712 char scm_logtab
[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
713 SCM_PROC(s_logcount
, "logcount", 1, 0, 0, scm_logcount
);
723 register unsigned long c
= 0;
727 scm_sizet i
; SCM_BIGDIG
*ds
, d
;
728 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_logcount
);
729 if SCM_BIGSIGN(n
) return scm_logcount(scm_difference(SCM_MAKINUM(-1L), n
));
731 for(i
= SCM_NUMDIGS(n
); i
--; )
732 for(d
= ds
[i
]; d
; d
>>= 4) c
+= scm_logtab
[15 & d
];
733 return SCM_MAKINUM(c
);
736 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_logcount
);
738 if ((nn
= SCM_INUM(n
)) < 0) nn
= -1 - nn
;
739 for(; nn
; nn
>>= 4) c
+= scm_logtab
[15 & nn
];
740 return SCM_MAKINUM(c
);
743 char scm_ilentab
[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4};
744 SCM_PROC(s_integer_length
, "integer-length", 1, 0, 0, scm_integer_length
);
747 scm_integer_length(SCM n
)
750 scm_integer_length(n
)
754 register unsigned long c
= 0;
760 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_integer_length
);
761 if SCM_BIGSIGN(n
) return scm_integer_length(scm_difference(SCM_MAKINUM(-1L), n
));
763 d
= ds
[c
= SCM_NUMDIGS(n
)-1];
764 for(c
*= SCM_BITSPERDIG
; d
; d
>>= 4) {c
+= 4; l
= scm_ilentab
[15 & d
];}
765 return SCM_MAKINUM(c
- 4 + l
);
768 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_integer_length
);
770 if ((nn
= SCM_INUM(n
)) < 0) nn
= -1 - nn
;
771 for(;nn
; nn
>>= 4) {c
+= 4; l
= scm_ilentab
[15 & nn
];}
772 return SCM_MAKINUM(c
- 4 + l
);
777 char s_bignum
[] = "bignum";
780 scm_mkbig(scm_sizet nlen
, int sign
)
783 scm_mkbig(nlen
, sign
)
789 if (((v
<< 16) >> 16) != nlen
)
790 scm_wta(SCM_MAKINUM(nlen
), (char *)SCM_NALLOC
, s_bignum
);
793 SCM_SETCHARS(v
, scm_must_malloc((long)(nlen
*sizeof(SCM_BIGDIG
)), s_bignum
));
794 SCM_SETNUMDIGS(v
, nlen
, sign
?scm_tc16_bigneg
:scm_tc16_bigpos
);
801 scm_big2inum(SCM b
, scm_sizet l
)
809 unsigned long num
= 0;
810 SCM_BIGDIG
*tmp
= SCM_BDIGITS(b
);
811 while (l
--) num
= SCM_BIGUP(num
) + tmp
[l
];
812 if (SCM_TYP16(b
)==scm_tc16_bigpos
) {
813 if SCM_POSFIXABLE(num
) return SCM_MAKINUM(num
);
815 else if SCM_UNEGFIXABLE(num
) return SCM_MAKINUM(-num
);
820 char s_adjbig
[] = "scm_adjbig";
823 scm_adjbig(SCM b
, scm_sizet nlen
)
832 if (((nsiz
<< 16) >> 16) != nlen
) scm_wta(SCM_MAKINUM(nsiz
), (char *)SCM_NALLOC
, s_adjbig
);
834 SCM_SETCHARS(b
, (SCM_BIGDIG
*)scm_must_realloc((char *)SCM_CHARS(b
),
835 (long)(SCM_NUMDIGS(b
)*sizeof(SCM_BIGDIG
)),
836 (long)(nsiz
*sizeof(SCM_BIGDIG
)), s_adjbig
));
837 SCM_SETNUMDIGS(b
, nsiz
, SCM_TYP16(b
));
853 scm_sizet nlen
= SCM_NUMDIGS(b
);
855 int nlen
= SCM_NUMDIGS(b
); /* unsigned nlen breaks on Cray when nlen => 0 */
857 SCM_BIGDIG
*zds
= SCM_BDIGITS(b
);
858 while (nlen
-- && !zds
[nlen
]); nlen
++;
859 if (nlen
* SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
))
860 if SCM_INUMP(b
= scm_big2inum(b
, (scm_sizet
)nlen
)) return b
;
861 if (SCM_NUMDIGS(b
)==nlen
) return b
;
862 return scm_adjbig(b
, (scm_sizet
)nlen
);
868 scm_copybig(SCM b
, int sign
)
876 scm_sizet i
= SCM_NUMDIGS(b
);
877 SCM ans
= scm_mkbig(i
, sign
);
878 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
879 while (i
--) dst
[i
] = src
[i
];
895 SCM ans
= scm_mkbig(SCM_DIGSPERLONG
, n
<0);
896 digits
= SCM_BDIGITS(ans
);
898 while (i
< SCM_DIGSPERLONG
) {
899 digits
[i
++] = SCM_BIGLO(n
);
900 n
= SCM_BIGDN((unsigned long)n
);
908 scm_long_long2big(long_long n
)
923 if ((long long)tn
== n
)
924 return scm_long2big (tn
);
930 for (tn
= n
, n_digits
= 0;
932 ++n_digits
, tn
= SCM_BIGDN ((ulong_long
)tn
))
937 ans
= scm_mkbig(n_digits
, n
<0);
938 digits
= SCM_BDIGITS(ans
);
941 while (i
< n_digits
) {
942 digits
[i
++] = SCM_BIGLO(n
);
943 n
= SCM_BIGDN((ulong_long
)n
);
951 scm_2ulong2big(unsigned long * np
)
963 ans
= scm_mkbig(2 * SCM_DIGSPERLONG
, 0);
964 digits
= SCM_BDIGITS(ans
);
967 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
969 digits
[i
] = SCM_BIGLO(n
);
970 n
= SCM_BIGDN((unsigned long)n
);
973 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
975 digits
[i
+ SCM_DIGSPERLONG
] = SCM_BIGLO(n
);
976 n
= SCM_BIGDN((unsigned long)n
);
984 scm_ulong2big(unsigned long n
)
993 SCM ans
= scm_mkbig(SCM_DIGSPERLONG
, 0);
994 digits
= SCM_BDIGITS(ans
);
995 while (i
< SCM_DIGSPERLONG
) {
996 digits
[i
++] = SCM_BIGLO(n
);
1005 scm_bigcomp(SCM x
, SCM y
)
1013 int xsign
= SCM_BIGSIGN(x
);
1014 int ysign
= SCM_BIGSIGN(y
);
1015 scm_sizet xlen
, ylen
;
1016 if (ysign
< xsign
) return 1;
1017 if (ysign
> xsign
) return -1;
1018 if ((ylen
= SCM_NUMDIGS(y
)) > (xlen
= SCM_NUMDIGS(x
))) return (xsign
) ? -1 : 1;
1019 if (ylen
< xlen
) return (xsign
) ? 1 : -1;
1020 while(xlen
-- && (SCM_BDIGITS(y
)[xlen
]==SCM_BDIGITS(x
)[xlen
]));
1021 if (-1==xlen
) return 0;
1022 return (SCM_BDIGITS(y
)[xlen
] > SCM_BDIGITS(x
)[xlen
]) ?
1023 (xsign
? -1 : 1) : (xsign
? 1 : -1);
1026 #ifndef SCM_DIGSTOOBIG
1030 scm_pseudolong(long x
)
1039 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1043 while (i
< SCM_DIGSPERLONG
) {p
.bd
[i
++] = SCM_BIGLO(x
); x
= SCM_BIGDN(x
);}
1044 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1052 scm_longdigs(long x
, SCM_BIGDIG digs
[])
1055 scm_longdigs(x
, digs
)
1062 while (i
< SCM_DIGSPERLONG
) {digs
[i
++] = SCM_BIGLO(x
); x
= SCM_BIGDN(x
);}
1069 scm_addbig(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int sgny
)
1072 scm_addbig(x
, nx
, xsgn
, bigy
, sgny
)
1080 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1081 /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */
1083 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
1084 SCM z
= scm_copybig(bigy
, SCM_BIGSIGN(bigy
) ^ sgny
);
1085 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
1086 if (xsgn
^ SCM_BIGSIGN(z
)) {
1088 num
+= (long) zds
[i
] - x
[i
];
1089 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
1090 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
1092 if (num
&& nx
==ny
) {
1094 SCM_CAR(z
) ^= 0x0100;
1096 num
+= (SCM_BIGRAD
-1) - zds
[i
];
1097 zds
[i
++] = SCM_BIGLO(num
);
1098 num
= SCM_BIGDN(num
);
1101 else while (i
< ny
) {
1103 if (num
< 0) {zds
[i
++] = num
+ SCM_BIGRAD
; num
= -1;}
1104 else {zds
[i
++] = SCM_BIGLO(num
); num
= 0;}
1108 num
+= (long) zds
[i
] + x
[i
];
1109 zds
[i
++] = SCM_BIGLO(num
);
1110 num
= SCM_BIGDN(num
);
1115 zds
[i
++] = SCM_BIGLO(num
);
1116 num
= SCM_BIGDN(num
);
1119 if (num
) {z
= scm_adjbig(z
, ny
+1); SCM_BDIGITS(z
)[ny
] = num
; return z
;}
1121 return scm_normbig(z
);
1126 scm_mulbig(SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
)
1129 scm_mulbig(x
, nx
, y
, ny
, sgn
)
1137 scm_sizet i
= 0, j
= nx
+ ny
;
1138 unsigned long n
= 0;
1139 SCM z
= scm_mkbig(j
, sgn
);
1140 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
1141 while (j
--) zds
[j
] = 0;
1146 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1147 zds
[i
+ j
++] = SCM_BIGLO(n
);
1150 if (n
) {zds
[i
+ j
] = n
; n
= 0;}
1153 return scm_normbig(z
);
1158 scm_divbigdig(SCM_BIGDIG
*ds
, scm_sizet h
, SCM_BIGDIG div
)
1161 scm_divbigdig(ds
, h
, div
)
1167 register unsigned long t2
= 0;
1169 t2
= SCM_BIGUP(t2
) + ds
[h
];
1179 scm_divbigint(SCM x
, long z
, int sgn
, int mode
)
1182 scm_divbigint(x
, z
, sgn
, mode
)
1190 if (z
< SCM_BIGRAD
) {
1191 register unsigned long t2
= 0;
1192 register SCM_BIGDIG
*ds
= SCM_BDIGITS(x
);
1193 scm_sizet nd
= SCM_NUMDIGS(x
);
1194 while(nd
--) t2
= (SCM_BIGUP(t2
) + ds
[nd
]) % z
;
1195 if (mode
) t2
= z
- t2
;
1196 return SCM_MAKINUM(sgn
? -t2
: t2
);
1199 #ifndef SCM_DIGSTOOBIG
1200 unsigned long t2
= scm_pseudolong(z
);
1201 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), (SCM_BIGDIG
*)&t2
,
1202 SCM_DIGSPERLONG
, sgn
, mode
);
1204 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1205 scm_longdigs(z
, t2
);
1206 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), t2
, SCM_DIGSPERLONG
, sgn
, mode
);
1213 scm_divbigbig(SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
)
1216 scm_divbigbig(x
, nx
, y
, ny
, sgn
, modes
)
1225 /* modes description
1229 3 quotient but returns 0 if division is not exact. */
1230 scm_sizet i
= 0, j
= 0;
1232 unsigned long t2
= 0;
1234 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1235 /* algorithm requires nx >= ny */
1238 case 0: /* remainder -- just return x */
1239 z
= scm_mkbig(nx
, sgn
); zds
= SCM_BDIGITS(z
);
1240 do {zds
[i
] = x
[i
];} while (++i
< nx
);
1242 case 1: /* scm_modulo -- return y-x */
1243 z
= scm_mkbig(ny
, sgn
); zds
= SCM_BDIGITS(z
);
1245 num
+= (long) y
[i
] - x
[i
];
1246 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
1247 else {zds
[i
] = num
; num
= 0;}
1251 if (num
< 0) {zds
[i
++] = num
+ SCM_BIGRAD
; num
= -1;}
1252 else {zds
[i
++] = num
; num
= 0;}
1255 case 2: return SCM_INUM0
; /* quotient is zero */
1256 case 3: return 0; /* the division is not exact */
1259 z
= scm_mkbig(nx
==ny
? nx
+2 : nx
+1, sgn
); zds
= SCM_BDIGITS(z
);
1260 if (nx
==ny
) zds
[nx
+1] = 0;
1261 while(!y
[ny
-1]) ny
--; /* in case y came in as a psuedolong */
1262 if (y
[ny
-1] < (SCM_BIGRAD
>>1)) { /* normalize operands */
1263 d
= SCM_BIGRAD
/(y
[ny
-1]+1);
1264 newy
= scm_mkbig(ny
, 0); yds
= SCM_BDIGITS(newy
);
1266 {t2
+= (unsigned long) y
[j
]*d
; yds
[j
++] = SCM_BIGLO(t2
); t2
= SCM_BIGDN(t2
);}
1267 y
= yds
; j
= 0; t2
= 0;
1269 {t2
+= (unsigned long) x
[j
]*d
; zds
[j
++] = SCM_BIGLO(t2
); t2
= SCM_BIGDN(t2
);}
1272 else {zds
[j
= nx
] = 0; while (j
--) zds
[j
] = x
[j
];}
1273 j
= nx
==ny
? nx
+1 : nx
; /* dividend needs more digits than divisor */
1274 do { /* loop over digits of quotient */
1275 if (zds
[j
]==y
[ny
-1]) qhat
= SCM_BIGRAD
-1;
1276 else qhat
= (SCM_BIGUP(zds
[j
]) + zds
[j
-1])/y
[ny
-1];
1277 if (!qhat
) continue;
1278 i
= 0; num
= 0; t2
= 0;
1279 do { /* multiply and subtract */
1280 t2
+= (unsigned long) y
[i
] * qhat
;
1281 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO(t2
);
1282 if (num
< 0) {zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
; num
= -1;}
1283 else {zds
[j
- ny
+ i
] = num
; num
= 0;}
1286 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1287 while (num
) { /* "add back" required */
1288 i
= 0; num
= 0; qhat
--;
1290 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1291 zds
[j
- ny
+ i
] = SCM_BIGLO(num
);
1292 num
= SCM_BIGDN(num
);
1296 if (modes
& 2) zds
[j
] = qhat
;
1297 } while (--j
>= ny
);
1299 case 3: /* check that remainder==0 */
1300 for(j
= ny
;j
&& !zds
[j
-1];--j
) ; if (j
) return 0;
1301 case 2: /* move quotient down in z */
1302 j
= (nx
==ny
? nx
+2 : nx
+1) - ny
;
1303 for (i
= 0;i
< j
;i
++) zds
[i
] = zds
[i
+ny
];
1306 case 1: /* subtract for scm_modulo */
1307 i
= 0; num
= 0; j
= 0;
1308 do {num
+= y
[i
] - zds
[i
];
1310 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
1311 else {zds
[i
] = num
; num
= 0;}
1313 if (!j
) return SCM_INUM0
;
1314 case 0: /* just normalize remainder */
1315 if (d
) scm_divbigdig(zds
, ny
, d
);
1318 for(j
= ny
;j
&& !zds
[j
-1];--j
) ;
1319 if (j
* SCM_BITSPERDIG
<= sizeof(SCM
)*SCM_CHAR_BIT
)
1320 if SCM_INUMP(z
= scm_big2inum(z
, j
)) return z
;
1321 return scm_adjbig(z
, j
);
1329 /*** NUMBERS -> STRINGS ***/
1332 static double fx
[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1333 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1334 5e-11,5e-12,5e-13,5e-14,5e-15,
1335 5e-16,5e-17,5e-18,5e-19,5e-20};
1341 idbl2str(double f
, char *a
)
1349 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1353 if (f
== 0.0) goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
1354 if (f
< 0.0) {f
= -f
;a
[ch
++]='-';}
1359 if (ch
== 0) a
[ch
++]='+';
1360 funny
: a
[ch
++]='#'; a
[ch
++]='.'; a
[ch
++]='#'; return ch
;
1362 # ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1363 make-uniform-vector, from causing infinite loops. */
1364 while (f
< 1.0) {f
*= 10.0; if (exp
-- < DBL_MIN_10_EXP
) goto funny
;}
1365 while (f
> 10.0) {f
*= 0.10; if (exp
++ > DBL_MAX_10_EXP
) goto funny
;}
1367 while (f
< 1.0) {f
*= 10.0; exp
--;}
1368 while (f
> 10.0) {f
/= 10.0; exp
++;}
1370 if (f
+fx
[wp
] >= 10.0) {f
= 1.0; exp
++;}
1377 efmt
= (exp
< -3) || (exp
> wp
+2);
1383 while (++dpt
) a
[ch
++] = '0';
1394 if (f
< fx
[wp
]) break;
1395 if (f
+fx
[wp
] >= 1.0) {
1400 if (!(--dpt
)) a
[ch
++] = '.';
1405 if ((dpt
> 4) && (exp
> 6)) {
1406 d
= (a
[0]=='-'?2:1);
1407 for (i
= ch
++; i
> d
; i
--)
1414 while (--dpt
) a
[ch
++] = '0';
1417 if (a
[ch
-1]=='.') a
[ch
++]='0'; /* trailing zero */
1424 for (i
= 10; i
<= exp
; i
*= 10);
1425 for (i
/= 10; i
; i
/= 10) {
1426 a
[ch
++] = exp
/i
+ '0';
1435 iflo2str(SCM flt
, char *str
)
1445 if SCM_SINGP(flt
) i
= idbl2str(SCM_FLO(flt
), str
);
1448 i
= idbl2str(SCM_REAL(flt
), str
);
1450 if(0 <= SCM_IMAG(flt
)) /* jeh */
1451 str
[i
++] = '+'; /* jeh */
1452 i
+= idbl2str(SCM_IMAG(flt
), &str
[i
]);
1457 #endif /* SCM_FLOATS */
1461 scm_iint2str(long num
, int rad
, char *p
)
1464 scm_iint2str(num
, rad
, p
)
1471 register int i
= 1, d
;
1472 register long n
= num
;
1473 if (n
< 0) {n
= -n
; i
++;}
1474 for (n
/= rad
;n
> 0;n
/= rad
) i
++;
1477 if (n
< 0) {n
= -n
; *p
++ = '-'; i
--;}
1481 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
1490 big2str(SCM b
, register unsigned int radix
)
1495 register unsigned int radix
;
1498 SCM t
= scm_copybig(b
, 0); /* sign of temp doesn't matter */
1499 register SCM_BIGDIG
*ds
= SCM_BDIGITS(t
);
1500 scm_sizet i
= SCM_NUMDIGS(t
);
1501 scm_sizet j
= radix
==16 ? (SCM_BITSPERDIG
*i
)/4+2
1502 : radix
>= 10 ? (SCM_BITSPERDIG
*i
*241L)/800+2
1503 : (SCM_BITSPERDIG
*i
)+2;
1505 scm_sizet radct
= 0;
1506 scm_sizet ch
; /* jeh */
1507 SCM_BIGDIG radpow
= 1, radmod
= 0;
1508 SCM ss
= scm_makstr((long)j
, 0);
1509 char *s
= SCM_CHARS(ss
), c
;
1510 while ((long) radpow
* radix
< SCM_BIGRAD
) {
1514 s
[0] = scm_tc16_bigneg
==SCM_TYP16(b
) ? '-' : '+';
1515 while ((i
|| radmod
) && j
) {
1517 radmod
= (SCM_BIGDIG
)scm_divbigdig(ds
, i
, radpow
);
1521 c
= radmod
% radix
; radmod
/= radix
; k
--;
1522 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
1524 ch
= s
[0] == '-' ? 1 : 0; /* jeh */
1525 if (ch
< j
) { /* jeh */
1526 for(i
= j
;j
< SCM_LENGTH(ss
);j
++) s
[ch
+j
-i
] = s
[j
]; /* jeh */
1527 scm_vector_set_length_x(ss
, (SCM
)SCM_MAKINUM(ch
+SCM_LENGTH(ss
)-i
)); /* jeh */
1534 SCM_PROC(s_number_to_string
, "number->string", 1, 1, 0, scm_number_to_string
);
1537 scm_number_to_string(SCM x
, SCM radix
)
1540 scm_number_to_string(x
, radix
)
1545 if SCM_UNBNDP(radix
) radix
=SCM_MAKINUM(10L);
1546 else SCM_ASSERT(SCM_INUMP(radix
), radix
, SCM_ARG2
, s_number_to_string
);
1549 char num_buf
[SCM_FLOBUFLEN
];
1551 SCM_ASRTGO(SCM_NIMP(x
), badx
);
1552 if SCM_BIGP(x
) return big2str(x
, (unsigned int)SCM_INUM(radix
));
1554 if (!(SCM_INEXP(x
)))
1555 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_number_to_string
);
1558 SCM_ASSERT(SCM_NIMP(x
) && SCM_INEXP(x
), x
, SCM_ARG1
, s_number_to_string
);
1560 return scm_makfromstr(num_buf
, iflo2str(x
, num_buf
), 0);
1565 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_number_to_string
);
1566 return big2str(x
, (unsigned int)SCM_INUM(radix
));
1569 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_number_to_string
);
1573 char num_buf
[SCM_INTBUFLEN
];
1574 return scm_makfromstr(num_buf
,
1575 scm_iint2str(SCM_INUM(x
), (int)SCM_INUM(radix
), num_buf
), 0);
1580 /* These print routines are stubbed here so that scm_repl.c doesn't need
1581 SCM_FLOATS or SCM_BIGDIGs conditionals */
1584 scm_floprint(SCM sexp
, SCM port
, scm_print_state
*pstate
)
1587 scm_floprint(sexp
, port
, pstate
)
1590 scm_print_state
*pstate
;
1594 char num_buf
[SCM_FLOBUFLEN
];
1595 scm_gen_write (scm_regular_string
, num_buf
, iflo2str(sexp
, num_buf
), port
);
1597 scm_ipruk("float", sexp
, port
);
1605 scm_bigprint(SCM exp
, SCM port
, scm_print_state
*pstate
)
1608 scm_bigprint(exp
, port
, pstate
)
1611 scm_print_state
*pstate
;
1615 exp
= big2str(exp
, (unsigned int)10);
1616 scm_gen_write (scm_regular_string
, SCM_CHARS(exp
), (scm_sizet
)SCM_LENGTH(exp
), port
);
1618 scm_ipruk("bignum", exp
, port
);
1622 /*** END nums->strs ***/
1624 /*** STRINGS -> NUMBERS ***/
1627 scm_small_istr2int(str
, len
, radix
)
1632 register long n
= 0, ln
;
1636 if (0 >= len
) return SCM_BOOL_F
; /* zero scm_length */
1637 switch (*str
) { /* leading sign */
1638 case '-': lead_neg
= 1;
1639 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1643 switch (c
= str
[i
++]) {
1647 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1650 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1653 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1656 /* Negation is a workaround for HP700 cc bug */
1657 if (n
> ln
|| (-n
> -SCM_MOST_NEGATIVE_FIXNUM
)) goto ovfl
;
1660 return SCM_BOOL_F
; /* not a digit */
1663 if (!lead_neg
) if ((n
= -n
) > SCM_MOST_POSITIVE_FIXNUM
) goto ovfl
;
1664 return SCM_MAKINUM(n
);
1665 ovfl
: /* overflow scheme integer */
1672 scm_istr2int(char *str
, long len
, long radix
)
1675 scm_istr2int(str
, len
, radix
)
1682 register scm_sizet k
, blen
= 1;
1686 register SCM_BIGDIG
*ds
;
1687 register unsigned long t2
;
1689 if (0 >= len
) return SCM_BOOL_F
; /* zero scm_length */
1691 /* Short numbers we parse directly into an int, to avoid the overhead
1692 of creating a bignum. */
1694 return scm_small_istr2int (str
, len
, radix
);
1696 if (16==radix
) j
= 1+(4*len
*sizeof(char))/(SCM_BITSPERDIG
);
1697 else if (10 <= radix
)
1698 j
= 1+(84*len
*sizeof(char))/(SCM_BITSPERDIG
*25);
1699 else j
= 1+(len
*sizeof(char))/(SCM_BITSPERDIG
);
1700 switch (str
[0]) { /* leading sign */
1702 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1704 res
= scm_mkbig(j
, '-'==str
[0]);
1705 ds
= SCM_BDIGITS(res
);
1706 for (k
= j
;k
--;) ds
[k
] = 0;
1708 switch (c
= str
[i
++]) {
1712 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1715 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1718 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1723 /* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/
1725 ds
[k
++] = SCM_BIGLO(t2
);
1729 scm_num_overflow ("bignum");
1730 if (t2
) {blen
++; goto moretodo
;}
1733 return SCM_BOOL_F
; /* not a digit */
1736 if (blen
* SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
))
1737 if SCM_INUMP(res
= scm_big2inum(res
, blen
)) return res
;
1738 if (j
==blen
) return res
;
1739 return scm_adjbig(res
, blen
);
1745 scm_istr2flo(char *str
, long len
, long radix
)
1748 scm_istr2flo(str
, len
, radix
)
1754 register int c
, i
= 0;
1756 double res
= 0.0, tmp
= 0.0;
1761 if (i
>= len
) return SCM_BOOL_F
; /* zero scm_length */
1763 switch (*str
) { /* leading sign */
1764 case '-': lead_sgn
= -1.0; i
++; break;
1765 case '+': lead_sgn
= 1.0; i
++; break;
1766 default : lead_sgn
= 0.0;
1768 if (i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1770 if (str
[i
]=='i' || str
[i
]=='I') { /* handle `+i' and `-i' */
1771 if (lead_sgn
==0.0) return SCM_BOOL_F
; /* must have leading sign */
1772 if (++i
< len
) return SCM_BOOL_F
; /* `i' not last character */
1773 return scm_makdbl(0.0, lead_sgn
);
1775 do { /* check initial digits */
1776 switch (c
= str
[i
]) {
1780 case 'D': case 'E': case 'F':
1781 if (radix
==10) goto out1
; /* must be exponent */
1782 case 'A': case 'B': case 'C':
1785 case 'd': case 'e': case 'f':
1786 if (radix
==10) goto out1
;
1787 case 'a': case 'b': case 'c':
1790 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1791 res
= res
* radix
+ c
;
1792 flg
= 1; /* res is valid */
1797 } while (++i
< len
);
1800 /* if true, then we did see a digit above, and res is valid */
1801 if (i
==len
) goto done
;
1803 /* By here, must have seen a digit,
1804 or must have next char be a `.' with radix==10 */
1806 if (!(str
[i
]=='.' && radix
==10))
1809 while (str
[i
]=='#') { /* optional sharps */
1811 if (++i
==len
) goto done
;
1816 switch (c
= str
[i
]) {
1820 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1823 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1826 if (c
>= radix
) return SCM_BOOL_F
;
1827 tmp
= tmp
* radix
+ c
;
1834 if (tmp
==0.0) return SCM_BOOL_F
; /* `slash zero' not allowed */
1836 while (str
[i
]=='#') { /* optional sharps */
1838 if (++i
==len
) break;
1844 if (str
[i
]=='.') { /* decimal point notation */
1845 if (radix
!= 10) return SCM_BOOL_F
; /* must be radix 10 */
1847 switch (c
= str
[i
]) {
1850 res
= res
*10.0 + c
-'0';
1858 if (!flg
) return SCM_BOOL_F
; /* no digits before or after decimal point */
1859 if (i
==len
) goto adjust
;
1860 while (str
[i
]=='#') { /* ignore remaining sharps */
1861 if (++i
==len
) goto adjust
;
1865 switch (str
[i
]) { /* exponent */
1870 case 's': case 'S': {
1871 int expsgn
= 1, expon
= 0;
1872 if (radix
!= 10) return SCM_BOOL_F
; /* only in radix 10 */
1873 if (++i
==len
) return SCM_BOOL_F
; /* bad exponent */
1875 case '-': expsgn
=(-1);
1876 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad exponent */
1878 if (str
[i
] < '0' || str
[i
] > '9') return SCM_BOOL_F
; /* bad exponent */
1880 switch (c
= str
[i
]) {
1882 expon
= expon
*10 + c
-'0';
1883 if (expon
> MAXEXP
) return SCM_BOOL_F
; /* exponent too large */
1888 } while (++i
< len
);
1890 point
+= expsgn
*expon
;
1896 while (point
--) res
*= 10.0;
1899 while (point
++) res
*= 0.1;
1901 while (point
++) res
/= 10.0;
1905 /* at this point, we have a legitimate floating point result */
1906 if (lead_sgn
==-1.0) res
= -res
;
1907 if (i
==len
) return scm_makdbl(res
, 0.0);
1909 if (str
[i
]=='i' || str
[i
]=='I') { /* pure imaginary number */
1910 if (lead_sgn
==0.0) return SCM_BOOL_F
; /* must have leading sign */
1911 if (++i
< len
) return SCM_BOOL_F
; /* `i' not last character */
1912 return scm_makdbl(0.0, res
);
1916 case '-': lead_sgn
= -1.0; break;
1917 case '+': lead_sgn
= 1.0; break;
1918 case '@': { /* polar input for complex number */
1919 /* get a `real' for scm_angle */
1920 second
= scm_istr2flo(&str
[i
], (long)(len
-i
), radix
);
1921 if (!(SCM_INEXP(second
))) return SCM_BOOL_F
; /* not `real' */
1922 if (SCM_CPLXP(second
)) return SCM_BOOL_F
; /* not `real' */
1923 tmp
= SCM_REALPART(second
);
1924 return scm_makdbl(res
*cos(tmp
), res
*sin(tmp
));
1926 default: return SCM_BOOL_F
;
1929 /* at this point, last char must be `i' */
1930 if (str
[len
-1] != 'i' && str
[len
-1] != 'I') return SCM_BOOL_F
;
1931 /* handles `x+i' and `x-i' */
1932 if (i
==(len
-1)) return scm_makdbl(res
, lead_sgn
);
1933 /* get a `ureal' for complex part */
1934 second
= scm_istr2flo(&str
[i
], (long)((len
-i
)-1), radix
);
1935 if (!(SCM_INEXP(second
))) return SCM_BOOL_F
; /* not `ureal' */
1936 if (SCM_CPLXP(second
)) return SCM_BOOL_F
; /* not `ureal' */
1937 tmp
= SCM_REALPART(second
);
1938 if (tmp
< 0.0) return SCM_BOOL_F
; /* not `ureal' */
1939 return scm_makdbl(res
, (lead_sgn
*tmp
));
1941 #endif /* SCM_FLOATS */
1946 scm_istring2number(char *str
, long len
, long radix
)
1949 scm_istring2number(str
, len
, radix
)
1957 char ex_p
= 0, rx_p
= 0; /* Only allow 1 exactness and 1 radix prefix */
1960 if (*str
=='+' || *str
=='-') /* Catches lone `+' and `-' for speed */
1963 while ((len
-i
) >= 2 && str
[i
]=='#' && ++i
)
1965 case 'b': case 'B': if (rx_p
++) return SCM_BOOL_F
; radix
= 2; break;
1966 case 'o': case 'O': if (rx_p
++) return SCM_BOOL_F
; radix
= 8; break;
1967 case 'd': case 'D': if (rx_p
++) return SCM_BOOL_F
; radix
= 10; break;
1968 case 'x': case 'X': if (rx_p
++) return SCM_BOOL_F
; radix
= 16; break;
1969 case 'i': case 'I': if (ex_p
++) return SCM_BOOL_F
; ex
= 2; break;
1970 case 'e': case 'E': if (ex_p
++) return SCM_BOOL_F
; ex
= 1; break;
1971 default: return SCM_BOOL_F
;
1976 return scm_istr2int(&str
[i
], len
-i
, radix
);
1978 res
= scm_istr2int(&str
[i
], len
-i
, radix
);
1979 if SCM_NFALSEP(res
) return res
;
1981 case 2: return scm_istr2flo(&str
[i
], len
-i
, radix
);
1988 SCM_PROC(s_string_to_number
, "string->number", 1, 1, 0, scm_string_to_number
);
1991 scm_string_to_number(SCM str
, SCM radix
)
1994 scm_string_to_number(str
, radix
)
2000 if SCM_UNBNDP(radix
) radix
=SCM_MAKINUM(10L);
2001 else SCM_ASSERT(SCM_INUMP(radix
), radix
, SCM_ARG2
, s_string_to_number
);
2002 SCM_ASSERT(SCM_NIMP(str
) && SCM_ROSTRINGP(str
), str
, SCM_ARG1
, s_string_to_number
);
2003 answer
= scm_istring2number(SCM_ROCHARS(str
), SCM_ROLENGTH(str
), SCM_INUM(radix
));
2004 return scm_return_first (answer
, str
);
2006 /*** END strs->nums ***/
2011 scm_makdbl (double x
, double y
)
2020 if ((y
==0.0) && (x
==0.0)) return scm_flo0
;
2026 # ifndef SCM_SINGLESONLY
2027 if ((-FLTMAX
< x
) && (x
< FLTMAX
) && (fx
==x
))
2030 SCM_CAR(z
) = scm_tc_flo
;
2035 # endif/* def SCM_SINGLES */
2036 SCM_CDR(z
) = (SCM
)scm_must_malloc(1L*sizeof(double), "real");
2037 SCM_CAR(z
) = scm_tc_dblr
;
2040 SCM_CDR(z
) = (SCM
)scm_must_malloc(2L*sizeof(double), "complex");
2041 SCM_CAR(z
) = scm_tc_dblc
;
2053 scm_bigequal(SCM x
, SCM y
)
2062 if (0==scm_bigcomp(x
, y
)) return SCM_BOOL_T
;
2070 scm_floequal(SCM x
, SCM y
)
2079 if (SCM_REALPART(x
) != SCM_REALPART(y
)) return SCM_BOOL_F
;
2080 if (!(SCM_CPLXP(x
) && (SCM_IMAG(x
) != SCM_IMAG(y
)))) return SCM_BOOL_T
;
2088 SCM_PROC(s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2089 SCM_PROC(s_complex_p
, "complex?", 1, 0, 0, scm_number_p
);
2099 if SCM_INUMP(x
) return SCM_BOOL_T
;
2101 if (SCM_NIMP(x
) && SCM_NUMP(x
)) return SCM_BOOL_T
;
2104 if (SCM_NIMP(x
) && SCM_NUMP(x
)) return SCM_BOOL_T
;
2113 SCM_PROC(s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2114 SCM_PROC(s_rational_p
, "rational?", 1, 0, 0, scm_real_p
);
2139 SCM_PROC(s_int_p
, "int?", 1, 0, 0, scm_int_p
);
2150 if SCM_INUMP(x
) return SCM_BOOL_T
;
2151 if SCM_IMP(x
) return SCM_BOOL_F
;
2153 if SCM_BIGP(x
) return SCM_BOOL_T
;
2155 if (!SCM_INEXP(x
)) return SCM_BOOL_F
;
2156 if SCM_CPLXP(x
) return SCM_BOOL_F
;
2157 r
= SCM_REALPART(x
);
2158 if (r
==floor(r
)) return SCM_BOOL_T
;
2164 #endif /* SCM_FLOATS */
2166 SCM_PROC(s_inexact_p
, "inexact?", 1, 0, 0, scm_inexact_p
);
2169 scm_inexact_p(SCM x
)
2177 if (SCM_NIMP(x
) && SCM_INEXP(x
)) return SCM_BOOL_T
;
2185 SCM_PROC1 (s_eq_p
, "=?", scm_tc7_rpsubr
, scm_num_eq_p
);
2188 scm_num_eq_p (SCM x
, SCM y
)
2202 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_eq_p
);
2205 if SCM_INUMP(y
) return SCM_BOOL_F
;
2206 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2207 if SCM_BIGP(y
) return (0==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2208 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2210 return (SCM_REALP(y
) && (scm_big2dbl(x
)==SCM_REALPART(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2212 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2214 SCM_ASSERT(SCM_NIMP(x
) && SCM_INEXP(x
), x
, SCM_ARG1
, s_eq_p
);
2216 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto realint
;}
2218 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2219 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
2220 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2222 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2224 if (SCM_REALPART(x
) != SCM_REALPART(y
)) return SCM_BOOL_F
;
2226 return (SCM_CPLXP(y
) && (SCM_IMAG(x
)==SCM_IMAG(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2227 return SCM_CPLXP(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
2231 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2232 if SCM_BIGP(y
) return SCM_BOOL_F
;
2234 if (!(SCM_INEXP(y
)))
2235 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2239 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2240 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2244 return (SCM_REALP(y
) && (((double)SCM_INUM(x
))==SCM_REALPART(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2249 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_eq_p
);
2250 if SCM_INUMP(y
) return SCM_BOOL_F
;
2251 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2252 return (0==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2256 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2257 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2262 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_eq_p
);
2263 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_eq_p
);
2266 return ((long)x
==(long)y
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2271 SCM_PROC1 (s_less_p
, "<?", scm_tc7_rpsubr
, scm_less_p
);
2274 scm_less_p(SCM x
, SCM y
)
2287 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_less_p
);
2290 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2291 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2292 if SCM_BIGP(y
) return (1==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2293 SCM_ASRTGO(SCM_REALP(y
), bady
);
2294 return (scm_big2dbl(x
) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2296 SCM_ASRTGO(SCM_REALP(x
), badx
);
2298 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_less_p
);
2301 return (SCM_REALPART(x
) < ((double)SCM_INUM(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2303 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2304 if SCM_BIGP(y
) return (SCM_REALPART(x
) < scm_big2dbl(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2305 SCM_ASRTGO(SCM_REALP(y
), bady
);
2307 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2309 return (SCM_REALPART(x
) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2313 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2314 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
2316 if (!(SCM_REALP(y
)))
2317 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2321 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2322 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2325 return (((double)SCM_INUM(x
)) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2330 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_less_p
);
2331 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2332 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2333 return (1==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2337 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2338 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2340 return SCM_BIGSIGN(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
2343 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_less_p
);
2344 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_less_p
);
2347 return ((long)x
< (long)y
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2351 SCM_PROC1 (s_gr_p
, ">?", scm_tc7_rpsubr
, scm_gr_p
);
2354 scm_gr_p(SCM x
, SCM y
)
2362 return scm_less_p(y
, x
);
2367 SCM_PROC1 (s_leq_p
, "<=?", scm_tc7_rpsubr
, scm_leq_p
);
2370 scm_leq_p(SCM x
, SCM y
)
2378 return SCM_BOOL_NOT(scm_less_p(y
, x
));
2383 SCM_PROC1 (s_geq_p
, ">=?", scm_tc7_rpsubr
, scm_geq_p
);
2386 scm_geq_p(SCM x
, SCM y
)
2394 return SCM_BOOL_NOT(scm_less_p(x
, y
));
2399 SCM_PROC(s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
);
2412 SCM_ASRTGO(SCM_NIMP(z
), badz
);
2413 if SCM_BIGP(z
) return SCM_BOOL_F
;
2415 if (!(SCM_INEXP(z
)))
2416 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_zero_p
);
2419 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_zero_p
);
2421 return (z
==scm_flo0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2426 SCM_ASSERT(SCM_NIMP(z
) && SCM_BIGP(z
), z
, SCM_ARG1
, s_zero_p
);
2430 SCM_ASSERT(SCM_INUMP(z
), z
, SCM_ARG1
, s_zero_p
);
2433 return (z
==SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2438 SCM_PROC(s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
);
2441 scm_positive_p(SCM x
)
2451 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2452 if SCM_BIGP(x
) return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_T
: SCM_BOOL_F
;
2454 if (!(SCM_REALP(x
)))
2455 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_positive_p
);
2458 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_positive_p
);
2460 return (SCM_REALPART(x
) > 0.0) ? SCM_BOOL_T
: SCM_BOOL_F
;
2465 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_positive_p
);
2466 return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_T
: SCM_BOOL_F
;
2469 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_positive_p
);
2472 return (x
> SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2477 SCM_PROC(s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
);
2480 scm_negative_p(SCM x
)
2490 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2491 if SCM_BIGP(x
) return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_F
: SCM_BOOL_T
;
2493 if (!(SCM_REALP(x
)))
2494 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_negative_p
);
2497 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_negative_p
);
2499 return (SCM_REALPART(x
) < 0.0) ? SCM_BOOL_T
: SCM_BOOL_F
;
2504 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_negative_p
);
2505 return (SCM_TYP16(x
)==scm_tc16_bigneg
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2508 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_negative_p
);
2511 return (x
< SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2515 SCM_PROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
);
2518 scm_max(SCM x
, SCM y
)
2531 if (!(SCM_NUMBERP(x
)))
2532 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_max
);
2539 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2541 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? y
: x
;
2542 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2543 if SCM_BIGP(y
) return (1==scm_bigcomp(x
, y
)) ? y
: x
;
2544 SCM_ASRTGO(SCM_REALP(y
), bady
);
2546 return (z
< SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2548 SCM_ASRTGO(SCM_REALP(x
), badx
);
2550 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_max
);
2553 return (SCM_REALPART(x
) < (z
= SCM_INUM(y
))) ? scm_makdbl(z
, 0.0) : x
;
2555 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2557 return (SCM_REALPART(x
) < (z
= scm_big2dbl(y
))) ? scm_makdbl(z
, 0.0) : x
;
2558 SCM_ASRTGO(SCM_REALP(y
), bady
);
2560 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2562 return (SCM_REALPART(x
) < SCM_REALPART(y
)) ? y
: x
;
2566 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2567 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? x
: y
;
2569 if (!(SCM_REALP(y
)))
2570 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2574 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2575 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2578 return ((z
= SCM_INUM(x
)) < SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2583 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_max
);
2584 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? y
: x
;
2585 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2586 return (1==scm_bigcomp(x
, y
)) ? y
: x
;
2590 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2591 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2593 return SCM_BIGSIGN(y
) ? x
: y
;
2596 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_max
);
2597 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_max
);
2600 return ((long)x
< (long)y
) ? y
: x
;
2606 SCM_PROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
);
2609 scm_min(SCM x
, SCM y
)
2622 if (!(SCM_NUMBERP(x
)))
2623 badx
:scm_wta(x
, (char *)SCM_ARG1
, s_min
);
2630 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2632 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? x
: y
;
2633 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2634 if SCM_BIGP(y
) return (-1==scm_bigcomp(x
, y
)) ? y
: x
;
2635 SCM_ASRTGO(SCM_REALP(y
), bady
);
2637 return (z
> SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2639 SCM_ASRTGO(SCM_REALP(x
), badx
);
2641 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_min
);
2643 if SCM_INUMP(y
) return (SCM_REALPART(x
) > (z
= SCM_INUM(y
))) ? scm_makdbl(z
, 0.0) : x
;
2645 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2646 if SCM_BIGP(y
) return (SCM_REALPART(x
) > (z
= scm_big2dbl(y
))) ? scm_makdbl(z
, 0.0) : x
;
2647 SCM_ASRTGO(SCM_REALP(y
), bady
);
2649 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2651 return (SCM_REALPART(x
) > SCM_REALPART(y
)) ? y
: x
;
2655 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2656 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? y
: x
;
2658 if (!(SCM_REALP(y
)))
2659 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2663 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2664 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2667 return ((z
= SCM_INUM(x
)) > SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2672 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_min
);
2673 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? x
: y
;
2674 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2675 return (-1==scm_bigcomp(x
, y
)) ? y
: x
;
2679 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2680 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2682 return SCM_BIGSIGN(y
) ? y
: x
;
2685 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_min
);
2686 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_min
);
2689 return ((long)x
> (long)y
) ? y
: x
;
2695 SCM_PROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
);
2698 scm_sum(SCM x
, SCM y
)
2707 if SCM_UNBNDP(x
) return SCM_INUM0
;
2709 if (!(SCM_NUMBERP(x
)))
2710 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_sum
);
2718 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2720 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2721 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2723 if (SCM_NUMDIGS(x
) > SCM_NUMDIGS(y
)) {t
= x
; x
= y
; y
= t
;}
2724 return scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0);
2726 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2727 bigreal
: return scm_makdbl(scm_big2dbl(x
)+SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_IMAG(y
):0.0);
2729 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2731 SCM_ASRTGO(SCM_NIMP(x
) && SCM_INEXP(x
), badx
);
2733 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intreal
;}
2735 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2736 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
2738 else if (!(SCM_INEXP(y
)))
2739 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2743 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2744 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2748 if SCM_CPLXP(x
) i
= SCM_IMAG(x
);
2749 if SCM_CPLXP(y
) i
+= SCM_IMAG(y
);
2750 return scm_makdbl(SCM_REALPART(x
)+SCM_REALPART(y
), i
); }
2754 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2757 # ifndef SCM_DIGSTOOBIG
2758 long z
= scm_pseudolong(SCM_INUM(x
));
2759 return scm_addbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2761 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2762 scm_longdigs(SCM_INUM(x
), zdigs
);
2763 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2766 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2768 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2770 intreal
: return scm_makdbl(SCM_INUM(x
)+SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_IMAG(y
):0.0);
2776 SCM_ASRTGO(SCM_NIMP(x
) && SCM_BIGP(x
), badx
);
2777 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2778 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2779 if (SCM_NUMDIGS(x
) > SCM_NUMDIGS(y
)) {t
= x
; x
= y
; y
= t
;}
2780 return scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0);
2784 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2785 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2788 # ifndef SCM_DIGSTOOBIG
2789 long z
= scm_pseudolong(SCM_INUM(x
));
2790 return scm_addbig(&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2792 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2793 scm_longdigs(SCM_INUM(x
), zdigs
);
2794 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2799 SCM_ASRTGO(SCM_INUMP(x
), badx
);
2800 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_sum
);
2803 x
= SCM_INUM(x
)+SCM_INUM(y
);
2804 if SCM_FIXABLE(x
) return SCM_MAKINUM(x
);
2806 return scm_long2big(x
);
2809 return scm_makdbl((double)x
, 0.0);
2811 scm_num_overflow (s_sum
);
2812 return SCM_UNSPECIFIED
;
2820 SCM_PROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
);
2823 scm_difference(SCM x
, SCM y
)
2826 scm_difference(x
, y
)
2835 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_difference
);
2840 x
= scm_copybig(x
, !SCM_BIGSIGN(x
));
2841 return SCM_NUMDIGS(x
) * SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
) ?
2842 scm_big2inum(x
, SCM_NUMDIGS(x
)) : x
;
2845 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2846 return scm_makdbl(-SCM_REALPART(x
), SCM_CPLXP(x
)?-SCM_IMAG(x
):0.0);
2848 if SCM_INUMP(y
) return scm_sum(x
, SCM_MAKINUM(-SCM_INUM(y
)));
2850 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2852 if SCM_BIGP(y
) return (SCM_NUMDIGS(x
) < SCM_NUMDIGS(y
)) ?
2853 scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0x0100) :
2854 scm_addbig(SCM_BDIGITS(y
), SCM_NUMDIGS(y
), SCM_BIGSIGN(y
) ^ 0x0100, x
, 0);
2855 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2856 return scm_makdbl(scm_big2dbl(x
)-SCM_REALPART(y
), SCM_CPLXP(y
)?-SCM_IMAG(y
):0.0);
2858 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2859 if SCM_BIGP(y
) return scm_makdbl(SCM_REALPART(x
)-scm_big2dbl(y
), SCM_CPLXP(x
)?SCM_IMAG(x
):0.0);
2860 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2862 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2863 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2867 return scm_makdbl(SCM_REAL(x
)-SCM_REAL(y
), SCM_IMAG(x
)-SCM_IMAG(y
));
2869 return scm_makdbl(SCM_REAL(x
)-SCM_REALPART(y
), SCM_IMAG(x
));
2870 return scm_makdbl(SCM_REALPART(x
)-SCM_REALPART(y
), SCM_CPLXP(y
)?-SCM_IMAG(y
):0.0);
2872 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2875 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2877 # ifndef SCM_DIGSTOOBIG
2878 long z
= scm_pseudolong(SCM_INUM(x
));
2879 return scm_addbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2881 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2882 scm_longdigs(SCM_INUM(x
), zdigs
);
2883 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2887 if (!(SCM_INEXP(y
)))
2888 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2892 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2893 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2896 return scm_makdbl(SCM_INUM(x
)-SCM_REALPART(y
), SCM_CPLXP(y
)?-SCM_IMAG(y
):0.0);
2901 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_difference
);
2903 x
= scm_copybig(x
, !SCM_BIGSIGN(x
));
2904 return SCM_NUMDIGS(x
) * SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
) ?
2905 scm_big2inum(x
, SCM_NUMDIGS(x
)) : x
;
2908 # ifndef SCM_DIGSTOOBIG
2909 long z
= scm_pseudolong(SCM_INUM(y
));
2910 return scm_addbig(&z
, SCM_DIGSPERLONG
, (y
< 0) ? 0 : 0x0100, x
, 0);
2912 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2913 scm_longdigs(SCM_INUM(x
), zdigs
);
2914 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (y
< 0) ? 0 : 0x0100, x
, 0);
2917 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2918 return (SCM_NUMDIGS(x
) < SCM_NUMDIGS(y
)) ?
2919 scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0x0100) :
2920 scm_addbig(SCM_BDIGITS(y
), SCM_NUMDIGS(y
), SCM_BIGSIGN(y
) ^ 0x0100, x
, 0);
2922 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2925 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2926 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2929 # ifndef SCM_DIGSTOOBIG
2930 long z
= scm_pseudolong(SCM_INUM(x
));
2931 return scm_addbig(&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2933 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2934 scm_longdigs(SCM_INUM(x
), zdigs
);
2935 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2940 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_difference
);
2941 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2942 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_difference
);
2945 x
= SCM_INUM(x
)-SCM_INUM(y
);
2947 if SCM_FIXABLE(x
) return SCM_MAKINUM(x
);
2949 return scm_long2big(x
);
2952 return scm_makdbl((double)x
, 0.0);
2954 scm_num_overflow (s_difference
);
2955 return SCM_UNSPECIFIED
;
2963 SCM_PROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
);
2966 scm_product(SCM x
, SCM y
)
2975 if SCM_UNBNDP(x
) return SCM_MAKINUM(1L);
2977 if (!(SCM_NUMBERP(x
)))
2978 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_product
);
2986 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2988 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2989 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2990 if SCM_BIGP(y
) return scm_mulbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2991 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
));
2992 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2994 double bg
= scm_big2dbl(x
);
2995 return scm_makdbl(bg
*SCM_REALPART(y
), SCM_CPLXP(y
)?bg
*SCM_IMAG(y
):0.0); }
2997 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2999 SCM_ASRTGO(SCM_NIMP(x
) && SCM_INEXP(x
), badx
);
3001 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intreal
;}
3003 SCM_ASRTGO(SCM_NIMP(y
), bady
);
3004 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
3006 else if (!(SCM_INEXP(y
)))
3007 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
3011 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
3012 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
3017 return scm_makdbl(SCM_REAL(x
)*SCM_REAL(y
)-SCM_IMAG(x
)*SCM_IMAG(y
),
3018 SCM_REAL(x
)*SCM_IMAG(y
)+SCM_IMAG(x
)*SCM_REAL(y
));
3020 return scm_makdbl(SCM_REAL(x
)*SCM_REALPART(y
), SCM_IMAG(x
)*SCM_REALPART(y
));
3021 return scm_makdbl(SCM_REALPART(x
)*SCM_REALPART(y
),
3022 SCM_CPLXP(y
)?SCM_REALPART(x
)*SCM_IMAG(y
):0.0);
3026 SCM_ASRTGO(SCM_NIMP(y
), bady
);
3028 intbig
: if (SCM_INUM0
==x
) return x
; if (SCM_MAKINUM(1L)==x
) return y
;
3030 # ifndef SCM_DIGSTOOBIG
3031 long z
= scm_pseudolong(SCM_INUM(x
));
3032 return scm_mulbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3033 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
3035 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3036 scm_longdigs(SCM_INUM(x
), zdigs
);
3037 return scm_mulbig(zdigs
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3038 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
3042 SCM_ASRTGO(SCM_INEXP(y
), bady
);
3044 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
3046 intreal
: return scm_makdbl(SCM_INUM(x
)*SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_INUM(x
)*SCM_IMAG(y
):0.0);
3051 SCM_ASRTGO(SCM_NIMP(x
) && SCM_BIGP(x
), badx
);
3052 if SCM_INUMP(y
) {SCM t
= x
; x
= y
; y
= t
; goto intbig
;}
3053 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
3054 return scm_mulbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3055 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
));
3059 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
3060 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
3062 intbig
: if (SCM_INUM0
==x
) return x
; if (SCM_MAKINUM(1L)==x
) return y
;
3064 # ifndef SCM_DIGSTOOBIG
3065 long z
= scm_pseudolong(SCM_INUM(x
));
3066 return scm_mulbig(&z
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3067 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
3069 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3070 scm_longdigs(SCM_INUM(x
), zdigs
);
3071 return scm_mulbig(zdigs
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3072 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
3077 SCM_ASRTGO(SCM_INUMP(x
), badx
);
3078 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_product
);
3088 if (k
!= SCM_INUM(y
) || k
/i
!= j
)
3090 { int sgn
= (i
< 0) ^ (j
< 0);
3091 # ifndef SCM_DIGSTOOBIG
3092 i
= scm_pseudolong(i
);
3093 j
= scm_pseudolong(j
);
3094 return scm_mulbig((SCM_BIGDIG
*)&i
, SCM_DIGSPERLONG
,
3095 (SCM_BIGDIG
*)&j
, SCM_DIGSPERLONG
, sgn
);
3096 # else /* SCM_DIGSTOOBIG */
3097 SCM_BIGDIG idigs
[SCM_DIGSPERLONG
];
3098 SCM_BIGDIG jdigs
[SCM_DIGSPERLONG
];
3099 scm_longdigs(i
, idigs
);
3100 scm_longdigs(j
, jdigs
);
3101 return scm_mulbig(idigs
, SCM_DIGSPERLONG
, jdigs
, SCM_DIGSPERLONG
, sgn
);
3106 return scm_makdbl(((double)i
)*((double)j
), 0.0);
3108 scm_num_overflow (s_product
);
3118 scm_num2dbl (SCM a
, char * why
)
3121 scm_num2dbl (a
, why
)
3127 return (double) SCM_INUM (a
);
3129 SCM_ASSERT (SCM_NIMP (a
), a
, "wrong type argument", why
);
3131 return (SCM_REALPART (a
));
3134 return scm_big2dbl (a
);
3136 SCM_ASSERT (0, a
, "wrong type argument", why
);
3137 return SCM_UNSPECIFIED
;
3141 SCM_PROC(s_fuck
, "fuck", 1, 0, 0, scm_fuck
);
3151 return scm_makdbl (scm_num2dbl (a
, "just because"), 0.0);
3154 SCM_PROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
);
3157 scm_divide(SCM x
, SCM y
)
3170 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_divide
);
3174 if SCM_BIGP(x
) return scm_makdbl(1.0/scm_big2dbl(x
), 0.0);
3176 SCM_ASRTGO(SCM_INEXP(x
), badx
);
3177 if SCM_REALP(x
) return scm_makdbl(1.0/SCM_REALPART(x
), 0.0);
3178 r
= SCM_REAL(x
); i
= SCM_IMAG(x
); d
= r
*r
+i
*i
;
3179 return scm_makdbl(r
/d
, -i
/d
);
3188 scm_num_overflow (s_divide
);
3192 if (z
< SCM_BIGRAD
) {
3193 SCM w
= scm_copybig(x
, SCM_BIGSIGN(x
) ? (y
>0) : (y
<0));
3194 return scm_divbigdig(SCM_BDIGITS(w
), SCM_NUMDIGS(w
), (SCM_BIGDIG
)z
) ?
3195 scm_makdbl(scm_big2dbl(x
)/SCM_INUM(y
), 0.0) : scm_normbig(w
);
3197 # ifndef SCM_DIGSTOOBIG
3198 z
= scm_pseudolong(z
);
3199 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), (SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
3200 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);
3202 { SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3203 scm_longdigs(z
, zdigs
);
3204 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), zdigs
, SCM_DIGSPERLONG
,
3205 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);}
3207 return z
? z
: scm_makdbl(scm_big2dbl(x
)/SCM_INUM(y
), 0.0);
3209 SCM_ASRTGO(SCM_NIMP(y
), bady
);
3211 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3212 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
), 3);
3213 return z
? z
: scm_makdbl(scm_big2dbl(x
)/scm_big2dbl(y
), 0.0);
3215 SCM_ASRTGO(SCM_INEXP(y
), bady
);
3216 if SCM_REALP(y
) return scm_makdbl(scm_big2dbl(x
)/SCM_REALPART(y
), 0.0);
3221 SCM_ASRTGO(SCM_INEXP(x
), badx
);
3222 if SCM_INUMP(y
) {d
= SCM_INUM(y
); goto basic_div
;}
3224 SCM_ASRTGO(SCM_NIMP(y
), bady
);
3225 if SCM_BIGP(y
) {d
= scm_big2dbl(y
); goto basic_div
;}
3226 SCM_ASRTGO(SCM_INEXP(y
), bady
);
3228 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
3231 d
= SCM_REALPART(y
);
3232 basic_div
: return scm_makdbl(SCM_REALPART(x
)/d
, SCM_CPLXP(x
)?SCM_IMAG(x
)/d
:0.0);
3234 a
= SCM_REALPART(x
);
3235 if SCM_REALP(x
) goto complex_div
;
3236 r
= SCM_REAL(y
); i
= SCM_IMAG(y
); d
= r
*r
+i
*i
;
3237 return scm_makdbl((a
*r
+SCM_IMAG(x
)*i
)/d
, (SCM_IMAG(x
)*r
-a
*i
)/d
);
3240 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
3241 return scm_makdbl(1.0/((double)SCM_INUM(x
)), 0.0);
3245 SCM_ASRTGO(SCM_NIMP(y
), bady
);
3246 if SCM_BIGP(y
) return scm_makdbl(SCM_INUM(x
)/scm_big2dbl(y
), 0.0);
3248 if (!(SCM_INEXP(y
)))
3249 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
3253 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
3254 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
3258 return scm_makdbl(SCM_INUM(x
)/SCM_REALPART(y
), 0.0);
3261 r
= SCM_REAL(y
); i
= SCM_IMAG(y
); d
= r
*r
+i
*i
;
3262 return scm_makdbl((a
*r
)/d
, (-a
*i
)/d
);
3268 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_divide
);
3269 if SCM_UNBNDP(y
) goto ov
;
3275 if (z
< SCM_BIGRAD
) {
3276 SCM w
= scm_copybig(x
, SCM_BIGSIGN(x
) ? (y
>0) : (y
<0));
3277 if (scm_divbigdig(SCM_BDIGITS(w
), SCM_NUMDIGS(w
), (SCM_BIGDIG
)z
)) goto ov
;
3280 # ifndef SCM_DIGSTOOBIG
3281 z
= scm_pseudolong(z
);
3282 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), &z
, SCM_DIGSPERLONG
,
3283 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);
3285 { SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3286 scm_longdigs(z
, zdigs
);
3287 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), zdigs
, SCM_DIGSPERLONG
,
3288 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);}
3291 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
3292 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3293 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
), 3);
3299 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
3304 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
3305 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
3310 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_divide
);
3312 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
3315 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_divide
);
3319 long z
= SCM_INUM(y
);
3320 if ((0==z
) || SCM_INUM(x
)%z
) goto ov
;
3322 if SCM_FIXABLE(z
) return SCM_MAKINUM(z
);
3324 return scm_long2big(z
);
3327 ov
: return scm_makdbl(((double)SCM_INUM(x
))/((double)SCM_INUM(y
)), 0.0);
3329 ov
: scm_num_overflow (s_divide
);
3330 return SCM_UNSPECIFIED
;
3339 SCM_PROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
);
3349 return log(x
+sqrt(x
*x
+1));
3355 SCM_PROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
);
3365 return log(x
+sqrt(x
*x
-1));
3371 SCM_PROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
);
3381 return 0.5*log((1+x
)/(1-x
));
3387 SCM_PROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
);
3390 scm_truncate(double x
)
3397 if (x
< 0.0) return -floor(-x
);
3403 SCM_PROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
);
3413 double plus_half
= x
+ 0.5;
3414 double result
= floor(plus_half
);
3415 /* Adjust so that the scm_round is towards even. */
3416 return (plus_half
== result
&& plus_half
/ 2 != floor(plus_half
/ 2))
3417 ? result
- 1 : result
;
3422 SCM_PROC1 (s_exact_to_inexact
, "exact->inexact", scm_tc7_cxr
, (SCM (*)()) scm_exact_to_inexact
);
3425 scm_exact_to_inexact(double z
)
3428 scm_exact_to_inexact(z
)
3436 SCM_PROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
);
3437 SCM_PROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
);
3438 SCM_PROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)())sqrt
);
3439 SCM_PROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)())fabs
);
3440 SCM_PROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)())exp
);
3441 SCM_PROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)())log
);
3442 SCM_PROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)())sin
);
3443 SCM_PROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)())cos
);
3444 SCM_PROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)())tan
);
3445 SCM_PROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)())asin
);
3446 SCM_PROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)())acos
);
3447 SCM_PROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)())atan
);
3448 SCM_PROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)())sinh
);
3449 SCM_PROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)())cosh
);
3450 SCM_PROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)())tanh
);
3452 struct dpair
{double x
, y
;};
3455 scm_two_doubles(z1
, z2
, sstring
, xy
)
3460 if SCM_INUMP(z1
) xy
->x
= SCM_INUM(z1
);
3463 SCM_ASRTGO(SCM_NIMP(z1
), badz1
);
3464 if SCM_BIGP(z1
) xy
->x
= scm_big2dbl(z1
);
3467 if (!(SCM_REALP(z1
)))
3468 badz1
: scm_wta(z1
, (char *)SCM_ARG1
, sstring
);
3470 xy
->x
= SCM_REALPART(z1
);}
3472 {SCM_ASSERT(SCM_NIMP(z1
) && SCM_REALP(z1
), z1
, SCM_ARG1
, sstring
);
3473 xy
->x
= SCM_REALPART(z1
);}
3476 if SCM_INUMP(z2
) xy
->y
= SCM_INUM(z2
);
3479 SCM_ASRTGO(SCM_NIMP(z2
), badz2
);
3480 if SCM_BIGP(z2
) xy
->y
= scm_big2dbl(z2
);
3483 if (!(SCM_REALP(z2
)))
3484 badz2
: scm_wta(z2
, (char *)SCM_ARG2
, sstring
);
3486 xy
->y
= SCM_REALPART(z2
);}
3488 {SCM_ASSERT(SCM_NIMP(z2
) && SCM_REALP(z2
), z2
, SCM_ARG2
, sstring
);
3489 xy
->y
= SCM_REALPART(z2
);}
3497 SCM_PROC(s_sys_expt
, "$expt", 2, 0, 0, scm_sys_expt
);
3500 scm_sys_expt(SCM z1
, SCM z2
)
3503 scm_sys_expt(z1
, z2
)
3509 scm_two_doubles(z1
, z2
, s_sys_expt
, &xy
);
3510 return scm_makdbl(pow(xy
.x
, xy
.y
), 0.0);
3515 SCM_PROC(s_sys_atan2
, "$atan2", 2, 0, 0, scm_sys_atan2
);
3518 scm_sys_atan2(SCM z1
, SCM z2
)
3521 scm_sys_atan2(z1
, z2
)
3527 scm_two_doubles(z1
, z2
, s_sys_atan2
, &xy
);
3528 return scm_makdbl(atan2(xy
.x
, xy
.y
), 0.0);
3533 SCM_PROC(s_make_rectangular
, "make-rectangular", 2, 0, 0, scm_make_rectangular
);
3536 scm_make_rectangular(SCM z1
, SCM z2
)
3539 scm_make_rectangular(z1
, z2
)
3545 scm_two_doubles(z1
, z2
, s_make_rectangular
, &xy
);
3546 return scm_makdbl(xy
.x
, xy
.y
);
3551 SCM_PROC(s_make_polar
, "make-polar", 2, 0, 0, scm_make_polar
);
3554 scm_make_polar(SCM z1
, SCM z2
)
3557 scm_make_polar(z1
, z2
)
3563 scm_two_doubles(z1
, z2
, s_make_polar
, &xy
);
3564 return scm_makdbl(xy
.x
*cos(xy
.y
), xy
.x
*sin(xy
.y
));
3570 SCM_PROC(s_real_part
, "real-part", 1, 0, 0, scm_real_part
);
3573 scm_real_part(SCM z
)
3582 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3583 if SCM_BIGP(z
) return z
;
3585 if (!(SCM_INEXP(z
)))
3586 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_real_part
);
3589 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_real_part
);
3591 if SCM_CPLXP(z
) return scm_makdbl(SCM_REAL(z
), 0.0);
3598 SCM_PROC(s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
);
3601 scm_imag_part(SCM z
)
3608 if SCM_INUMP(z
) return SCM_INUM0
;
3610 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3611 if SCM_BIGP(z
) return SCM_INUM0
;
3613 if (!(SCM_INEXP(z
)))
3614 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_imag_part
);
3617 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_imag_part
);
3619 if SCM_CPLXP(z
) return scm_makdbl(SCM_IMAG(z
), 0.0);
3625 SCM_PROC(s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
);
3628 scm_magnitude(SCM z
)
3635 if SCM_INUMP(z
) return scm_abs(z
);
3637 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3638 if SCM_BIGP(z
) return scm_abs(z
);
3640 if (!(SCM_INEXP(z
)))
3641 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_magnitude
);
3644 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_magnitude
);
3648 double i
= SCM_IMAG(z
), r
= SCM_REAL(z
);
3649 return scm_makdbl(sqrt(i
*i
+r
*r
), 0.0);
3651 return scm_makdbl(fabs(SCM_REALPART(z
)), 0.0);
3657 SCM_PROC(s_angle
, "angle", 1, 0, 0, scm_angle
);
3668 if SCM_INUMP(z
) {x
= (z
>=SCM_INUM0
) ? 1.0 : -1.0; goto do_angle
;}
3670 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3671 if SCM_BIGP(z
) {x
= (SCM_TYP16(z
)==scm_tc16_bigpos
) ? 1.0 : -1.0; goto do_angle
;}
3673 if (!(SCM_INEXP(z
))) {
3674 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_angle
);}
3677 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_angle
);
3681 x
= SCM_REALPART(z
);
3684 x
= SCM_REAL(z
); y
= SCM_IMAG(z
);
3686 return scm_makdbl(atan2(y
, x
), 0.0);
3690 SCM_PROC(s_inexact_to_exact
, "inexact->exact", 1, 0, 0, scm_inexact_to_exact
);
3693 scm_inexact_to_exact(SCM z
)
3696 scm_inexact_to_exact(z
)
3700 if SCM_INUMP(z
) return z
;
3702 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3703 if SCM_BIGP(z
) return z
;
3705 if (!(SCM_REALP(z
)))
3706 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_inexact_to_exact
);
3709 SCM_ASSERT(SCM_NIMP(z
) && SCM_REALP(z
), z
, SCM_ARG1
, s_inexact_to_exact
);
3713 double u
= floor(SCM_REALPART(z
)+0.5);
3714 if ((u
<= SCM_MOST_POSITIVE_FIXNUM
) && (-u
<= -SCM_MOST_NEGATIVE_FIXNUM
)) {
3715 /* Negation is a workaround for HP700 cc bug */
3716 SCM ans
= SCM_MAKINUM((long)u
);
3717 if (SCM_INUM(ans
)==(long)u
) return ans
;
3719 SCM_ASRTGO(!IS_INF(u
), badz
); /* problem? */
3720 return scm_dbl2big(u
);
3723 return SCM_MAKINUM((long)floor(SCM_REALPART(z
)+0.5));
3729 #else /* ~SCM_FLOATS */
3730 SCM_PROC(s_trunc
, "truncate", 1, 0, 0, scm_trunc
);
3740 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_truncate
);
3746 #endif /* SCM_FLOATS */
3750 /* d must be integer */
3753 scm_dbl2big(double d
)
3764 double u
= (d
< 0)?-d
:d
;
3765 while (0 != floor(u
)) {u
/= SCM_BIGRAD
;i
++;}
3766 ans
= scm_mkbig(i
, d
< 0);
3767 digits
= SCM_BDIGITS(ans
);
3776 scm_num_overflow ("dbl2big");
3793 scm_sizet i
= SCM_NUMDIGS(b
);
3794 SCM_BIGDIG
*digits
= SCM_BDIGITS(b
);
3795 while (i
--) ans
= digits
[i
] + SCM_BIGRAD
*ans
;
3796 if (scm_tc16_bigneg
==SCM_TYP16(b
)) return -ans
;
3804 scm_long2num(long sl
)
3811 if (!SCM_FIXABLE(sl
)) {
3813 return scm_long2big(sl
);
3816 return scm_makdbl((double) sl
, 0.0);
3822 return SCM_MAKINUM(sl
);
3829 scm_long_long2num(long_long sl
)
3832 scm_long_long2num(sl
)
3836 if (!SCM_FIXABLE(sl
)) {
3838 return scm_long_long2big(sl
);
3841 return scm_makdbl((double) sl
, 0.0);
3847 return SCM_MAKINUM(sl
);
3854 scm_ulong2num(unsigned long sl
)
3861 if (!SCM_POSFIXABLE(sl
)) {
3863 return scm_ulong2big(sl
);
3866 return scm_makdbl((double) sl
, 0.0);
3872 return SCM_MAKINUM(sl
);
3877 scm_num2long(SCM num
, char *pos
, char *s_caller
)
3880 scm_num2long(num
, pos
, s_caller
)
3889 res
= SCM_INUM(num
);
3892 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3896 double u
= SCM_REALPART(num
);
3898 if ((double)res
== u
)
3905 if (SCM_BIGP(num
)) {
3910 for(l
= SCM_NUMDIGS(num
);l
--;)
3912 res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
3917 if (SCM_TYP16 (num
) == scm_tc16_bigpos
)
3923 errout
: scm_wta(num
, pos
, s_caller
);
3924 return SCM_UNSPECIFIED
;
3932 num2long(SCM num
, char *pos
, char *s_caller
)
3935 num2long(num
, pos
, s_caller
)
3943 res
= SCM_INUM((long)num
);
3946 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3949 double u
= SCM_REALPART(num
);
3950 if (((SCM_MOST_NEGATIVE_FIXNUM
* 4) <= u
)
3951 && (u
<= (SCM_MOST_POSITIVE_FIXNUM
* 4 + 3))) {
3959 scm_sizet l
= SCM_NUMDIGS(num
);
3960 SCM_ASRTGO(SCM_DIGSPERLONG
>= l
, errout
);
3962 for(;l
--;) res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
3966 errout
: scm_wta(num
, pos
, s_caller
);
3967 return SCM_UNSPECIFIED
;
3974 scm_num2long_long(SCM num
, char *pos
, char *s_caller
)
3977 scm_num2long_long(num
, pos
, s_caller
)
3985 res
= SCM_INUM((long_long
)num
);
3988 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3991 double u
= SCM_REALPART(num
);
3992 if (((SCM_MOST_NEGATIVE_FIXNUM
* 4) <= u
)
3993 && (u
<= (SCM_MOST_POSITIVE_FIXNUM
* 4 + 3))) {
4001 scm_sizet l
= SCM_NUMDIGS(num
);
4002 SCM_ASRTGO(SCM_DIGSPERLONGLONG
>= l
, errout
);
4004 for(;l
--;) res
= SCM_LONGLONGBIGUP(res
) + SCM_BDIGITS(num
)[l
];
4008 errout
: scm_wta(num
, pos
, s_caller
);
4009 return SCM_UNSPECIFIED
;
4016 scm_num2ulong(SCM num
, char *pos
, char *s_caller
)
4019 scm_num2ulong(num
, pos
, s_caller
)
4028 res
= SCM_INUM((unsigned long)num
);
4031 SCM_ASRTGO(SCM_NIMP(num
), errout
);
4035 double u
= SCM_REALPART(num
);
4036 if ((0 <= u
) && (u
<= (unsigned long)~0L))
4044 if (SCM_BIGP(num
)) {
4045 unsigned long oldres
;
4049 for(l
= SCM_NUMDIGS(num
);l
--;)
4051 res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
4059 errout
: scm_wta(num
, pos
, s_caller
);
4060 return SCM_UNSPECIFIED
;
4066 static void add1(f
, fsum
)
4077 scm_init_numbers (void)
4084 SCM_NEWCELL(scm_flo0
);
4086 SCM_CAR(scm_flo0
) = scm_tc_flo
;
4087 SCM_FLO(scm_flo0
) = 0.0;
4089 SCM_CDR(scm_flo0
) = (SCM
)scm_must_malloc(1L*sizeof(double), "real");
4090 SCM_REAL(scm_flo0
) = 0.0;
4091 SCM_CAR(scm_flo0
) = scm_tc_dblr
;
4094 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4096 { /* determine floating point precision */
4098 double fsum
= 1.0+f
;
4099 while (fsum
!= 1.0) {
4101 if (++scm_dblprec
> 20) break;
4104 scm_dblprec
= scm_dblprec
-1;
4106 # endif /* DBL_DIG */
4108 #include "numbers.x"
HCoop / bpt / guile.git / blob