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.
49 #define DIGITS '0':case '1':case '2':case '3':case '4':\
50 case '5':case '6':case '7':case '8':case '9'
53 /* IS_INF tests its floating point number for infiniteness
56 # define IS_INF(x) ((x)==(x)/2)
59 /* MAXEXP is the maximum double precision expontent
60 * FLTMAX is less than or scm_equal the largest single precision float
67 # endif /* ndef GO32 */
68 # endif /* def STDC_HEADERS */
69 # ifdef DBL_MAX_10_EXP
70 # define MAXEXP DBL_MAX_10_EXP
72 # define MAXEXP 308 /* IEEE doubles */
73 # endif /* def DBL_MAX_10_EXP */
75 # define FLTMAX FLT_MAX
78 # endif /* def FLT_MAX */
79 #endif /* def SCM_FLOATS */
83 SCM_PROC(s_exact_p
, "exact?", 1, 0, 0, scm_exact_p
);
93 if SCM_INUMP(x
) return SCM_BOOL_T
;
95 if (SCM_NIMP(x
) && SCM_BIGP(x
)) return SCM_BOOL_T
;
100 SCM_PROC(s_odd_p
, "odd?", 1, 0, 0, scm_odd_p
);
112 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_odd_p
);
113 return (1 & SCM_BDIGITS(n
)[0]) ? SCM_BOOL_T
: SCM_BOOL_F
;
116 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_odd_p
);
118 return (4 & (int)n
) ? SCM_BOOL_T
: SCM_BOOL_F
;
121 SCM_PROC(s_even_p
, "even?", 1, 0, 0, scm_even_p
);
133 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_even_p
);
134 return (1 & SCM_BDIGITS(n
)[0]) ? SCM_BOOL_F
: SCM_BOOL_T
;
137 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_even_p
);
139 return (4 & (int)n
) ? SCM_BOOL_F
: SCM_BOOL_T
;
142 SCM_PROC(s_abs
, "abs", 1, 0, 0, scm_abs
);
154 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_abs
);
155 if (SCM_TYP16(x
)==scm_tc16_bigpos
) return x
;
156 return scm_copybig(x
, 0);
159 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_abs
);
161 if (SCM_INUM(x
) >= 0) return x
;
163 if (!SCM_POSSCM_FIXABLE(x
))
165 return scm_long2big(x
);
167 scm_wta(SCM_MAKINUM(-x
), (char *)SCM_OVSCM_FLOW
, s_abs
);
169 return SCM_MAKINUM(x
);
172 SCM_PROC(s_quotient
, "quotient", 2, 0, 0, scm_quotient
);
175 scm_quotient(SCM x
, SCM y
)
187 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_quotient
);
189 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
190 return scm_divbigbig(SCM_BDIGITS(x
),
194 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
),
201 if (z
< SCM_BIGRAD
) {
202 w
= scm_copybig(x
, SCM_BIGSIGN(x
) ? (y
>0) : (y
<0));
203 scm_divbigdig(SCM_BDIGITS(w
), SCM_NUMDIGS(w
), (SCM_BIGDIG
)z
);
204 return scm_normbig(w
);
206 #ifndef SCM_DIGSTOOBIG
207 w
= scm_pseudolong(z
);
208 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), (SCM_BIGDIG
*)&w
, SCM_DIGSPERLONG
,
209 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 2);
211 { SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
212 scm_longdigs(z
, zdigs
);
213 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), zdigs
, SCM_DIGSPERLONG
,
214 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 2);
220 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
221 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_quotient
);
226 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_quotient
);
227 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_quotient
);
229 if ((z
= SCM_INUM(y
))==0)
230 ov
: scm_wta(y
, (char *)SCM_OVSCM_FLOW
, s_quotient
);
235 long t
= ((y
<0) ? -SCM_INUM(x
) : SCM_INUM(x
))%SCM_INUM(y
);
237 long t
= SCM_INUM(x
)%SCM_INUM(y
);
248 return scm_long2big(z
);
250 scm_wta(x
, (char *)SCM_OVSCM_FLOW
, s_quotient
);
252 return SCM_MAKINUM(z
);
255 SCM_PROC(s_remainder
, "remainder", 2, 0, 0, scm_remainder
);
258 scm_remainder(SCM x
, SCM y
)
269 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_remainder
);
271 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
272 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
275 if (!(z
= SCM_INUM(y
))) goto ov
;
276 return scm_divbigint(x
, z
, SCM_BIGSIGN(x
), 0);
280 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
281 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_remainder
);
286 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_remainder
);
287 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_remainder
);
289 if (!(z
= SCM_INUM(y
)))
290 ov
: scm_wta(y
, (char *)SCM_OVSCM_FLOW
, s_remainder
);
299 else z
+= SCM_INUM(y
);
300 else if (x
< 0) z
-= SCM_INUM(y
);
302 return SCM_MAKINUM(z
);
305 SCM_PROC(s_modulo
, "modulo", 2, 0, 0, scm_modulo
);
308 scm_modulo(SCM x
, SCM y
)
319 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_modulo
);
321 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
322 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
323 SCM_BIGSIGN(y
), (SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
)) ? 1 : 0);
325 if (!(z
= SCM_INUM(y
))) goto ov
;
326 return scm_divbigint(x
, z
, y
< 0, (SCM_BIGSIGN(x
) ? (y
> 0) : (y
< 0)) ? 1 : 0);
330 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
331 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_modulo
);
333 return (SCM_BIGSIGN(y
) ? (x
>0) : (x
<0)) ? scm_sum(x
, y
) : x
;
336 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_modulo
);
337 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_modulo
);
339 if (!(yy
= SCM_INUM(y
)))
340 ov
: scm_wta(y
, (char *)SCM_OVSCM_FLOW
, s_modulo
);
343 z
= ((yy
<0) ? -z
: z
)%yy
;
347 return SCM_MAKINUM(((yy
<0) ? (z
>0) : (z
<0)) ? z
+yy
: z
);
350 SCM_PROC1 (s_gcd
, "gcd", scm_tc7_asubr
, scm_gcd
);
353 scm_gcd(SCM x
, SCM y
)
361 register long u
, v
, k
, t
;
362 if SCM_UNBNDP(y
) return SCM_UNBNDP(x
) ? SCM_INUM0
: x
;
367 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_gcd
);
368 if SCM_BIGSIGN(x
) x
= scm_copybig(x
, 0);
371 SCM_ASSERT(SCM_NIMP(y
) && SCM_BIGP(y
), y
, SCM_ARG2
, s_gcd
);
372 if SCM_BIGSIGN(y
) y
= scm_copybig(y
, 0);
373 switch (scm_bigcomp(x
, y
)) {
375 swaprec
: t
= scm_remainder(x
, y
); x
= y
; y
= t
; goto tailrec
;
377 case 1: y
= scm_remainder(y
, x
); goto newy
;
379 /* instead of the switch, we could just return scm_gcd(y, scm_modulo(x, y)); */
381 if (SCM_INUM0
==y
) return x
; goto swaprec
;
383 if SCM_NINUMP(y
) { t
=x
; x
=y
; y
=t
; goto big_gcd
;}
385 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_gcd
);
386 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_gcd
);
392 else if (0==v
) goto getout
;
393 if (0==u
) {u
= v
; goto getout
;}
394 for (k
= 1;!(1 & ((int)u
|(int)v
));k
<<= 1, u
>>= 1, v
>>= 1);
395 if (1 & (int)u
) t
= -v
;
401 if (!(1 & (int)t
)) goto b3
;
404 if ((t
= u
-v
)) goto b3
;
407 if (!SCM_POSSCM_FIXABLE(u
))
409 return scm_long2big(u
);
411 scm_wta(x
, (char *)SCM_OVSCM_FLOW
, s_gcd
);
413 return SCM_MAKINUM(u
);
416 SCM_PROC1 (s_lcm
, "lcm", scm_tc7_asubr
, scm_lcm
);
419 scm_lcm(SCM n1
, SCM n2
)
429 n2
= SCM_MAKINUM(1L);
430 if SCM_UNBNDP(n1
) return n2
;
433 if (SCM_INUM0
==d
) return d
;
434 return scm_abs(scm_product(n1
, scm_quotient(n2
, d
)));
439 # define scm_long2num SCM_MAKINUM
444 SCM_PROC1 (s_logand
, "logand", scm_tc7_asubr
, scm_logand
);
447 scm_logand(SCM n1
, SCM n2
)
455 return scm_long2num(scm_num2long(n1
, (char *)SCM_ARG1
, s_logand
)
456 & scm_num2long(n2
, (char *)SCM_ARG2
, s_logand
));
459 SCM_PROC1 (s_logior
, "logior", scm_tc7_asubr
, scm_logior
);
462 scm_logior(SCM n1
, SCM n2
)
470 return scm_long2num(scm_num2long(n1
, (char *)SCM_ARG1
, s_logior
)
471 | scm_num2long(n2
, (char *)SCM_ARG2
, s_logior
));
474 SCM_PROC1 (s_logxor
, "logxor", scm_tc7_asubr
, scm_logxor
);
477 scm_logxor(SCM n1
, SCM n2
)
485 return scm_long2num(scm_num2long(n1
, (char *)SCM_ARG1
, s_logxor
)
486 ^ scm_num2long(n2
, (char *)SCM_ARG2
, s_logxor
));
489 SCM_PROC(s_logtest
, "logtest", 2, 0, 0, scm_logtest
);
492 scm_logtest(SCM n1
, SCM n2
)
500 return ((scm_num2long (n1
, (char *)SCM_ARG1
, s_logtest
)
501 & scm_num2long (n2
, (char *)SCM_ARG2
, s_logtest
))
502 ? SCM_BOOL_T
: SCM_BOOL_F
);
506 SCM_PROC(s_logbit_p
, "logbit?", 2, 0, 0, scm_logbit_p
);
509 scm_logbit_p(SCM n1
, SCM n2
)
517 return (((1 << scm_num2long (n1
, (char *)SCM_ARG1
, s_logtest
))
518 & scm_num2long (n2
, (char *)SCM_ARG2
, s_logtest
))
519 ? SCM_BOOL_T
: SCM_BOOL_F
);
524 SCM_PROC1 (s_logand
, "logand", scm_tc7_asubr
, scm_logand
);
527 scm_logand(SCM n1
, SCM n2
)
535 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logand
);
536 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logand
);
537 return SCM_MAKINUM(SCM_INUM(n1
) & SCM_INUM(n2
));
540 SCM_PROC1 (s_logior
, "logior", scm_tc7_asubr
, scm_logior
);
543 scm_logior(SCM n1
, SCM n2
)
551 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logior
);
552 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logior
);
553 return SCM_MAKINUM(SCM_INUM(n1
) | SCM_INUM(n2
));
556 SCM_PROC1 (s_logxor
, "logxor", scm_tc7_asubr
, scm_logxor
);
559 scm_logxor(SCM n1
, SCM n2
)
567 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logxor
);
568 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logxor
);
569 return SCM_MAKINUM(SCM_INUM(n1
) ^ SCM_INUM(n2
));
572 SCM_PROC(s_logtest
, "logtest", 2, 0, 0, scm_logtest
);
575 scm_logtest(SCM n1
, SCM n2
)
583 SCM_ASSERT(SCM_INUMP(n1
), n1
, SCM_ARG1
, s_logtest
);
584 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logtest
);
585 return (SCM_INUM(n1
) & SCM_INUM(n2
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
588 SCM_PROC(s_logbit_p
, "logbit?", 2, 0, 0, scm_logbit_p
);
591 scm_logbit_p(SCM n1
, SCM n2
)
599 SCM_ASSERT(SCM_INUMP(n1
) && SCM_INUM(n1
) >= 0, n1
, SCM_ARG1
, s_logbit_p
);
600 SCM_ASSERT(SCM_INUMP(n2
), n2
, SCM_ARG2
, s_logbit_p
);
601 return ((1 << SCM_INUM(n1
)) & SCM_INUM(n2
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
605 SCM_PROC(s_lognot
, "lognot", 1, 0, 0, scm_lognot
);
615 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_lognot
);
616 return scm_difference(SCM_MAKINUM(-1L), n
);
619 SCM_PROC(s_integer_expt
, "integer-expt", 2, 0, 0, scm_integer_expt
);
622 scm_integer_expt(SCM z1
, SCM z2
)
625 scm_integer_expt(z1
, z2
)
630 SCM acc
= SCM_MAKINUM(1L);
632 if (SCM_INUM0
==z1
|| acc
==z1
) return z1
;
633 else if (SCM_MAKINUM(-1L)==z1
) return SCM_BOOL_F
==scm_even_p(z2
)?z1
:acc
;
635 SCM_ASSERT(SCM_INUMP(z2
), z2
, SCM_ARG2
, s_integer_expt
);
639 z1
= scm_divide(z1
, SCM_UNDEFINED
);
642 if (0==z2
) return acc
;
643 if (1==z2
) return scm_product(acc
, z1
);
644 if (z2
& 1) acc
= scm_product(acc
, z1
);
645 z1
= scm_product(z1
, z1
);
650 SCM_PROC(s_ash
, "ash", 2, 0, 0, scm_ash
);
653 scm_ash(SCM n
, SCM cnt
)
661 SCM res
= SCM_INUM(n
);
662 SCM_ASSERT(SCM_INUMP(cnt
), cnt
, SCM_ARG2
, s_ash
);
665 res
= scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(-SCM_INUM(cnt
)));
666 if (SCM_NFALSEP(scm_negative_p(n
)))
667 return scm_sum(SCM_MAKINUM(-1L), scm_quotient(scm_sum(SCM_MAKINUM(1L), n
), res
));
668 else return scm_quotient(n
, res
);
670 else return scm_product(n
, scm_integer_expt(SCM_MAKINUM(2), cnt
));
672 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_ash
);
674 if (cnt
< 0) return SCM_MAKINUM(SCM_SRS(res
, -cnt
));
675 res
= SCM_MAKINUM(res
<<cnt
);
676 if (SCM_INUM(res
)>>cnt
!= SCM_INUM(n
)) scm_wta(n
, (char *)SCM_OVSCM_FLOW
, s_ash
);
681 SCM_PROC(s_bit_extract
, "bit-extract", 3, 0, 0, scm_bit_extract
);
684 scm_bit_extract(SCM n
, SCM start
, SCM end
)
687 scm_bit_extract(n
, start
, end
)
693 SCM_ASSERT(SCM_INUMP(start
), start
, SCM_ARG2
, s_bit_extract
);
694 SCM_ASSERT(SCM_INUMP(end
), end
, SCM_ARG3
, s_bit_extract
);
695 start
= SCM_INUM(start
); end
= SCM_INUM(end
);
696 SCM_ASSERT(end
>= start
, SCM_MAKINUM(end
), SCM_OUTOFRANGE
, s_bit_extract
);
700 scm_logand(scm_difference(scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(end
- start
)),
702 scm_ash(n
, SCM_MAKINUM(-start
)));
704 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_bit_extract
);
706 return SCM_MAKINUM((SCM_INUM(n
)>>start
) & ((1L<<(end
-start
))-1));
709 char scm_logtab
[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
710 SCM_PROC(s_logcount
, "logcount", 1, 0, 0, scm_logcount
);
720 register unsigned long c
= 0;
724 scm_sizet i
; SCM_BIGDIG
*ds
, d
;
725 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_logcount
);
726 if SCM_BIGSIGN(n
) return scm_logcount(scm_difference(SCM_MAKINUM(-1L), n
));
728 for(i
= SCM_NUMDIGS(n
); i
--; )
729 for(d
= ds
[i
]; d
; d
>>= 4) c
+= scm_logtab
[15 & d
];
730 return SCM_MAKINUM(c
);
733 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_logcount
);
735 if ((nn
= SCM_INUM(n
)) < 0) nn
= -1 - nn
;
736 for(; nn
; nn
>>= 4) c
+= scm_logtab
[15 & nn
];
737 return SCM_MAKINUM(c
);
740 char scm_ilentab
[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4};
741 SCM_PROC(s_integer_length
, "integer-length", 1, 0, 0, scm_integer_length
);
744 scm_integer_length(SCM n
)
747 scm_integer_length(n
)
751 register unsigned long c
= 0;
757 SCM_ASSERT(SCM_NIMP(n
) && SCM_BIGP(n
), n
, SCM_ARG1
, s_integer_length
);
758 if SCM_BIGSIGN(n
) return scm_integer_length(scm_difference(SCM_MAKINUM(-1L), n
));
760 d
= ds
[c
= SCM_NUMDIGS(n
)-1];
761 for(c
*= SCM_BITSPERDIG
; d
; d
>>= 4) {c
+= 4; l
= scm_ilentab
[15 & d
];}
762 return SCM_MAKINUM(c
- 4 + l
);
765 SCM_ASSERT(SCM_INUMP(n
), n
, SCM_ARG1
, s_integer_length
);
767 if ((nn
= SCM_INUM(n
)) < 0) nn
= -1 - nn
;
768 for(;nn
; nn
>>= 4) {c
+= 4; l
= scm_ilentab
[15 & nn
];}
769 return SCM_MAKINUM(c
- 4 + l
);
774 char s_bignum
[] = "bignum";
777 scm_mkbig(scm_sizet nlen
, int sign
)
780 scm_mkbig(nlen
, sign
)
786 if (((v
<< 16) >> 16) != nlen
)
787 scm_wta(SCM_MAKINUM(nlen
), (char *)SCM_NALLOC
, s_bignum
);
790 SCM_SETCHARS(v
, scm_must_malloc((long)(nlen
*sizeof(SCM_BIGDIG
)), s_bignum
));
791 SCM_SETNUMDIGS(v
, nlen
, sign
?scm_tc16_bigneg
:scm_tc16_bigpos
);
798 scm_big2inum(SCM b
, scm_sizet l
)
806 unsigned long num
= 0;
807 SCM_BIGDIG
*tmp
= SCM_BDIGITS(b
);
808 while (l
--) num
= SCM_BIGUP(num
) + tmp
[l
];
809 if (SCM_TYP16(b
)==scm_tc16_bigpos
) {
810 if SCM_POSSCM_FIXABLE(num
) return SCM_MAKINUM(num
);
812 else if SCM_UNEGSCM_FIXABLE(num
) return SCM_MAKINUM(-num
);
817 char s_adjbig
[] = "scm_adjbig";
820 scm_adjbig(SCM b
, scm_sizet nlen
)
829 if (((nsiz
<< 16) >> 16) != nlen
) scm_wta(SCM_MAKINUM(nsiz
), (char *)SCM_NALLOC
, s_adjbig
);
831 SCM_SETCHARS(b
, (SCM_BIGDIG
*)scm_must_realloc((char *)SCM_CHARS(b
),
832 (long)(SCM_NUMDIGS(b
)*sizeof(SCM_BIGDIG
)),
833 (long)(nsiz
*sizeof(SCM_BIGDIG
)), s_adjbig
));
834 SCM_SETNUMDIGS(b
, nsiz
, SCM_TYP16(b
));
850 scm_sizet nlen
= SCM_NUMDIGS(b
);
852 int nlen
= SCM_NUMDIGS(b
); /* unsigned nlen breaks on Cray when nlen => 0 */
854 SCM_BIGDIG
*zds
= SCM_BDIGITS(b
);
855 while (nlen
-- && !zds
[nlen
]); nlen
++;
856 if (nlen
* SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
))
857 if SCM_INUMP(b
= scm_big2inum(b
, (scm_sizet
)nlen
)) return b
;
858 if (SCM_NUMDIGS(b
)==nlen
) return b
;
859 return scm_adjbig(b
, (scm_sizet
)nlen
);
865 scm_copybig(SCM b
, int sign
)
873 scm_sizet i
= SCM_NUMDIGS(b
);
874 SCM ans
= scm_mkbig(i
, sign
);
875 SCM_BIGDIG
*src
= SCM_BDIGITS(b
), *dst
= SCM_BDIGITS(ans
);
876 while (i
--) dst
[i
] = src
[i
];
892 SCM ans
= scm_mkbig(SCM_DIGSPERLONG
, n
<0);
893 digits
= SCM_BDIGITS(ans
);
895 while (i
< SCM_DIGSPERLONG
) {
896 digits
[i
++] = SCM_BIGLO(n
);
897 n
= SCM_BIGDN((unsigned long)n
);
905 scm_long_long2big(long_long n
)
920 if ((long long)tn
== n
)
921 return scm_long2big (tn
);
927 for (tn
= n
, n_digits
= 0;
929 ++n_digits
, tn
= SCM_BIGDN ((ulong_long
)tn
))
934 ans
= scm_mkbig(n_digits
, n
<0);
935 digits
= SCM_BDIGITS(ans
);
938 while (i
< n_digits
) {
939 digits
[i
++] = SCM_BIGLO(n
);
940 n
= SCM_BIGDN((ulong_long
)n
);
948 scm_2ulong2big(unsigned long * np
)
960 ans
= scm_mkbig(2 * SCM_DIGSPERLONG
, 0);
961 digits
= SCM_BDIGITS(ans
);
964 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
966 digits
[i
] = SCM_BIGLO(n
);
967 n
= SCM_BIGDN((unsigned long)n
);
970 for (i
= 0; i
< SCM_DIGSPERLONG
; ++i
)
972 digits
[i
+ SCM_DIGSPERLONG
] = SCM_BIGLO(n
);
973 n
= SCM_BIGDN((unsigned long)n
);
981 scm_ulong2big(unsigned long n
)
990 SCM ans
= scm_mkbig(SCM_DIGSPERLONG
, 0);
991 digits
= SCM_BDIGITS(ans
);
992 while (i
< SCM_DIGSPERLONG
) {
993 digits
[i
++] = SCM_BIGLO(n
);
1002 scm_bigcomp(SCM x
, SCM y
)
1010 int xsign
= SCM_BIGSIGN(x
);
1011 int ysign
= SCM_BIGSIGN(y
);
1012 scm_sizet xlen
, ylen
;
1013 if (ysign
< xsign
) return 1;
1014 if (ysign
> xsign
) return -1;
1015 if ((ylen
= SCM_NUMDIGS(y
)) > (xlen
= SCM_NUMDIGS(x
))) return (xsign
) ? -1 : 1;
1016 if (ylen
< xlen
) return (xsign
) ? 1 : -1;
1017 while(xlen
-- && (SCM_BDIGITS(y
)[xlen
]==SCM_BDIGITS(x
)[xlen
]));
1018 if (-1==xlen
) return 0;
1019 return (SCM_BDIGITS(y
)[xlen
] > SCM_BDIGITS(x
)[xlen
]) ?
1020 (xsign
? -1 : 1) : (xsign
? 1 : -1);
1023 #ifndef SCM_DIGSTOOBIG
1027 scm_pseudolong(long x
)
1036 SCM_BIGDIG bd
[SCM_DIGSPERLONG
];
1040 while (i
< SCM_DIGSPERLONG
) {p
.bd
[i
++] = SCM_BIGLO(x
); x
= SCM_BIGDN(x
);}
1041 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1049 scm_longdigs(long x
, SCM_BIGDIG digs
[])
1052 scm_longdigs(x
, digs
)
1059 while (i
< SCM_DIGSPERLONG
) {digs
[i
++] = SCM_BIGLO(x
); x
= SCM_BIGDN(x
);}
1066 scm_addbig(SCM_BIGDIG
*x
, scm_sizet nx
, int xsgn
, SCM bigy
, int sgny
)
1069 scm_addbig(x
, nx
, xsgn
, bigy
, sgny
)
1077 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1078 /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */
1080 scm_sizet i
= 0, ny
= SCM_NUMDIGS(bigy
);
1081 SCM z
= scm_copybig(bigy
, SCM_BIGSIGN(bigy
) ^ sgny
);
1082 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
1083 if (xsgn
^ SCM_BIGSIGN(z
)) {
1085 num
+= (long) zds
[i
] - x
[i
];
1086 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
1087 else {zds
[i
] = SCM_BIGLO(num
); num
= 0;}
1089 if (num
&& nx
==ny
) {
1091 SCM_CAR(z
) ^= 0x0100;
1093 num
+= (SCM_BIGRAD
-1) - zds
[i
];
1094 zds
[i
++] = SCM_BIGLO(num
);
1095 num
= SCM_BIGDN(num
);
1098 else while (i
< ny
) {
1100 if (num
< 0) {zds
[i
++] = num
+ SCM_BIGRAD
; num
= -1;}
1101 else {zds
[i
++] = SCM_BIGLO(num
); num
= 0;}
1105 num
+= (long) zds
[i
] + x
[i
];
1106 zds
[i
++] = SCM_BIGLO(num
);
1107 num
= SCM_BIGDN(num
);
1112 zds
[i
++] = SCM_BIGLO(num
);
1113 num
= SCM_BIGDN(num
);
1116 if (num
) {z
= scm_adjbig(z
, ny
+1); SCM_BDIGITS(z
)[ny
] = num
; return z
;}
1118 return scm_normbig(z
);
1123 scm_mulbig(SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
)
1126 scm_mulbig(x
, nx
, y
, ny
, sgn
)
1134 scm_sizet i
= 0, j
= nx
+ ny
;
1135 unsigned long n
= 0;
1136 SCM z
= scm_mkbig(j
, sgn
);
1137 SCM_BIGDIG
*zds
= SCM_BDIGITS(z
);
1138 while (j
--) zds
[j
] = 0;
1143 n
+= zds
[i
+ j
] + ((unsigned long) x
[i
] * y
[j
]);
1144 zds
[i
+ j
++] = SCM_BIGLO(n
);
1147 if (n
) {zds
[i
+ j
] = n
; n
= 0;}
1150 return scm_normbig(z
);
1155 scm_divbigdig(SCM_BIGDIG
*ds
, scm_sizet h
, SCM_BIGDIG div
)
1158 scm_divbigdig(ds
, h
, div
)
1164 register unsigned long t2
= 0;
1166 t2
= SCM_BIGUP(t2
) + ds
[h
];
1176 scm_divbigint(SCM x
, long z
, int sgn
, int mode
)
1179 scm_divbigint(x
, z
, sgn
, mode
)
1187 if (z
< SCM_BIGRAD
) {
1188 register unsigned long t2
= 0;
1189 register SCM_BIGDIG
*ds
= SCM_BDIGITS(x
);
1190 scm_sizet nd
= SCM_NUMDIGS(x
);
1191 while(nd
--) t2
= (SCM_BIGUP(t2
) + ds
[nd
]) % z
;
1192 if (mode
) t2
= z
- t2
;
1193 return SCM_MAKINUM(sgn
? -t2
: t2
);
1196 #ifndef SCM_DIGSTOOBIG
1197 unsigned long t2
= scm_pseudolong(z
);
1198 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), (SCM_BIGDIG
*)&t2
,
1199 SCM_DIGSPERLONG
, sgn
, mode
);
1201 SCM_BIGDIG t2
[SCM_DIGSPERLONG
];
1202 scm_longdigs(z
, t2
);
1203 return scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), t2
, SCM_DIGSPERLONG
, sgn
, mode
);
1210 scm_divbigbig(SCM_BIGDIG
*x
, scm_sizet nx
, SCM_BIGDIG
*y
, scm_sizet ny
, int sgn
, int modes
)
1213 scm_divbigbig(x
, nx
, y
, ny
, sgn
, modes
)
1222 /* modes description
1226 3 quotient but returns 0 if division is not exact. */
1227 scm_sizet i
= 0, j
= 0;
1229 unsigned long t2
= 0;
1231 SCM_BIGDIG d
= 0, qhat
, *zds
, *yds
;
1232 /* algorithm requires nx >= ny */
1235 case 0: /* remainder -- just return x */
1236 z
= scm_mkbig(nx
, sgn
); zds
= SCM_BDIGITS(z
);
1237 do {zds
[i
] = x
[i
];} while (++i
< nx
);
1239 case 1: /* scm_modulo -- return y-x */
1240 z
= scm_mkbig(ny
, sgn
); zds
= SCM_BDIGITS(z
);
1242 num
+= (long) y
[i
] - x
[i
];
1243 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
1244 else {zds
[i
] = num
; num
= 0;}
1248 if (num
< 0) {zds
[i
++] = num
+ SCM_BIGRAD
; num
= -1;}
1249 else {zds
[i
++] = num
; num
= 0;}
1252 case 2: return SCM_INUM0
; /* quotient is zero */
1253 case 3: return 0; /* the division is not exact */
1256 z
= scm_mkbig(nx
==ny
? nx
+2 : nx
+1, sgn
); zds
= SCM_BDIGITS(z
);
1257 if (nx
==ny
) zds
[nx
+1] = 0;
1258 while(!y
[ny
-1]) ny
--; /* in case y came in as a psuedolong */
1259 if (y
[ny
-1] < (SCM_BIGRAD
>>1)) { /* normalize operands */
1260 d
= SCM_BIGRAD
/(y
[ny
-1]+1);
1261 newy
= scm_mkbig(ny
, 0); yds
= SCM_BDIGITS(newy
);
1263 {t2
+= (unsigned long) y
[j
]*d
; yds
[j
++] = SCM_BIGLO(t2
); t2
= SCM_BIGDN(t2
);}
1264 y
= yds
; j
= 0; t2
= 0;
1266 {t2
+= (unsigned long) x
[j
]*d
; zds
[j
++] = SCM_BIGLO(t2
); t2
= SCM_BIGDN(t2
);}
1269 else {zds
[j
= nx
] = 0; while (j
--) zds
[j
] = x
[j
];}
1270 j
= nx
==ny
? nx
+1 : nx
; /* dividend needs more digits than divisor */
1271 do { /* loop over digits of quotient */
1272 if (zds
[j
]==y
[ny
-1]) qhat
= SCM_BIGRAD
-1;
1273 else qhat
= (SCM_BIGUP(zds
[j
]) + zds
[j
-1])/y
[ny
-1];
1274 if (!qhat
) continue;
1275 i
= 0; num
= 0; t2
= 0;
1276 do { /* multiply and subtract */
1277 t2
+= (unsigned long) y
[i
] * qhat
;
1278 num
+= zds
[j
- ny
+ i
] - SCM_BIGLO(t2
);
1279 if (num
< 0) {zds
[j
- ny
+ i
] = num
+ SCM_BIGRAD
; num
= -1;}
1280 else {zds
[j
- ny
+ i
] = num
; num
= 0;}
1283 num
+= zds
[j
- ny
+ i
] - t2
; /* borrow from high digit; don't update */
1284 while (num
) { /* "add back" required */
1285 i
= 0; num
= 0; qhat
--;
1287 num
+= (long) zds
[j
- ny
+ i
] + y
[i
];
1288 zds
[j
- ny
+ i
] = SCM_BIGLO(num
);
1289 num
= SCM_BIGDN(num
);
1293 if (modes
& 2) zds
[j
] = qhat
;
1294 } while (--j
>= ny
);
1296 case 3: /* check that remainder==0 */
1297 for(j
= ny
;j
&& !zds
[j
-1];--j
) ; if (j
) return 0;
1298 case 2: /* move quotient down in z */
1299 j
= (nx
==ny
? nx
+2 : nx
+1) - ny
;
1300 for (i
= 0;i
< j
;i
++) zds
[i
] = zds
[i
+ny
];
1303 case 1: /* subtract for scm_modulo */
1304 i
= 0; num
= 0; j
= 0;
1305 do {num
+= y
[i
] - zds
[i
];
1307 if (num
< 0) {zds
[i
] = num
+ SCM_BIGRAD
; num
= -1;}
1308 else {zds
[i
] = num
; num
= 0;}
1310 if (!j
) return SCM_INUM0
;
1311 case 0: /* just normalize remainder */
1312 if (d
) scm_divbigdig(zds
, ny
, d
);
1315 for(j
= ny
;j
&& !zds
[j
-1];--j
) ;
1316 if (j
* SCM_BITSPERDIG
<= sizeof(SCM
)*SCM_CHAR_BIT
)
1317 if SCM_INUMP(z
= scm_big2inum(z
, j
)) return z
;
1318 return scm_adjbig(z
, j
);
1326 /*** NUMBERS -> STRINGS ***/
1329 static double fx
[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1330 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1331 5e-11,5e-12,5e-13,5e-14,5e-15,
1332 5e-16,5e-17,5e-18,5e-19,5e-20};
1338 idbl2str(double f
, char *a
)
1346 int efmt
, dpt
, d
, i
, wp
= scm_dblprec
;
1350 if (f
== 0.0) goto zero
; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
1351 if (f
< 0.0) {f
= -f
;a
[ch
++]='-';}
1356 if (ch
== 0) a
[ch
++]='+';
1357 funny
: a
[ch
++]='#'; a
[ch
++]='.'; a
[ch
++]='#'; return ch
;
1359 # ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1360 make-uniform-vector, from causing infinite loops. */
1361 while (f
< 1.0) {f
*= 10.0; if (exp
-- < DBL_MIN_10_EXP
) goto funny
;}
1362 while (f
> 10.0) {f
*= 0.10; if (exp
++ > DBL_MAX_10_EXP
) goto funny
;}
1364 while (f
< 1.0) {f
*= 10.0; exp
--;}
1365 while (f
> 10.0) {f
/= 10.0; exp
++;}
1367 if (f
+fx
[wp
] >= 10.0) {f
= 1.0; exp
++;}
1374 efmt
= (exp
< -3) || (exp
> wp
+2);
1380 while (++dpt
) a
[ch
++] = '0';
1391 if (f
< fx
[wp
]) break;
1392 if (f
+fx
[wp
] >= 1.0) {
1397 if (!(--dpt
)) a
[ch
++] = '.';
1402 if ((dpt
> 4) && (exp
> 6)) {
1403 d
= (a
[0]=='-'?2:1);
1404 for (i
= ch
++; i
> d
; i
--)
1411 while (--dpt
) a
[ch
++] = '0';
1414 if (a
[ch
-1]=='.') a
[ch
++]='0'; /* trailing zero */
1421 for (i
= 10; i
<= exp
; i
*= 10);
1422 for (i
/= 10; i
; i
/= 10) {
1423 a
[ch
++] = exp
/i
+ '0';
1432 iflo2str(SCM flt
, char *str
)
1442 if SCM_SINGP(flt
) i
= idbl2str(SCM_FLO(flt
), str
);
1445 i
= idbl2str(SCM_REAL(flt
), str
);
1447 if(0 <= SCM_IMAG(flt
)) /* jeh */
1448 str
[i
++] = '+'; /* jeh */
1449 i
+= idbl2str(SCM_IMAG(flt
), &str
[i
]);
1454 #endif /* SCM_FLOATS */
1458 scm_iint2str(long num
, int rad
, char *p
)
1461 scm_iint2str(num
, rad
, p
)
1468 register int i
= 1, d
;
1469 register long n
= num
;
1470 if (n
< 0) {n
= -n
; i
++;}
1471 for (n
/= rad
;n
> 0;n
/= rad
) i
++;
1474 if (n
< 0) {n
= -n
; *p
++ = '-'; i
--;}
1478 p
[i
] = d
+ ((d
< 10) ? '0' : 'a' - 10);
1487 big2str(SCM b
, register unsigned int radix
)
1492 register unsigned int radix
;
1495 SCM t
= scm_copybig(b
, 0); /* sign of temp doesn't matter */
1496 register SCM_BIGDIG
*ds
= SCM_BDIGITS(t
);
1497 scm_sizet i
= SCM_NUMDIGS(t
);
1498 scm_sizet j
= radix
==16 ? (SCM_BITSPERDIG
*i
)/4+2
1499 : radix
>= 10 ? (SCM_BITSPERDIG
*i
*241L)/800+2
1500 : (SCM_BITSPERDIG
*i
)+2;
1502 scm_sizet radct
= 0;
1503 scm_sizet ch
; /* jeh */
1504 SCM_BIGDIG radpow
= 1, radmod
= 0;
1505 SCM ss
= scm_makstr((long)j
, 0);
1506 char *s
= SCM_CHARS(ss
), c
;
1507 while ((long) radpow
* radix
< SCM_BIGRAD
) {
1511 s
[0] = scm_tc16_bigneg
==SCM_TYP16(b
) ? '-' : '+';
1512 while ((i
|| radmod
) && j
) {
1514 radmod
= (SCM_BIGDIG
)scm_divbigdig(ds
, i
, radpow
);
1518 c
= radmod
% radix
; radmod
/= radix
; k
--;
1519 s
[--j
] = c
< 10 ? c
+ '0' : c
+ 'a' - 10;
1521 ch
= s
[0] == '-' ? 1 : 0; /* jeh */
1522 if (ch
< j
) { /* jeh */
1523 for(i
= j
;j
< SCM_LENGTH(ss
);j
++) s
[ch
+j
-i
] = s
[j
]; /* jeh */
1524 scm_vector_set_length_x(ss
, (SCM
)SCM_MAKINUM(ch
+SCM_LENGTH(ss
)-i
)); /* jeh */
1531 SCM_PROC(s_number_to_string
, "number->string", 1, 1, 0, scm_number_to_string
);
1534 scm_number_to_string(SCM x
, SCM radix
)
1537 scm_number_to_string(x
, radix
)
1542 if SCM_UNBNDP(radix
) radix
=SCM_MAKINUM(10L);
1543 else SCM_ASSERT(SCM_INUMP(radix
), radix
, SCM_ARG2
, s_number_to_string
);
1546 char num_buf
[SCM_FLOBUFLEN
];
1548 SCM_ASRTGO(SCM_NIMP(x
), badx
);
1549 if SCM_BIGP(x
) return big2str(x
, (unsigned int)SCM_INUM(radix
));
1551 if (!(SCM_INEXP(x
)))
1552 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_number_to_string
);
1555 SCM_ASSERT(SCM_NIMP(x
) && SCM_INEXP(x
), x
, SCM_ARG1
, s_number_to_string
);
1557 return scm_makfromstr(num_buf
, iflo2str(x
, num_buf
), 0);
1562 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_number_to_string
);
1563 return big2str(x
, (unsigned int)SCM_INUM(radix
));
1566 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_number_to_string
);
1570 char num_buf
[SCM_INTBUFLEN
];
1571 return scm_makfromstr(num_buf
,
1572 scm_iint2str(SCM_INUM(x
), (int)SCM_INUM(radix
), num_buf
), 0);
1577 /* These print routines are stubbed here so that scm_repl.c doesn't need
1578 SCM_FLOATS or SCM_BIGDIGs conditionals */
1581 scm_floprint(SCM sexp
, SCM port
, int writing
)
1584 scm_floprint(sexp
, port
, writing
)
1591 char num_buf
[SCM_FLOBUFLEN
];
1592 scm_gen_write (scm_regular_string
, num_buf
, iflo2str(sexp
, num_buf
), port
);
1594 scm_ipruk("float", sexp
, port
);
1602 scm_bigprint(SCM exp
, SCM port
, int writing
)
1605 scm_bigprint(exp
, port
, writing
)
1612 exp
= big2str(exp
, (unsigned int)10);
1613 scm_gen_write (scm_regular_string
, SCM_CHARS(exp
), (scm_sizet
)SCM_LENGTH(exp
), port
);
1615 scm_ipruk("bignum", exp
, port
);
1619 /*** END nums->strs ***/
1621 /*** STRINGS -> NUMBERS ***/
1625 scm_istr2int(char *str
, long len
, long radix
)
1628 scm_istr2int(str
, len
, radix
)
1635 register scm_sizet k
, blen
= 1;
1639 register SCM_BIGDIG
*ds
;
1640 register unsigned long t2
;
1642 if (0 >= len
) return SCM_BOOL_F
; /* zero scm_length */
1643 if (16==radix
) j
= 1+(4*len
*sizeof(char))/(SCM_BITSPERDIG
);
1644 else if (10 <= radix
)
1645 j
= 1+(84*len
*sizeof(char))/(SCM_BITSPERDIG
*25);
1646 else j
= 1+(len
*sizeof(char))/(SCM_BITSPERDIG
);
1647 switch (str
[0]) { /* leading sign */
1649 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1651 res
= scm_mkbig(j
, '-'==str
[0]);
1652 ds
= SCM_BDIGITS(res
);
1653 for (k
= j
;k
--;) ds
[k
] = 0;
1655 switch (c
= str
[i
++]) {
1659 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1662 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1665 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1670 /* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/
1672 ds
[k
++] = SCM_BIGLO(t2
);
1675 SCM_ASSERT(blen
<= j
, (SCM
)SCM_MAKINUM(blen
), SCM_OVSCM_FLOW
, "bignum");
1676 if (t2
) {blen
++; goto moretodo
;}
1679 return SCM_BOOL_F
; /* not a digit */
1682 if (blen
* SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
))
1683 if SCM_INUMP(res
= scm_big2inum(res
, blen
)) return res
;
1684 if (j
==blen
) return res
;
1685 return scm_adjbig(res
, blen
);
1693 scm_istr2int(char *str
, long len
, long radix
)
1696 scm_istr2int(str
, len
, radix
)
1702 register long n
= 0, ln
;
1706 if (0 >= len
) return SCM_BOOL_F
; /* zero scm_length */
1707 switch (*str
) { /* leading sign */
1708 case '-': lead_neg
= 1;
1709 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1713 switch (c
= str
[i
++]) {
1717 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1720 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1723 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1726 /* Negation is a workaround for HP700 cc bug */
1727 if (n
> ln
|| (-n
> -SCM_MOST_NEGATIVE_FIXNUM
)) goto ovfl
;
1730 return SCM_BOOL_F
; /* not a digit */
1733 if (!lead_neg
) if ((n
= -n
) > SCM_MOST_POSITIVE_FIXNUM
) goto ovfl
;
1734 return SCM_MAKINUM(n
);
1735 ovfl
: /* overflow scheme integer */
1743 scm_istr2flo(char *str
, long len
, long radix
)
1746 scm_istr2flo(str
, len
, radix
)
1752 register int c
, i
= 0;
1754 double res
= 0.0, tmp
= 0.0;
1759 if (i
>= len
) return SCM_BOOL_F
; /* zero scm_length */
1761 switch (*str
) { /* leading sign */
1762 case '-': lead_sgn
= -1.0; i
++; break;
1763 case '+': lead_sgn
= 1.0; i
++; break;
1764 default : lead_sgn
= 0.0;
1766 if (i
==len
) return SCM_BOOL_F
; /* bad if lone `+' or `-' */
1768 if (str
[i
]=='i' || str
[i
]=='I') { /* handle `+i' and `-i' */
1769 if (lead_sgn
==0.0) return SCM_BOOL_F
; /* must have leading sign */
1770 if (++i
< len
) return SCM_BOOL_F
; /* `i' not last character */
1771 return scm_makdbl(0.0, lead_sgn
);
1773 do { /* check initial digits */
1774 switch (c
= str
[i
]) {
1778 case 'D': case 'E': case 'F':
1779 if (radix
==10) goto out1
; /* must be exponent */
1780 case 'A': case 'B': case 'C':
1783 case 'd': case 'e': case 'f':
1784 if (radix
==10) goto out1
;
1785 case 'a': case 'b': case 'c':
1788 if (c
>= radix
) return SCM_BOOL_F
; /* bad digit for radix */
1789 res
= res
* radix
+ c
;
1790 flg
= 1; /* res is valid */
1795 } while (++i
< len
);
1798 /* if true, then we did see a digit above, and res is valid */
1799 if (i
==len
) goto done
;
1801 /* By here, must have seen a digit,
1802 or must have next char be a `.' with radix==10 */
1804 if (!(str
[i
]=='.' && radix
==10))
1807 while (str
[i
]=='#') { /* optional sharps */
1809 if (++i
==len
) goto done
;
1814 switch (c
= str
[i
]) {
1818 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1821 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1824 if (c
>= radix
) return SCM_BOOL_F
;
1825 tmp
= tmp
* radix
+ c
;
1832 if (tmp
==0.0) return SCM_BOOL_F
; /* `slash zero' not allowed */
1834 while (str
[i
]=='#') { /* optional sharps */
1836 if (++i
==len
) break;
1842 if (str
[i
]=='.') { /* decimal point notation */
1843 if (radix
!= 10) return SCM_BOOL_F
; /* must be radix 10 */
1845 switch (c
= str
[i
]) {
1848 res
= res
*10.0 + c
-'0';
1856 if (!flg
) return SCM_BOOL_F
; /* no digits before or after decimal point */
1857 if (i
==len
) goto adjust
;
1858 while (str
[i
]=='#') { /* ignore remaining sharps */
1859 if (++i
==len
) goto adjust
;
1863 switch (str
[i
]) { /* exponent */
1868 case 's': case 'S': {
1869 int expsgn
= 1, expon
= 0;
1870 if (radix
!= 10) return SCM_BOOL_F
; /* only in radix 10 */
1871 if (++i
==len
) return SCM_BOOL_F
; /* bad exponent */
1873 case '-': expsgn
=(-1);
1874 case '+': if (++i
==len
) return SCM_BOOL_F
; /* bad exponent */
1876 if (str
[i
] < '0' || str
[i
] > '9') return SCM_BOOL_F
; /* bad exponent */
1878 switch (c
= str
[i
]) {
1880 expon
= expon
*10 + c
-'0';
1881 if (expon
> MAXEXP
) return SCM_BOOL_F
; /* exponent too large */
1886 } while (++i
< len
);
1888 point
+= expsgn
*expon
;
1894 while (point
--) res
*= 10.0;
1897 while (point
++) res
*= 0.1;
1899 while (point
++) res
/= 10.0;
1903 /* at this point, we have a legitimate floating point result */
1904 if (lead_sgn
==-1.0) res
= -res
;
1905 if (i
==len
) return scm_makdbl(res
, 0.0);
1907 if (str
[i
]=='i' || str
[i
]=='I') { /* pure imaginary number */
1908 if (lead_sgn
==0.0) return SCM_BOOL_F
; /* must have leading sign */
1909 if (++i
< len
) return SCM_BOOL_F
; /* `i' not last character */
1910 return scm_makdbl(0.0, res
);
1914 case '-': lead_sgn
= -1.0; break;
1915 case '+': lead_sgn
= 1.0; break;
1916 case '@': { /* polar input for complex number */
1917 /* get a `real' for scm_angle */
1918 second
= scm_istr2flo(&str
[i
], (long)(len
-i
), radix
);
1919 if (!(SCM_INEXP(second
))) return SCM_BOOL_F
; /* not `real' */
1920 if (SCM_CPLXP(second
)) return SCM_BOOL_F
; /* not `real' */
1921 tmp
= SCM_REALPART(second
);
1922 return scm_makdbl(res
*cos(tmp
), res
*sin(tmp
));
1924 default: return SCM_BOOL_F
;
1927 /* at this point, last char must be `i' */
1928 if (str
[len
-1] != 'i' && str
[len
-1] != 'I') return SCM_BOOL_F
;
1929 /* handles `x+i' and `x-i' */
1930 if (i
==(len
-1)) return scm_makdbl(res
, lead_sgn
);
1931 /* get a `ureal' for complex part */
1932 second
= scm_istr2flo(&str
[i
], (long)((len
-i
)-1), radix
);
1933 if (!(SCM_INEXP(second
))) return SCM_BOOL_F
; /* not `ureal' */
1934 if (SCM_CPLXP(second
)) return SCM_BOOL_F
; /* not `ureal' */
1935 tmp
= SCM_REALPART(second
);
1936 if (tmp
< 0.0) return SCM_BOOL_F
; /* not `ureal' */
1937 return scm_makdbl(res
, (lead_sgn
*tmp
));
1939 #endif /* SCM_FLOATS */
1944 scm_istring2number(char *str
, long len
, long radix
)
1947 scm_istring2number(str
, len
, radix
)
1955 char ex_p
= 0, rx_p
= 0; /* Only allow 1 exactness and 1 radix prefix */
1958 if (*str
=='+' || *str
=='-') /* Catches lone `+' and `-' for speed */
1961 while ((len
-i
) >= 2 && str
[i
]=='#' && ++i
)
1963 case 'b': case 'B': if (rx_p
++) return SCM_BOOL_F
; radix
= 2; break;
1964 case 'o': case 'O': if (rx_p
++) return SCM_BOOL_F
; radix
= 8; break;
1965 case 'd': case 'D': if (rx_p
++) return SCM_BOOL_F
; radix
= 10; break;
1966 case 'x': case 'X': if (rx_p
++) return SCM_BOOL_F
; radix
= 16; break;
1967 case 'i': case 'I': if (ex_p
++) return SCM_BOOL_F
; ex
= 2; break;
1968 case 'e': case 'E': if (ex_p
++) return SCM_BOOL_F
; ex
= 1; break;
1969 default: return SCM_BOOL_F
;
1974 return scm_istr2int(&str
[i
], len
-i
, radix
);
1976 res
= scm_istr2int(&str
[i
], len
-i
, radix
);
1977 if SCM_NFALSEP(res
) return res
;
1979 case 2: return scm_istr2flo(&str
[i
], len
-i
, radix
);
1986 SCM_PROC(s_string_to_number
, "string->number", 1, 1, 0, scm_string_to_number
);
1989 scm_string_to_number(SCM str
, SCM radix
)
1992 scm_string_to_number(str
, radix
)
1998 if SCM_UNBNDP(radix
) radix
=SCM_MAKINUM(10L);
1999 else SCM_ASSERT(SCM_INUMP(radix
), radix
, SCM_ARG2
, s_string_to_number
);
2000 SCM_ASSERT(SCM_NIMP(str
) && SCM_ROSTRINGP(str
), str
, SCM_ARG1
, s_string_to_number
);
2001 answer
= scm_istring2number(SCM_ROCHARS(str
), SCM_ROLENGTH(str
), SCM_INUM(radix
));
2002 return scm_return_first (answer
, str
);
2004 /*** END strs->nums ***/
2009 scm_makdbl (double x
, double y
)
2018 if ((y
==0.0) && (x
==0.0)) return scm_flo0
;
2024 # ifndef SCM_SINGLESONLY
2025 if ((-FLTMAX
< x
) && (x
< FLTMAX
) && (fx
==x
))
2028 SCM_CAR(z
) = scm_tc_flo
;
2033 # endif/* def SCM_SINGLES */
2034 SCM_CDR(z
) = (SCM
)scm_must_malloc(1L*sizeof(double), "real");
2035 SCM_CAR(z
) = scm_tc_dblr
;
2038 SCM_CDR(z
) = (SCM
)scm_must_malloc(2L*sizeof(double), "complex");
2039 SCM_CAR(z
) = scm_tc_dblc
;
2051 scm_bigequal(SCM x
, SCM y
)
2060 if (0==scm_bigcomp(x
, y
)) return SCM_BOOL_T
;
2068 scm_floequal(SCM x
, SCM y
)
2077 if (SCM_REALPART(x
) != SCM_REALPART(y
)) return SCM_BOOL_F
;
2078 if (!(SCM_CPLXP(x
) && (SCM_IMAG(x
) != SCM_IMAG(y
)))) return SCM_BOOL_T
;
2086 SCM_PROC(s_number_p
, "number?", 1, 0, 0, scm_number_p
);
2087 SCM_PROC(s_complex_p
, "complex?", 1, 0, 0, scm_number_p
);
2097 if SCM_INUMP(x
) return SCM_BOOL_T
;
2099 if (SCM_NIMP(x
) && SCM_NUMP(x
)) return SCM_BOOL_T
;
2102 if (SCM_NIMP(x
) && SCM_NUMP(x
)) return SCM_BOOL_T
;
2111 SCM_PROC(s_real_p
, "real?", 1, 0, 0, scm_real_p
);
2112 SCM_PROC(s_rational_p
, "rational?", 1, 0, 0, scm_real_p
);
2137 SCM_PROC(s_int_p
, "int?", 1, 0, 0, scm_int_p
);
2148 if SCM_INUMP(x
) return SCM_BOOL_T
;
2149 if SCM_IMP(x
) return SCM_BOOL_F
;
2151 if SCM_BIGP(x
) return SCM_BOOL_T
;
2153 if (!SCM_INEXP(x
)) return SCM_BOOL_F
;
2154 if SCM_CPLXP(x
) return SCM_BOOL_F
;
2155 r
= SCM_REALPART(x
);
2156 if (r
==floor(r
)) return SCM_BOOL_T
;
2162 #endif /* SCM_FLOATS */
2164 SCM_PROC(s_inexact_p
, "inexact?", 1, 0, 0, scm_inexact_p
);
2167 scm_inexact_p(SCM x
)
2175 if (SCM_NIMP(x
) && SCM_INEXP(x
)) return SCM_BOOL_T
;
2183 SCM_PROC1 (s_eq_p
, "=?", scm_tc7_rpsubr
, scm_num_eq_p
);
2186 scm_num_eq_p (SCM x
, SCM y
)
2200 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_eq_p
);
2203 if SCM_INUMP(y
) return SCM_BOOL_F
;
2204 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2205 if SCM_BIGP(y
) return (0==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2206 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2208 return (SCM_REALP(y
) && (scm_big2dbl(x
)==SCM_REALPART(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2210 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2212 SCM_ASSERT(SCM_NIMP(x
) && SCM_INEXP(x
), x
, SCM_ARG1
, s_eq_p
);
2214 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto realint
;}
2216 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2217 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
2218 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2220 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2222 if (SCM_REALPART(x
) != SCM_REALPART(y
)) return SCM_BOOL_F
;
2224 return (SCM_CPLXP(y
) && (SCM_IMAG(x
)==SCM_IMAG(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2225 return SCM_CPLXP(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
2229 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2230 if SCM_BIGP(y
) return SCM_BOOL_F
;
2232 if (!(SCM_INEXP(y
)))
2233 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2237 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2238 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2242 return (SCM_REALP(y
) && (((double)SCM_INUM(x
))==SCM_REALPART(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2247 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_eq_p
);
2248 if SCM_INUMP(y
) return SCM_BOOL_F
;
2249 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2250 return (0==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2254 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2255 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_eq_p
);
2260 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_eq_p
);
2261 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_eq_p
);
2264 return ((long)x
==(long)y
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2269 SCM_PROC1 (s_less_p
, "<?", scm_tc7_rpsubr
, scm_less_p
);
2272 scm_less_p(SCM x
, SCM y
)
2285 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_less_p
);
2288 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2289 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2290 if SCM_BIGP(y
) return (1==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2291 SCM_ASRTGO(SCM_REALP(y
), bady
);
2292 return (scm_big2dbl(x
) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2294 SCM_ASRTGO(SCM_REALP(x
), badx
);
2296 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_less_p
);
2299 return (SCM_REALPART(x
) < ((double)SCM_INUM(y
))) ? SCM_BOOL_T
: SCM_BOOL_F
;
2301 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2302 if SCM_BIGP(y
) return (SCM_REALPART(x
) < scm_big2dbl(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2303 SCM_ASRTGO(SCM_REALP(y
), bady
);
2305 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2307 return (SCM_REALPART(x
) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2311 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2312 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
2314 if (!(SCM_REALP(y
)))
2315 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2319 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2320 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2323 return (((double)SCM_INUM(x
)) < SCM_REALPART(y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2328 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_less_p
);
2329 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2330 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2331 return (1==scm_bigcomp(x
, y
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2335 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2336 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_less_p
);
2338 return SCM_BIGSIGN(y
) ? SCM_BOOL_F
: SCM_BOOL_T
;
2341 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_less_p
);
2342 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_less_p
);
2345 return ((long)x
< (long)y
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2349 SCM_PROC1 (s_gr_p
, ">?", scm_tc7_rpsubr
, scm_gr_p
);
2352 scm_gr_p(SCM x
, SCM y
)
2360 return scm_less_p(y
, x
);
2365 SCM_PROC1 (s_leq_p
, "<=?", scm_tc7_rpsubr
, scm_leq_p
);
2368 scm_leq_p(SCM x
, SCM y
)
2376 return SCM_BOOL_NOT(scm_less_p(y
, x
));
2381 SCM_PROC1 (s_geq_p
, ">=?", scm_tc7_rpsubr
, scm_geq_p
);
2384 scm_geq_p(SCM x
, SCM y
)
2392 return SCM_BOOL_NOT(scm_less_p(x
, y
));
2397 SCM_PROC(s_zero_p
, "zero?", 1, 0, 0, scm_zero_p
);
2410 SCM_ASRTGO(SCM_NIMP(z
), badz
);
2411 if SCM_BIGP(z
) return SCM_BOOL_F
;
2413 if (!(SCM_INEXP(z
)))
2414 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_zero_p
);
2417 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_zero_p
);
2419 return (z
==scm_flo0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2424 SCM_ASSERT(SCM_NIMP(z
) && SCM_BIGP(z
), z
, SCM_ARG1
, s_zero_p
);
2428 SCM_ASSERT(SCM_INUMP(z
), z
, SCM_ARG1
, s_zero_p
);
2431 return (z
==SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2436 SCM_PROC(s_positive_p
, "positive?", 1, 0, 0, scm_positive_p
);
2439 scm_positive_p(SCM x
)
2449 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2450 if SCM_BIGP(x
) return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_T
: SCM_BOOL_F
;
2452 if (!(SCM_REALP(x
)))
2453 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_positive_p
);
2456 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_positive_p
);
2458 return (SCM_REALPART(x
) > 0.0) ? SCM_BOOL_T
: SCM_BOOL_F
;
2463 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_positive_p
);
2464 return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_T
: SCM_BOOL_F
;
2467 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_positive_p
);
2470 return (x
> SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2475 SCM_PROC(s_negative_p
, "negative?", 1, 0, 0, scm_negative_p
);
2478 scm_negative_p(SCM x
)
2488 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2489 if SCM_BIGP(x
) return SCM_TYP16(x
)==scm_tc16_bigpos
? SCM_BOOL_F
: SCM_BOOL_T
;
2491 if (!(SCM_REALP(x
)))
2492 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_negative_p
);
2495 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_negative_p
);
2497 return (SCM_REALPART(x
) < 0.0) ? SCM_BOOL_T
: SCM_BOOL_F
;
2502 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_negative_p
);
2503 return (SCM_TYP16(x
)==scm_tc16_bigneg
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2506 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_negative_p
);
2509 return (x
< SCM_INUM0
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2513 SCM_PROC1 (s_max
, "max", scm_tc7_asubr
, scm_max
);
2516 scm_max(SCM x
, SCM y
)
2529 if (!(SCM_NUMBERP(x
)))
2530 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_max
);
2537 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2539 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? y
: x
;
2540 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2541 if SCM_BIGP(y
) return (1==scm_bigcomp(x
, y
)) ? y
: x
;
2542 SCM_ASRTGO(SCM_REALP(y
), bady
);
2544 return (z
< SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2546 SCM_ASRTGO(SCM_REALP(x
), badx
);
2548 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_max
);
2551 return (SCM_REALPART(x
) < (z
= SCM_INUM(y
))) ? scm_makdbl(z
, 0.0) : x
;
2553 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2555 return (SCM_REALPART(x
) < (z
= scm_big2dbl(y
))) ? scm_makdbl(z
, 0.0) : x
;
2556 SCM_ASRTGO(SCM_REALP(y
), bady
);
2558 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2560 return (SCM_REALPART(x
) < SCM_REALPART(y
)) ? y
: x
;
2564 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2565 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? x
: y
;
2567 if (!(SCM_REALP(y
)))
2568 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2572 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2573 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2576 return ((z
= SCM_INUM(x
)) < SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2581 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_max
);
2582 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? y
: x
;
2583 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2584 return (1==scm_bigcomp(x
, y
)) ? y
: x
;
2588 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2589 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_max
);
2591 return SCM_BIGSIGN(y
) ? x
: y
;
2594 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_max
);
2595 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_max
);
2598 return ((long)x
< (long)y
) ? y
: x
;
2604 SCM_PROC1 (s_min
, "min", scm_tc7_asubr
, scm_min
);
2607 scm_min(SCM x
, SCM y
)
2620 if (!(SCM_NUMBERP(x
)))
2621 badx
:scm_wta(x
, (char *)SCM_ARG1
, s_min
);
2628 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2630 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? x
: y
;
2631 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2632 if SCM_BIGP(y
) return (-1==scm_bigcomp(x
, y
)) ? y
: x
;
2633 SCM_ASRTGO(SCM_REALP(y
), bady
);
2635 return (z
> SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2637 SCM_ASRTGO(SCM_REALP(x
), badx
);
2639 SCM_ASSERT(SCM_NIMP(x
) && SCM_REALP(x
), x
, SCM_ARG1
, s_min
);
2641 if SCM_INUMP(y
) return (SCM_REALPART(x
) > (z
= SCM_INUM(y
))) ? scm_makdbl(z
, 0.0) : x
;
2643 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2644 if SCM_BIGP(y
) return (SCM_REALPART(x
) > (z
= scm_big2dbl(y
))) ? scm_makdbl(z
, 0.0) : x
;
2645 SCM_ASRTGO(SCM_REALP(y
), bady
);
2647 SCM_ASRTGO(SCM_NIMP(y
) && SCM_REALP(y
), bady
);
2649 return (SCM_REALPART(x
) > SCM_REALPART(y
)) ? y
: x
;
2653 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2654 if SCM_BIGP(y
) return SCM_BIGSIGN(y
) ? y
: x
;
2656 if (!(SCM_REALP(y
)))
2657 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2661 if (!(SCM_NIMP(y
) && SCM_REALP(y
)))
2662 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2665 return ((z
= SCM_INUM(x
)) > SCM_REALPART(y
)) ? y
: scm_makdbl(z
, 0.0);
2670 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_min
);
2671 if SCM_INUMP(y
) return SCM_BIGSIGN(x
) ? x
: y
;
2672 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2673 return (-1==scm_bigcomp(x
, y
)) ? y
: x
;
2677 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2678 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_min
);
2680 return SCM_BIGSIGN(y
) ? y
: x
;
2683 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_min
);
2684 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_min
);
2687 return ((long)x
> (long)y
) ? y
: x
;
2693 SCM_PROC1 (s_sum
, "+", scm_tc7_asubr
, scm_sum
);
2696 scm_sum(SCM x
, SCM y
)
2705 if SCM_UNBNDP(x
) return SCM_INUM0
;
2707 if (!(SCM_NUMBERP(x
)))
2708 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_sum
);
2716 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2718 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2719 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2721 if (SCM_NUMDIGS(x
) > SCM_NUMDIGS(y
)) {t
= x
; x
= y
; y
= t
;}
2722 return scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0);
2724 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2725 bigreal
: return scm_makdbl(scm_big2dbl(x
)+SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_IMAG(y
):0.0);
2727 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2729 SCM_ASRTGO(SCM_NIMP(x
) && SCM_INEXP(x
), badx
);
2731 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intreal
;}
2733 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2734 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
2736 else if (!(SCM_INEXP(y
)))
2737 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2741 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2742 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2746 if SCM_CPLXP(x
) i
= SCM_IMAG(x
);
2747 if SCM_CPLXP(y
) i
+= SCM_IMAG(y
);
2748 return scm_makdbl(SCM_REALPART(x
)+SCM_REALPART(y
), i
); }
2752 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2755 # ifndef SCM_DIGSTOOBIG
2756 long z
= scm_pseudolong(SCM_INUM(x
));
2757 return scm_addbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2759 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2760 scm_longdigs(SCM_INUM(x
), zdigs
);
2761 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2764 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2766 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2768 intreal
: return scm_makdbl(SCM_INUM(x
)+SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_IMAG(y
):0.0);
2774 SCM_ASRTGO(SCM_NIMP(x
) && SCM_BIGP(x
), badx
);
2775 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2776 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2777 if (SCM_NUMDIGS(x
) > SCM_NUMDIGS(y
)) {t
= x
; x
= y
; y
= t
;}
2778 return scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0);
2782 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2783 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_sum
);
2786 # ifndef SCM_DIGSTOOBIG
2787 long z
= scm_pseudolong(SCM_INUM(x
));
2788 return scm_addbig(&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2790 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2791 scm_longdigs(SCM_INUM(x
), zdigs
);
2792 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0);
2797 SCM_ASRTGO(SCM_INUMP(x
), badx
);
2798 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_sum
);
2801 x
= SCM_INUM(x
)+SCM_INUM(y
);
2802 if SCM_FIXABLE(x
) return SCM_MAKINUM(x
);
2804 return scm_long2big(x
);
2807 return scm_makdbl((double)x
, 0.0);
2809 scm_wta(y
, (char *)SCM_OVSCM_FLOW
, s_sum
);
2810 return SCM_UNSPECIFIED
;
2818 SCM_PROC1 (s_difference
, "-", scm_tc7_asubr
, scm_difference
);
2821 scm_difference(SCM x
, SCM y
)
2824 scm_difference(x
, y
)
2833 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_difference
);
2838 x
= scm_copybig(x
, !SCM_BIGSIGN(x
));
2839 return SCM_NUMDIGS(x
) * SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
) ?
2840 scm_big2inum(x
, SCM_NUMDIGS(x
)) : x
;
2843 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2844 return scm_makdbl(-SCM_REALPART(x
), SCM_CPLXP(x
)?-SCM_IMAG(x
):0.0);
2846 if SCM_INUMP(y
) return scm_sum(x
, SCM_MAKINUM(-SCM_INUM(y
)));
2848 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2850 if SCM_BIGP(y
) return (SCM_NUMDIGS(x
) < SCM_NUMDIGS(y
)) ?
2851 scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0x0100) :
2852 scm_addbig(SCM_BDIGITS(y
), SCM_NUMDIGS(y
), SCM_BIGSIGN(y
) ^ 0x0100, x
, 0);
2853 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2854 return scm_makdbl(scm_big2dbl(x
)-SCM_REALPART(y
), SCM_CPLXP(y
)?-SCM_IMAG(y
):0.0);
2856 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2857 if SCM_BIGP(y
) return scm_makdbl(SCM_REALPART(x
)-scm_big2dbl(y
), SCM_CPLXP(x
)?SCM_IMAG(x
):0.0);
2858 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2860 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2861 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
2865 return scm_makdbl(SCM_REAL(x
)-SCM_REAL(y
), SCM_IMAG(x
)-SCM_IMAG(y
));
2867 return scm_makdbl(SCM_REAL(x
)-SCM_REALPART(y
), SCM_IMAG(x
));
2868 return scm_makdbl(SCM_REALPART(x
)-SCM_REALPART(y
), SCM_CPLXP(y
)?-SCM_IMAG(y
):0.0);
2870 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2873 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2875 # ifndef SCM_DIGSTOOBIG
2876 long z
= scm_pseudolong(SCM_INUM(x
));
2877 return scm_addbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2879 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2880 scm_longdigs(SCM_INUM(x
), zdigs
);
2881 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2885 if (!(SCM_INEXP(y
)))
2886 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2890 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
2891 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2894 return scm_makdbl(SCM_INUM(x
)-SCM_REALPART(y
), SCM_CPLXP(y
)?-SCM_IMAG(y
):0.0);
2899 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_difference
);
2901 x
= scm_copybig(x
, !SCM_BIGSIGN(x
));
2902 return SCM_NUMDIGS(x
) * SCM_BITSPERDIG
/SCM_CHAR_BIT
<= sizeof(SCM
) ?
2903 scm_big2inum(x
, SCM_NUMDIGS(x
)) : x
;
2906 # ifndef SCM_DIGSTOOBIG
2907 long z
= scm_pseudolong(SCM_INUM(y
));
2908 return scm_addbig(&z
, SCM_DIGSPERLONG
, (y
< 0) ? 0 : 0x0100, x
, 0);
2910 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2911 scm_longdigs(SCM_INUM(x
), zdigs
);
2912 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (y
< 0) ? 0 : 0x0100, x
, 0);
2915 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
2916 return (SCM_NUMDIGS(x
) < SCM_NUMDIGS(y
)) ?
2917 scm_addbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BIGSIGN(x
), y
, 0x0100) :
2918 scm_addbig(SCM_BDIGITS(y
), SCM_NUMDIGS(y
), SCM_BIGSIGN(y
) ^ 0x0100, x
, 0);
2920 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2923 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
2924 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_difference
);
2927 # ifndef SCM_DIGSTOOBIG
2928 long z
= scm_pseudolong(SCM_INUM(x
));
2929 return scm_addbig(&z
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2931 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
2932 scm_longdigs(SCM_INUM(x
), zdigs
);
2933 return scm_addbig(zdigs
, SCM_DIGSPERLONG
, (x
< 0) ? 0x0100 : 0, y
, 0x0100);
2938 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_difference
);
2939 if SCM_UNBNDP(y
) {x
= -SCM_INUM(x
); goto checkx
;}
2940 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_difference
);
2943 x
= SCM_INUM(x
)-SCM_INUM(y
);
2945 if SCM_FIXABLE(x
) return SCM_MAKINUM(x
);
2947 return scm_long2big(x
);
2950 return scm_makdbl((double)x
, 0.0);
2952 scm_wta(y
, (char *)SCM_OVSCM_FLOW
, s_difference
);
2953 return SCM_UNSPECIFIED
;
2961 SCM_PROC1 (s_product
, "*", scm_tc7_asubr
, scm_product
);
2964 scm_product(SCM x
, SCM y
)
2973 if SCM_UNBNDP(x
) return SCM_MAKINUM(1L);
2975 if (!(SCM_NUMBERP(x
)))
2976 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_product
);
2984 SCM_ASRTGO(SCM_NIMP(x
), badx
);
2986 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intbig
;}
2987 SCM_ASRTGO(SCM_NIMP(y
), bady
);
2988 if SCM_BIGP(y
) return scm_mulbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
2989 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
));
2990 SCM_ASRTGO(SCM_INEXP(y
), bady
);
2992 double bg
= scm_big2dbl(x
);
2993 return scm_makdbl(bg
*SCM_REALPART(y
), SCM_CPLXP(y
)?bg
*SCM_IMAG(y
):0.0); }
2995 SCM_ASRTGO(SCM_INEXP(x
), badx
);
2997 SCM_ASRTGO(SCM_NIMP(x
) && SCM_INEXP(x
), badx
);
2999 if SCM_INUMP(y
) {t
= x
; x
= y
; y
= t
; goto intreal
;}
3001 SCM_ASRTGO(SCM_NIMP(y
), bady
);
3002 if SCM_BIGP(y
) {t
= x
; x
= y
; y
= t
; goto bigreal
;}
3004 else if (!(SCM_INEXP(y
)))
3005 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
3009 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
3010 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
3015 return scm_makdbl(SCM_REAL(x
)*SCM_REAL(y
)-SCM_IMAG(x
)*SCM_IMAG(y
),
3016 SCM_REAL(x
)*SCM_IMAG(y
)+SCM_IMAG(x
)*SCM_REAL(y
));
3018 return scm_makdbl(SCM_REAL(x
)*SCM_REALPART(y
), SCM_IMAG(x
)*SCM_REALPART(y
));
3019 return scm_makdbl(SCM_REALPART(x
)*SCM_REALPART(y
),
3020 SCM_CPLXP(y
)?SCM_REALPART(x
)*SCM_IMAG(y
):0.0);
3024 SCM_ASRTGO(SCM_NIMP(y
), bady
);
3026 intbig
: if (SCM_INUM0
==x
) return x
; if (SCM_MAKINUM(1L)==x
) return y
;
3028 # ifndef SCM_DIGSTOOBIG
3029 long z
= scm_pseudolong(SCM_INUM(x
));
3030 return scm_mulbig((SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3031 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
3033 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3034 scm_longdigs(SCM_INUM(x
), zdigs
);
3035 return scm_mulbig(zdigs
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3036 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
3040 SCM_ASRTGO(SCM_INEXP(y
), bady
);
3042 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
3044 intreal
: return scm_makdbl(SCM_INUM(x
)*SCM_REALPART(y
), SCM_CPLXP(y
)?SCM_INUM(x
)*SCM_IMAG(y
):0.0);
3049 SCM_ASRTGO(SCM_NIMP(x
) && SCM_BIGP(x
), badx
);
3050 if SCM_INUMP(y
) {SCM t
= x
; x
= y
; y
= t
; goto intbig
;}
3051 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
3052 return scm_mulbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3053 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
));
3057 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
3058 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_product
);
3060 intbig
: if (SCM_INUM0
==x
) return x
; if (SCM_MAKINUM(1L)==x
) return y
;
3062 # ifndef SCM_DIGSTOOBIG
3063 long z
= scm_pseudolong(SCM_INUM(x
));
3064 return scm_mulbig(&z
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3065 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
3067 SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3068 scm_longdigs(SCM_INUM(x
), zdigs
);
3069 return scm_mulbig(zdigs
, SCM_DIGSPERLONG
, SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3070 SCM_BIGSIGN(y
) ? (x
>0) : (x
<0));
3075 SCM_ASRTGO(SCM_INUMP(x
), badx
);
3076 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_product
);
3086 if (k
!= SCM_INUM(y
) || k
/i
!= j
)
3088 { int sgn
= (i
< 0) ^ (j
< 0);
3089 # ifndef SCM_DIGSTOOBIG
3090 i
= scm_pseudolong(i
);
3091 j
= scm_pseudolong(j
);
3092 return scm_mulbig((SCM_BIGDIG
*)&i
, SCM_DIGSPERLONG
,
3093 (SCM_BIGDIG
*)&j
, SCM_DIGSPERLONG
, sgn
);
3094 # else /* SCM_DIGSTOOBIG */
3095 SCM_BIGDIG idigs
[SCM_DIGSPERLONG
];
3096 SCM_BIGDIG jdigs
[SCM_DIGSPERLONG
];
3097 scm_longdigs(i
, idigs
);
3098 scm_longdigs(j
, jdigs
);
3099 return scm_mulbig(idigs
, SCM_DIGSPERLONG
, jdigs
, SCM_DIGSPERLONG
, sgn
);
3104 return scm_makdbl(((double)i
)*((double)j
), 0.0);
3106 scm_wta(y
, (char *)SCM_OVSCM_FLOW
, s_product
);
3116 scm_num2dbl (SCM a
, char * why
)
3119 scm_num2dbl (a
, why
)
3125 return (double) SCM_INUM (a
);
3127 SCM_ASSERT (SCM_NIMP (a
), a
, "wrong type argument", why
);
3129 return (SCM_REALPART (a
));
3132 return scm_big2dbl (a
);
3134 SCM_ASSERT (0, a
, "wrong type argument", why
);
3135 return SCM_UNSPECIFIED
;
3139 SCM_PROC(s_fuck
, "fuck", 1, 0, 0, scm_fuck
);
3149 return scm_makdbl (scm_num2dbl (a
, "just because"), 0.0);
3152 SCM_PROC1 (s_divide
, "/", scm_tc7_asubr
, scm_divide
);
3155 scm_divide(SCM x
, SCM y
)
3168 badx
: scm_wta(x
, (char *)SCM_ARG1
, s_divide
);
3172 if SCM_BIGP(x
) return scm_makdbl(1.0/scm_big2dbl(x
), 0.0);
3174 SCM_ASRTGO(SCM_INEXP(x
), badx
);
3175 if SCM_REALP(x
) return scm_makdbl(1.0/SCM_REALPART(x
), 0.0);
3176 r
= SCM_REAL(x
); i
= SCM_IMAG(x
); d
= r
*r
+i
*i
;
3177 return scm_makdbl(r
/d
, -i
/d
);
3184 SCM_ASSERT(z
, y
, SCM_OVSCM_FLOW
, s_divide
);
3187 if (z
< SCM_BIGRAD
) {
3188 SCM w
= scm_copybig(x
, SCM_BIGSIGN(x
) ? (y
>0) : (y
<0));
3189 return scm_divbigdig(SCM_BDIGITS(w
), SCM_NUMDIGS(w
), (SCM_BIGDIG
)z
) ?
3190 scm_makdbl(scm_big2dbl(x
)/SCM_INUM(y
), 0.0) : scm_normbig(w
);
3192 # ifndef SCM_DIGSTOOBIG
3193 z
= scm_pseudolong(z
);
3194 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), (SCM_BIGDIG
*)&z
, SCM_DIGSPERLONG
,
3195 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);
3197 { SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3198 scm_longdigs(z
, zdigs
);
3199 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), zdigs
, SCM_DIGSPERLONG
,
3200 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);}
3202 return z
? z
: scm_makdbl(scm_big2dbl(x
)/SCM_INUM(y
), 0.0);
3204 SCM_ASRTGO(SCM_NIMP(y
), bady
);
3206 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3207 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
), 3);
3208 return z
? z
: scm_makdbl(scm_big2dbl(x
)/scm_big2dbl(y
), 0.0);
3210 SCM_ASRTGO(SCM_INEXP(y
), bady
);
3211 if SCM_REALP(y
) return scm_makdbl(scm_big2dbl(x
)/SCM_REALPART(y
), 0.0);
3216 SCM_ASRTGO(SCM_INEXP(x
), badx
);
3217 if SCM_INUMP(y
) {d
= SCM_INUM(y
); goto basic_div
;}
3219 SCM_ASRTGO(SCM_NIMP(y
), bady
);
3220 if SCM_BIGP(y
) {d
= scm_big2dbl(y
); goto basic_div
;}
3221 SCM_ASRTGO(SCM_INEXP(y
), bady
);
3223 SCM_ASRTGO(SCM_NIMP(y
) && SCM_INEXP(y
), bady
);
3226 d
= SCM_REALPART(y
);
3227 basic_div
: return scm_makdbl(SCM_REALPART(x
)/d
, SCM_CPLXP(x
)?SCM_IMAG(x
)/d
:0.0);
3229 a
= SCM_REALPART(x
);
3230 if SCM_REALP(x
) goto complex_div
;
3231 r
= SCM_REAL(y
); i
= SCM_IMAG(y
); d
= r
*r
+i
*i
;
3232 return scm_makdbl((a
*r
+SCM_IMAG(x
)*i
)/d
, (SCM_IMAG(x
)*r
-a
*i
)/d
);
3235 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
3236 return scm_makdbl(1.0/((double)SCM_INUM(x
)), 0.0);
3240 SCM_ASRTGO(SCM_NIMP(y
), bady
);
3241 if SCM_BIGP(y
) return scm_makdbl(SCM_INUM(x
)/scm_big2dbl(y
), 0.0);
3243 if (!(SCM_INEXP(y
)))
3244 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
3248 if (!(SCM_NIMP(y
) && SCM_INEXP(y
)))
3249 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
3253 return scm_makdbl(SCM_INUM(x
)/SCM_REALPART(y
), 0.0);
3256 r
= SCM_REAL(y
); i
= SCM_IMAG(y
); d
= r
*r
+i
*i
;
3257 return scm_makdbl((a
*r
)/d
, (-a
*i
)/d
);
3263 SCM_ASSERT(SCM_NIMP(x
) && SCM_BIGP(x
), x
, SCM_ARG1
, s_divide
);
3264 if SCM_UNBNDP(y
) goto ov
;
3270 if (z
< SCM_BIGRAD
) {
3271 SCM w
= scm_copybig(x
, SCM_BIGSIGN(x
) ? (y
>0) : (y
<0));
3272 if (scm_divbigdig(SCM_BDIGITS(w
), SCM_NUMDIGS(w
), (SCM_BIGDIG
)z
)) goto ov
;
3275 # ifndef SCM_DIGSTOOBIG
3276 z
= scm_pseudolong(z
);
3277 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), &z
, SCM_DIGSPERLONG
,
3278 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);
3280 { SCM_BIGDIG zdigs
[SCM_DIGSPERLONG
];
3281 scm_longdigs(z
, zdigs
);
3282 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), zdigs
, SCM_DIGSPERLONG
,
3283 SCM_BIGSIGN(x
) ? (y
>0) : (y
<0), 3);}
3286 SCM_ASRTGO(SCM_NIMP(y
) && SCM_BIGP(y
), bady
);
3287 z
= scm_divbigbig(SCM_BDIGITS(x
), SCM_NUMDIGS(x
), SCM_BDIGITS(y
), SCM_NUMDIGS(y
),
3288 SCM_BIGSIGN(x
) ^ SCM_BIGSIGN(y
), 3);
3294 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
3299 if (!(SCM_NIMP(y
) && SCM_BIGP(y
)))
3300 bady
: scm_wta(y
, (char *)SCM_ARG2
, s_divide
);
3305 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_divide
);
3307 if ((SCM_MAKINUM(1L)==x
) || (SCM_MAKINUM(-1L)==x
)) return x
;
3310 SCM_ASSERT(SCM_INUMP(y
), y
, SCM_ARG2
, s_divide
);
3314 long z
= SCM_INUM(y
);
3315 if ((0==z
) || SCM_INUM(x
)%z
) goto ov
;
3317 if SCM_FIXABLE(z
) return SCM_MAKINUM(z
);
3319 return scm_long2big(z
);
3322 ov
: return scm_makdbl(((double)SCM_INUM(x
))/((double)SCM_INUM(y
)), 0.0);
3324 ov
: scm_wta(x
, (char *)SCM_OVSCM_FLOW
, s_divide
);
3325 return SCM_UNSPECIFIED
;
3334 SCM_PROC1 (s_asinh
, "$asinh", scm_tc7_cxr
, (SCM (*)()) scm_asinh
);
3344 return log(x
+sqrt(x
*x
+1));
3350 SCM_PROC1 (s_acosh
, "$acosh", scm_tc7_cxr
, (SCM (*)()) scm_acosh
);
3360 return log(x
+sqrt(x
*x
-1));
3366 SCM_PROC1 (s_atanh
, "$atanh", scm_tc7_cxr
, (SCM (*)()) scm_atanh
);
3376 return 0.5*log((1+x
)/(1-x
));
3382 SCM_PROC1 (s_truncate
, "truncate", scm_tc7_cxr
, (SCM (*)()) scm_truncate
);
3385 scm_truncate(double x
)
3392 if (x
< 0.0) return -floor(-x
);
3398 SCM_PROC1 (s_round
, "round", scm_tc7_cxr
, (SCM (*)()) scm_round
);
3408 double plus_half
= x
+ 0.5;
3409 double result
= floor(plus_half
);
3410 /* Adjust so that the scm_round is towards even. */
3411 return (plus_half
== result
&& plus_half
/ 2 != floor(plus_half
/ 2))
3412 ? result
- 1 : result
;
3417 SCM_PROC1 (s_exact_to_inexact
, "exact->inexact", scm_tc7_cxr
, (SCM (*)()) scm_exact_to_inexact
);
3420 scm_exact_to_inexact(double z
)
3423 scm_exact_to_inexact(z
)
3431 SCM_PROC1 (s_i_floor
, "floor", scm_tc7_cxr
, (SCM (*)()) floor
);
3432 SCM_PROC1 (s_i_ceil
, "ceiling", scm_tc7_cxr
, (SCM (*)()) ceil
);
3433 SCM_PROC1 (s_i_sqrt
, "$sqrt", scm_tc7_cxr
, (SCM (*)())sqrt
);
3434 SCM_PROC1 (s_i_abs
, "$abs", scm_tc7_cxr
, (SCM (*)())fabs
);
3435 SCM_PROC1 (s_i_exp
, "$exp", scm_tc7_cxr
, (SCM (*)())exp
);
3436 SCM_PROC1 (s_i_log
, "$log", scm_tc7_cxr
, (SCM (*)())log
);
3437 SCM_PROC1 (s_i_sin
, "$sin", scm_tc7_cxr
, (SCM (*)())sin
);
3438 SCM_PROC1 (s_i_cos
, "$cos", scm_tc7_cxr
, (SCM (*)())cos
);
3439 SCM_PROC1 (s_i_tan
, "$tan", scm_tc7_cxr
, (SCM (*)())tan
);
3440 SCM_PROC1 (s_i_asin
, "$asin", scm_tc7_cxr
, (SCM (*)())asin
);
3441 SCM_PROC1 (s_i_acos
, "$acos", scm_tc7_cxr
, (SCM (*)())acos
);
3442 SCM_PROC1 (s_i_atan
, "$atan", scm_tc7_cxr
, (SCM (*)())atan
);
3443 SCM_PROC1 (s_i_sinh
, "$sinh", scm_tc7_cxr
, (SCM (*)())sinh
);
3444 SCM_PROC1 (s_i_cosh
, "$cosh", scm_tc7_cxr
, (SCM (*)())cosh
);
3445 SCM_PROC1 (s_i_tanh
, "$tanh", scm_tc7_cxr
, (SCM (*)())tanh
);
3447 struct dpair
{double x
, y
;};
3449 void scm_two_doubles(z1
, z2
, sstring
, xy
)
3454 if SCM_INUMP(z1
) xy
->x
= SCM_INUM(z1
);
3457 SCM_ASRTGO(SCM_NIMP(z1
), badz1
);
3458 if SCM_BIGP(z1
) xy
->x
= scm_big2dbl(z1
);
3461 if (!(SCM_REALP(z1
)))
3462 badz1
: scm_wta(z1
, (char *)SCM_ARG1
, sstring
);
3464 xy
->x
= SCM_REALPART(z1
);}
3466 {SCM_ASSERT(SCM_NIMP(z1
) && SCM_REALP(z1
), z1
, SCM_ARG1
, sstring
);
3467 xy
->x
= SCM_REALPART(z1
);}
3470 if SCM_INUMP(z2
) xy
->y
= SCM_INUM(z2
);
3473 SCM_ASRTGO(SCM_NIMP(z2
), badz2
);
3474 if SCM_BIGP(z2
) xy
->y
= scm_big2dbl(z2
);
3477 if (!(SCM_REALP(z2
)))
3478 badz2
: scm_wta(z2
, (char *)SCM_ARG2
, sstring
);
3480 xy
->y
= SCM_REALPART(z2
);}
3482 {SCM_ASSERT(SCM_NIMP(z2
) && SCM_REALP(z2
), z2
, SCM_ARG2
, sstring
);
3483 xy
->y
= SCM_REALPART(z2
);}
3491 SCM_PROC(s_sys_expt
, "%expt", 2, 0, 0, scm_sys_expt
);
3494 scm_sys_expt(SCM z1
, SCM z2
)
3497 scm_sys_expt(z1
, z2
)
3503 scm_two_doubles(z1
, z2
, s_sys_expt
, &xy
);
3504 return scm_makdbl(pow(xy
.x
, xy
.y
), 0.0);
3509 SCM_PROC(s_sys_atan2
, "%atan2", 2, 0, 0, scm_sys_atan2
);
3512 scm_sys_atan2(SCM z1
, SCM z2
)
3515 scm_sys_atan2(z1
, z2
)
3521 scm_two_doubles(z1
, z2
, s_sys_atan2
, &xy
);
3522 return scm_makdbl(atan2(xy
.x
, xy
.y
), 0.0);
3527 SCM_PROC(s_make_rectangular
, "make-rectangular", 2, 0, 0, scm_make_rectangular
);
3530 scm_make_rectangular(SCM z1
, SCM z2
)
3533 scm_make_rectangular(z1
, z2
)
3539 scm_two_doubles(z1
, z2
, s_make_rectangular
, &xy
);
3540 return scm_makdbl(xy
.x
, xy
.y
);
3545 SCM_PROC(s_make_polar
, "make-polar", 2, 0, 0, scm_make_polar
);
3548 scm_make_polar(SCM z1
, SCM z2
)
3551 scm_make_polar(z1
, z2
)
3557 scm_two_doubles(z1
, z2
, s_make_polar
, &xy
);
3558 return scm_makdbl(xy
.x
*cos(xy
.y
), xy
.x
*sin(xy
.y
));
3564 SCM_PROC(s_real_part
, "real-part", 1, 0, 0, scm_real_part
);
3567 scm_real_part(SCM z
)
3576 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3577 if SCM_BIGP(z
) return z
;
3579 if (!(SCM_INEXP(z
)))
3580 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_real_part
);
3583 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_real_part
);
3585 if SCM_CPLXP(z
) return scm_makdbl(SCM_REAL(z
), 0.0);
3592 SCM_PROC(s_imag_part
, "imag-part", 1, 0, 0, scm_imag_part
);
3595 scm_imag_part(SCM z
)
3602 if SCM_INUMP(z
) return SCM_INUM0
;
3604 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3605 if SCM_BIGP(z
) return SCM_INUM0
;
3607 if (!(SCM_INEXP(z
)))
3608 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_imag_part
);
3611 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_imag_part
);
3613 if SCM_CPLXP(z
) return scm_makdbl(SCM_IMAG(z
), 0.0);
3619 SCM_PROC(s_magnitude
, "magnitude", 1, 0, 0, scm_magnitude
);
3622 scm_magnitude(SCM z
)
3629 if SCM_INUMP(z
) return scm_abs(z
);
3631 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3632 if SCM_BIGP(z
) return scm_abs(z
);
3634 if (!(SCM_INEXP(z
)))
3635 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_magnitude
);
3638 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_magnitude
);
3642 double i
= SCM_IMAG(z
), r
= SCM_REAL(z
);
3643 return scm_makdbl(sqrt(i
*i
+r
*r
), 0.0);
3645 return scm_makdbl(fabs(SCM_REALPART(z
)), 0.0);
3651 SCM_PROC(s_angle
, "angle", 1, 0, 0, scm_angle
);
3662 if SCM_INUMP(z
) {x
= (z
>=SCM_INUM0
) ? 1.0 : -1.0; goto do_angle
;}
3664 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3665 if SCM_BIGP(z
) {x
= (SCM_TYP16(z
)==scm_tc16_bigpos
) ? 1.0 : -1.0; goto do_angle
;}
3667 if (!(SCM_INEXP(z
))) {
3668 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_angle
);}
3671 SCM_ASSERT(SCM_NIMP(z
) && SCM_INEXP(z
), z
, SCM_ARG1
, s_angle
);
3675 x
= SCM_REALPART(z
);
3678 x
= SCM_REAL(z
); y
= SCM_IMAG(z
);
3680 return scm_makdbl(atan2(y
, x
), 0.0);
3684 SCM_PROC(s_inexact_to_exact
, "inexact->exact", 1, 0, 0, scm_inexact_to_exact
);
3687 scm_inexact_to_exact(SCM z
)
3690 scm_inexact_to_exact(z
)
3694 if SCM_INUMP(z
) return z
;
3696 SCM_ASRTGO(SCM_NIMP(z
), badz
);
3697 if SCM_BIGP(z
) return z
;
3699 if (!(SCM_REALP(z
)))
3700 badz
: scm_wta(z
, (char *)SCM_ARG1
, s_inexact_to_exact
);
3703 SCM_ASSERT(SCM_NIMP(z
) && SCM_REALP(z
), z
, SCM_ARG1
, s_inexact_to_exact
);
3707 double u
= floor(SCM_REALPART(z
)+0.5);
3708 if ((u
<= SCM_MOST_POSITIVE_FIXNUM
) && (-u
<= -SCM_MOST_NEGATIVE_FIXNUM
)) {
3709 /* Negation is a workaround for HP700 cc bug */
3710 SCM ans
= SCM_MAKINUM((long)u
);
3711 if (SCM_INUM(ans
)==(long)u
) return ans
;
3713 SCM_ASRTGO(!IS_INF(u
), badz
); /* problem? */
3714 return scm_dbl2big(u
);
3717 return SCM_MAKINUM((long)floor(SCM_REALPART(z
)+0.5));
3723 #else /* ~SCM_FLOATS */
3724 SCM_PROC(s_trunc
, "truncate", 1, 0, 0, scm_trunc
);
3734 SCM_ASSERT(SCM_INUMP(x
), x
, SCM_ARG1
, s_truncate
);
3740 #endif /* SCM_FLOATS */
3744 /* d must be integer */
3747 scm_dbl2big(double d
)
3758 double u
= (d
< 0)?-d
:d
;
3759 while (0 != floor(u
)) {u
/= SCM_BIGRAD
;i
++;}
3760 ans
= scm_mkbig(i
, d
< 0);
3761 digits
= SCM_BDIGITS(ans
);
3768 SCM_ASSERT(0==u
, SCM_INUM0
, SCM_OVSCM_FLOW
, "dbl2big");
3784 scm_sizet i
= SCM_NUMDIGS(b
);
3785 SCM_BIGDIG
*digits
= SCM_BDIGITS(b
);
3786 while (i
--) ans
= digits
[i
] + SCM_BIGRAD
*ans
;
3787 if (scm_tc16_bigneg
==SCM_TYP16(b
)) return -ans
;
3795 scm_long2num(long sl
)
3802 if (!SCM_FIXABLE(sl
)) {
3804 return scm_long2big(sl
);
3807 return scm_makdbl((double) sl
, 0.0);
3813 return SCM_MAKINUM(sl
);
3820 scm_long_long2num(long_long sl
)
3823 scm_long_long2num(sl
)
3827 if (!SCM_FIXABLE(sl
)) {
3829 return scm_long_long2big(sl
);
3832 return scm_makdbl((double) sl
, 0.0);
3838 return SCM_MAKINUM(sl
);
3845 scm_ulong2num(unsigned long sl
)
3852 if (!SCM_POSSCM_FIXABLE(sl
)) {
3854 return scm_ulong2big(sl
);
3857 return scm_makdbl((double) sl
, 0.0);
3863 return SCM_MAKINUM(sl
);
3868 scm_num2long(SCM num
, char *pos
, char *s_caller
)
3871 scm_num2long(num
, pos
, s_caller
)
3880 res
= SCM_INUM(num
);
3883 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3887 double u
= SCM_REALPART(num
);
3889 if ((double)res
== u
)
3896 if (SCM_BIGP(num
)) {
3901 for(l
= SCM_NUMDIGS(num
);l
--;)
3903 res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
3908 if (SCM_TYP16 (num
) == scm_tc16_bigpos
)
3914 errout
: scm_wta(num
, pos
, s_caller
);
3915 return SCM_UNSPECIFIED
;
3923 num2long(SCM num
, char *pos
, char *s_caller
)
3926 num2long(num
, pos
, s_caller
)
3934 res
= SCM_INUM((long)num
);
3937 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3940 double u
= SCM_REALPART(num
);
3941 if (((SCM_MOST_NEGATIVE_FIXNUM
* 4) <= u
)
3942 && (u
<= (SCM_MOST_POSITIVE_FIXNUM
* 4 + 3))) {
3950 scm_sizet l
= SCM_NUMDIGS(num
);
3951 SCM_ASRTGO(SCM_DIGSPERLONG
>= l
, errout
);
3953 for(;l
--;) res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
3957 errout
: scm_wta(num
, pos
, s_caller
);
3958 return SCM_UNSPECIFIED
;
3965 scm_num2long_long(SCM num
, char *pos
, char *s_caller
)
3968 scm_num2long_long(num
, pos
, s_caller
)
3976 res
= SCM_INUM((long_long
)num
);
3979 SCM_ASRTGO(SCM_NIMP(num
), errout
);
3982 double u
= SCM_REALPART(num
);
3983 if (((SCM_MOST_NEGATIVE_FIXNUM
* 4) <= u
)
3984 && (u
<= (SCM_MOST_POSITIVE_FIXNUM
* 4 + 3))) {
3992 scm_sizet l
= SCM_NUMDIGS(num
);
3993 SCM_ASRTGO(SCM_DIGSPERLONGLONG
>= l
, errout
);
3995 for(;l
--;) res
= SCM_LONGLONGSCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
3999 errout
: scm_wta(num
, pos
, s_caller
);
4000 return SCM_UNSPECIFIED
;
4007 scm_num2ulong(SCM num
, char *pos
, char *s_caller
)
4010 scm_num2ulong(num
, pos
, s_caller
)
4019 res
= SCM_INUM((unsigned long)num
);
4022 SCM_ASRTGO(SCM_NIMP(num
), errout
);
4026 double u
= SCM_REALPART(num
);
4027 if ((0 <= u
) && (u
<= (unsigned long)~0L))
4035 if (SCM_BIGP(num
)) {
4036 unsigned long oldres
;
4040 for(l
= SCM_NUMDIGS(num
);l
--;)
4042 res
= SCM_BIGUP(res
) + SCM_BDIGITS(num
)[l
];
4050 errout
: scm_wta(num
, pos
, s_caller
);
4051 return SCM_UNSPECIFIED
;
4057 static void add1(f
, fsum
)
4068 scm_init_numbers (void)
4075 SCM_NEWCELL(scm_flo0
);
4077 SCM_CAR(scm_flo0
) = scm_tc_flo
;
4078 SCM_FLO(scm_flo0
) = 0.0;
4080 SCM_CDR(scm_flo0
) = (SCM
)scm_must_malloc(1L*sizeof(double), "real");
4081 SCM_REAL(scm_flo0
) = 0.0;
4082 SCM_CAR(scm_flo0
) = scm_tc_dblr
;
4085 scm_dblprec
= (DBL_DIG
> 20) ? 20 : DBL_DIG
;
4087 { /* determine floating point precision */
4089 double fsum
= 1.0+f
;
4090 while (fsum
!= 1.0) {
4092 if (++scm_dblprec
> 20) break;
4095 scm_dblprec
= scm_dblprec
-1;
4097 # endif /* DBL_DIG */
4099 #include "numbers.x"
HCoop / bpt / guile.git / blob