diff --git a/Makefile b/Makefile index ef014868..df83a51a 100644 --- a/Makefile +++ b/Makefile @@ -99,6 +99,9 @@ test-basic: chibi-scheme$(EXE) fi; \ done +test-numbers: chibi-scheme$(EXE) + ./chibi-scheme$(EXE) tests/numeric-tests.scm + test: chibi-scheme$(EXE) ./chibi-scheme$(EXE) tests/r5rs-tests.scm diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 446671ea..973535a9 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -523,8 +523,8 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_fx_div(a, b) (sexp_make_integer(sexp_unbox_integer(a) / sexp_unbox_integer(b))) #define sexp_fx_rem(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) #define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(int)*8 - 1))) -#define sexp_fx_abs(a) (((sexp_sint_t)a) < 0 ? -((sexp_sint_t)a) : ((sexp_sint_t)a)) #define sexp_fx_neg(a) (sexp_make_integer(-(sexp_unbox_integer(a)))) +#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) #define sexp_fp_add(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) + sexp_flonum_value(b))) #define sexp_fp_sub(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) - sexp_flonum_value(b))) diff --git a/opt/bignum.c b/opt/bignum.c index e7f9a2f9..0ddd7c3e 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -4,12 +4,11 @@ #define SEXP_INIT_BIGNUM_SIZE 2 -#define sexp_negate(x) \ - if (sexp_bignump(x)) \ - sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ - else if (sexp_integerp(x)) \ - x = sexp_fx_neg(x); \ - +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_integerp(x)) \ + x = sexp_fx_neg(x); sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); @@ -58,11 +57,9 @@ static sexp_uint_t sexp_bignum_hi (sexp a) { return i+1; } -sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { +sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) { int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); - if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) - return sexp_bignum_sign(a); if (ai != bi) return ai - bi; for (--ai; ai >= 0; ai--) { @@ -74,6 +71,12 @@ sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { return 0; } +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + return sexp_bignum_compare_abs(a, b); +} + sexp sexp_bignum_normalize (sexp a) { sexp_uint_t *data; if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) @@ -222,17 +225,22 @@ sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { /****************** bignum arithmetic *************************/ sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { - if (sexp_bignum_sign(a) == sexp_fx_sign(b)) - return sexp_bignum_fxadd(ctx, a, sexp_unbox_integer(sexp_fx_abs(b))); + sexp_gc_var(ctx, c, s_c); + sexp_gc_preserve(ctx, c, s_c); + c = sexp_copy_bignum(ctx, NULL, a, 0); + if (sexp_bignum_sign(c) == sexp_fx_sign(b)) + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_integer(sexp_fx_abs(b))); else - return sexp_bignum_fxsub(ctx, a, sexp_unbox_integer(sexp_fx_abs(b))); + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_integer(sexp_fx_abs(b))); + sexp_gc_release(ctx, c, s_c); + return c; } sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), borrow=0, i, *adata, *bdata, *cdata; sexp_gc_var(ctx, c, s_c); - if (alen < blen) + if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) return sexp_bignum_sub_digits(ctx, dst, b, a); sexp_gc_preserve(ctx, c, s_c); c = ((dst && sexp_bignum_hi(dst) >= alen) @@ -288,7 +296,7 @@ sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b) { } else { res = sexp_bignum_sub_digits(ctx, dst, a, b); sexp_bignum_sign(res) - = sexp_bignum_sign(sexp_bignum_compare(a, b) >= 0 ? a : b); + = sexp_bignum_sign(sexp_bignum_compare_abs(a, b) >= 0 ? a : b); } return res; } @@ -298,7 +306,8 @@ sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { res = sexp_bignum_sub_digits(ctx, dst, a, b); sexp_bignum_sign(res) - = sexp_bignum_sign(sexp_bignum_compare(a, b) >= 0 ? a : b); + = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); } else { res = sexp_bignum_add_digits(ctx, dst, a, b); sexp_bignum_sign(res) = sexp_bignum_sign(a); @@ -362,26 +371,27 @@ static sexp quot_step (sexp ctx, sexp *rem, sexp a, sexp b, sexp k, sexp i) { return res; } -#undef _str - sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { - int cmp; sexp res; sexp_gc_var(ctx, k, s_k); sexp_gc_var(ctx, i, s_i); - cmp = sexp_bignum_compare(a, b); - if (cmp == 0) { /* a == b, return 1, no rem */ - *rem = sexp_make_integer(0); - return sexp_make_integer(1); - } else if (cmp < 0) { /* a < b, return 0, rem = a */ - *rem = a; - return sexp_make_integer(0); - } + sexp_gc_var(ctx, a1, s_a1); + sexp_gc_var(ctx, b1, s_b1); sexp_gc_preserve(ctx, k, s_k); sexp_gc_preserve(ctx, i, s_i); - k = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_gc_preserve(ctx, a1, s_a1); + sexp_gc_preserve(ctx, b1, s_b1); + a1 = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(a1) = 1; + b1 = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_bignum_sign(b1) = 1; + k = sexp_copy_bignum(ctx, NULL, b1, 0); i = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); - res = quot_step(ctx, rem, a, b, k, i); + res = quot_step(ctx, rem, a1, b1, k, i); + sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); + if (sexp_bignum_sign(a) < 0) { + sexp_negate(*rem); + } sexp_gc_release(ctx, k, s_k); return res; } @@ -468,7 +478,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) { r = sexp_type_exception(ctx, "+: not a number", a); break; case SEXP_NUM_FIX_FIX: - r = sexp_fx_add(a, b); + r = sexp_fx_add(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)); @@ -501,14 +511,15 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { r = sexp_type_exception(ctx, "-: not a number", b); break; case SEXP_NUM_FIX_FIX: - r = sexp_fx_sub(a, 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)); break; case SEXP_NUM_FIX_BIG: - r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a))); + r = sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a)); sexp_negate(r); + r = sexp_bignum_normalize(r); break; case SEXP_NUM_FLO_FIX: r = sexp_make_flonum(ctx, sexp_integer_to_double(b)+sexp_flonum_value(a)); @@ -548,7 +559,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) { break; case SEXP_NUM_FIX_BIG: r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_integer(sexp_fx_abs(a)), 0); - sexp_bignum_sign(r) *= sexp_fx_sign(a); + sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); break; case SEXP_NUM_FLO_FLO: r = sexp_fp_mul(ctx, a, b); diff --git a/sexp.c b/sexp.c index 093c2d33..dfaca5a1 100644 --- a/sexp.c +++ b/sexp.c @@ -307,7 +307,7 @@ sexp sexp_nreverse (sexp ctx, sexp ls) { if (ls == SEXP_NULL) { return ls; } else if (! sexp_pairp(ls)) { - return SEXP_NULL; /* XXXX return an exception */ + return sexp_type_exception(ctx, "not a list", ls); } else { b = ls; a = sexp_cdr(ls); @@ -387,6 +387,10 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) { && (! strncmp(sexp_string_data(a), sexp_string_data(b), sexp_string_length(a)))); +#if USE_BIGNUMS + case SEXP_BIGNUM: + return sexp_make_boolean(!sexp_bignum_compare(a, b)); +#endif #if ! USE_IMMEDIATE_FLONUMS case SEXP_FLONUM: return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..a5d17b2f --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,138 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test expect expr) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display 'expr out)))) + (res expr)) + (display str) + (write-char #\space) + (display (make-string (max 0 (- 72 (string-length str))) #\.)) + (flush-output) + (cond + ((equal? res expect) + (set! *tests-passed* (+ *tests-passed* 1)) + (display " [PASS]\n")) + (else + (display " [FAIL]\n") + (display " expected ") (write expect) + (display " but got ") (write res) (newline)))))))) + +(define (test-report) + (write *tests-passed*) + (display " out of ") + (write *tests-run*) + (display " passed (") + (write (* (/ *tests-passed* *tests-run*) 100)) + (display "%)") + (newline)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-neighborhoods x) + (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) + +(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913) + (integer-neighborhoods (expt 2 29))) + +(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825) + (integer-neighborhoods (expt 2 30))) + +(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649) + (integer-neighborhoods (expt 2 31))) + +(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297) + (integer-neighborhoods (expt 2 32))) + +(test '(4611686018427387904 4611686018427387905 4611686018427387903 + -4611686018427387904 -4611686018427387903 -4611686018427387905) + (integer-neighborhoods (expt 2 62))) + +(test '(9223372036854775808 9223372036854775809 9223372036854775807 + -9223372036854775808 -9223372036854775807 -9223372036854775809) + (integer-neighborhoods (expt 2 63))) + +(test '(18446744073709551616 18446744073709551617 18446744073709551615 + -18446744073709551616 -18446744073709551615 -18446744073709551617) + (integer-neighborhoods (expt 2 64))) + +(test '(85070591730234615865843651857942052864 + 85070591730234615865843651857942052865 + 85070591730234615865843651857942052863 + -85070591730234615865843651857942052864 + -85070591730234615865843651857942052863 + -85070591730234615865843651857942052865) + (integer-neighborhoods (expt 2 126))) + +(test '(170141183460469231731687303715884105728 + 170141183460469231731687303715884105729 + 170141183460469231731687303715884105727 + -170141183460469231731687303715884105728 + -170141183460469231731687303715884105727 + -170141183460469231731687303715884105729) + (integer-neighborhoods (expt 2 127))) + +(test '(340282366920938463463374607431768211456 + 340282366920938463463374607431768211457 + 340282366920938463463374607431768211455 + -340282366920938463463374607431768211456 + -340282366920938463463374607431768211455 + -340282366920938463463374607431768211457) + (integer-neighborhoods (expt 2 128))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-arithmetic-combinations a b) + (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b))) + +(define (sign-combinations a b) + (list (integer-arithmetic-combinations a b) + (integer-arithmetic-combinations (- a) b) + (integer-arithmetic-combinations a (- b)) + (integer-arithmetic-combinations (- a) (- b)))) + +;; fix x fix +(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) + (sign-combinations 0 1)) +(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0)) + (sign-combinations 1 1)) +(test '((59 25 714 2 8) (-25 -59 -714 -2 -8) + (25 59 -714 -2 8) (-59 -25 714 2 -8)) + (sign-combinations 42 17)) + +;; fix x big +(test '((4294967338 -4294967254 180388626432 0 42) + (4294967254 -4294967338 -180388626432 0 -42) + (-4294967254 4294967338 -180388626432 0 42) + (-4294967338 4294967254 180388626432 0 -42)) + (sign-combinations 42 (expt 2 32))) + +;; big x fix +(test '((4294967338 4294967254 180388626432 102261126 4) + (-4294967254 -4294967338 -180388626432 -102261126 -4) + (4294967254 4294967338 -180388626432 -102261126 4) + (-4294967338 -4294967254 180388626432 102261126 -4)) + (sign-combinations (expt 2 32) 42)) + +;; big x bigger +(test '((12884901889 -4294967297 36893488151714070528 0 4294967296) + (4294967297 -12884901889 -36893488151714070528 0 -4294967296) + (-4294967297 12884901889 -36893488151714070528 0 4294967296) + (-12884901889 4294967297 36893488151714070528 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) + +;; bigger x big +(test '((12884901889 4294967297 36893488151714070528 2 1) + (-4294967297 -12884901889 -36893488151714070528 -2 -1) + (4294967297 12884901889 -36893488151714070528 -2 1) + (-12884901889 -4294967297 36893488151714070528 2 -1)) + (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) + +(test-report) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 8fc0606e..9e06318d 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -219,8 +219,20 @@ (test 256 (string->number "100" 16)) +(test 127 (string->number "177" 8)) + +(test 5 (string->number "101" 2)) + (test 100 (string->number "1e2")) +(test "100" (number->string 100)) + +(test "100" (number->string 256 16)) + +(test "177" (number->string 127 8)) + +(test "101" (number->string 5 2)) + (test #f (not 3)) (test #f (not (list 3))) @@ -349,6 +361,10 @@ (test #t (call-with-current-continuation procedure?)) +(test 7 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + (test 7 (apply + (list 3 4))) (test '(b e h) (map cadr '((a b) (d e) (g h)))) @@ -368,10 +384,6 @@ (test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) -(test 7 (call-with-current-continuation (lambda (k) (+ 2 5)))) - -(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test-report)