mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 05:27:35 +02:00
adding extended numeric tests and fixes for the bignum bugs it turned up
This commit is contained in:
parent
4ba0705f05
commit
9951c8e921
6 changed files with 206 additions and 38 deletions
3
Makefile
3
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
|
||||
|
||||
|
|
|
@ -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)))
|
||||
|
|
75
opt/bignum.c
75
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);
|
||||
|
|
6
sexp.c
6
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));
|
||||
|
|
138
tests/numeric-tests.scm
Normal file
138
tests/numeric-tests.scm
Normal file
|
@ -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)
|
|
@ -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)
|
||||
|
|
Loading…
Add table
Reference in a new issue