Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 05:27:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding extended numeric tests and fixes for the bignum bugs it turned up

Browse source
This commit is contained in:
Alex Shinn 2009-07-15 23:56:51 +09:00
parent 4ba0705f05
commit 9951c8e921
6 changed files with 206 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile
View file

@ -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

2
include/chibi/sexp.h
View file

@ -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
View file

@ -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
View file

@ -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
View 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)

20
tests/r5rs-tests.scm
View file

@ -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)