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

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
 

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

opt/bignum.c

@@ -8,8 +8,7 @@
   if (sexp_bignump(x))                                  \
     sexp_bignum_sign(x) = -sexp_bignum_sign(x);         \
   else if (sexp_integerp(x))                            \
-    x = sexp_fx_neg(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))
+  sexp_gc_var(ctx, c, s_c);
-    return sexp_bignum_fxadd(ctx, a, sexp_unbox_integer(sexp_fx_abs(b)));
+  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);
+  sexp_gc_var(ctx, a1, s_a1);
-  if (cmp == 0) {                 /* a == b, return 1, no rem */
+  sexp_gc_var(ctx, b1, s_b1);
-    *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_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);

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

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)

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)