diff --git a/eval.c b/eval.c index 6351ad33..eace6762 100644 --- a/eval.c +++ b/eval.c @@ -1678,13 +1678,20 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case OP_DIV: - if (_ARG2 == sexp_make_integer(0)) - sexp_raise("divide by zero", SEXP_NULL); - if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (_ARG2 == sexp_make_integer(0)) { +#if USE_FLONUMS + if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) + _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { #if USE_FLONUMS _ARG1 = sexp_integer_to_flonum(ctx, _ARG1); _ARG2 = sexp_integer_to_flonum(ctx, _ARG2); _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + if (sexp_flonum_value(_ARG2) == trunc(sexp_flonum_value(_ARG2))) + _ARG2 = sexp_make_integer(sexp_flonum_value(_ARG2)); #else _ARG2 = sexp_fx_div(_ARG1, _ARG2); #endif @@ -1849,10 +1856,18 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); break; case OP_FLO2FIX: - if (sexp_flonump(_ARG1)) - _ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1)); - else if (! sexp_integerp(_ARG1)) + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); + } else { + _ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_integerp(_ARG1) && ! sexp_bignump(_ARG1)) { sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } break; case OP_CHAR2INT: _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); diff --git a/init.scm b/init.scm index fac7cae9..61413eda 100644 --- a/init.scm +++ b/init.scm @@ -391,6 +391,13 @@ (define (abs x) (if (< x 0) (- x) x)) +(define (numerator x) + (if (integer? x) x (numerator (* x 10)))) +(define (denominator x) + (if (exact? x) + 1 + (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10)))))) + (define (modulo a b) (let ((res (remainder a b))) (if (< b 0) diff --git a/opcodes.c b/opcodes.c index 56aa6563..e765c22b 100644 --- a/opcodes.c +++ b/opcodes.c @@ -126,24 +126,7 @@ _FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), _FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), #endif #if PLAN9 -_FN0("random-integer", 0, sexp_rand), -_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), -_FN0("current-directory", 0, sexp_getwd), -_FN0("current-user", 0, sexp_getuser), -_FN0("system-name", 0, sexp_sysname), -_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), -_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), -_FN0("fork", 0, sexp_fork), -_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), -_FN1(SEXP_STRING, "exits", 0, sexp_exits), -_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), -_FN0("pipe", 0, sexp_pipe), -_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), -_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), -_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), -_FN0("wait", 0, sexp_wait), -_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), -_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +#include "opt/plan9-opcodes.c" #endif }; diff --git a/opt/bignum.c b/opt/bignum.c index 0ddd7c3e..1a7112bd 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -25,6 +25,30 @@ sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { return res; } +#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) +#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) + +sexp sexp_double_to_bignum (sexp ctx, double f) { + int sign; + sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, scale, s_scale); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, scale, s_scale); + sexp_gc_preserve(ctx, tmp, s_tmp); + res = sexp_fixnum_to_bignum(ctx, sexp_make_integer(0)); + scale = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); + sign = (f < 0 ? -1 : 1); + for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { + tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + res = sexp_bignum_add(ctx, res, res, tmp); + scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); + } + sexp_bignum_sign(res) = sign; + sexp_gc_release(ctx, res, s_res); + return res; +} + sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); @@ -514,7 +538,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { r = sexp_fx_sub(a, b); /* XXXX check overflow */ break; case SEXP_NUM_FIX_FLO: - r = sexp_make_flonum(ctx, sexp_integer_to_double(a)+sexp_flonum_value(b)); + r = sexp_make_flonum(ctx, sexp_integer_to_double(a)-sexp_flonum_value(b)); break; case SEXP_NUM_FIX_BIG: r = sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a)); @@ -528,13 +552,13 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { r = sexp_fp_sub(ctx, a, b); break; case SEXP_NUM_FLO_BIG: - r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b)); break; case SEXP_NUM_BIG_FIX: r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, sexp_fixnum_to_bignum(ctx, b))); break; case SEXP_NUM_BIG_FLO: - r = sexp_make_flonum(ctx, sexp_flonum_value(b) + sexp_bignum_to_double(a)); + r = sexp_make_flonum(ctx, sexp_flonum_value(b) - sexp_bignum_to_double(a)); case SEXP_NUM_BIG_BIG: r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); break; @@ -555,7 +579,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) { r = sexp_fx_mul(a, b); break; case SEXP_NUM_FIX_FLO: - r = sexp_make_flonum(ctx, sexp_integer_to_double(a)+sexp_flonum_value(b)); + r = sexp_make_flonum(ctx, sexp_integer_to_double(a)*sexp_flonum_value(b)); break; case SEXP_NUM_FIX_BIG: r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_integer(sexp_fx_abs(a)), 0); @@ -565,7 +589,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) { r = sexp_fp_mul(ctx, a, b); break; case SEXP_NUM_FLO_BIG: - r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b)); break; case SEXP_NUM_BIG_BIG: r = sexp_bignum_mul(ctx, NULL, a, b); diff --git a/sexp.c b/sexp.c index 74cf8376..e27c42aa 100644 --- a/sexp.c +++ b/sexp.c @@ -844,9 +844,14 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { #if ! USE_IMMEDIATE_FLONUMS case SEXP_FLONUM: f = sexp_flonum_value(obj); - i = sprintf(numbuf, "%.15g", f); - if (f == trunc(f)) { - numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else { + i = sprintf(numbuf, "%.15g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + } } sexp_write_string(ctx, numbuf, out); break; @@ -902,9 +907,14 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { #if USE_IMMEDIATE_FLONUMS } else if (sexp_flonump(obj)) { f = sexp_flonum_value(obj); - i = sprintf(numbuf, "%.15g", f); - if (f == trunc(f)) { - numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else { + i = sprintf(numbuf, "%.15g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + } } sexp_write_string(ctx, numbuf, out); #endif @@ -1029,15 +1039,17 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp) { isdigit(c); c=sexp_read_char(ctx, in), scale*=0.1) res += digit_value(c)*scale; - sexp_push_char(ctx, c, in); if (c=='e' || c=='E') { exponent = sexp_read_number(ctx, in, 10); if (sexp_exceptionp(exponent)) return exponent; e = (sexp_integerp(exponent) ? sexp_unbox_integer(exponent) : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0); - } else if ((c!=EOF) && ! is_separator(c)) + } else if ((c!=EOF) && ! is_separator(c)) { return sexp_read_error(ctx, "invalid numeric syntax", sexp_make_character(c), in); + } else { + sexp_push_char(ctx, c, in); + } res = ((double)whole + res) * pow(10, e); if (negp) res *= -1; if ((scale == 0.1) && (exponent != SEXP_VOID) && (res == round(res)))