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

fixing some 64-bit bignum arithmetic cases

Browse source
This commit is contained in:
Alex Shinn 2009-11-28 16:05:59 +09:00
parent 025aae80d6
commit 353594a028
4 changed files with 33 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
eval.c
View file

@ -63,7 +63,7 @@ static sexp sexp_env_cell_create (sexp ctx, sexp e, sexp key, sexp value) {
return cell; return cell;
} }
static sexp sexp_env_global_ref (sexp e, sexp key, sexp dflt) { sexp sexp_env_global_ref (sexp e, sexp key, sexp dflt) {
sexp cell; sexp cell;
while (sexp_env_parent(e)) while (sexp_env_parent(e))
e = sexp_env_parent(e); e = sexp_env_parent(e);
@ -1650,7 +1650,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
#if USE_BIGNUMS #if USE_BIGNUMS
tmp1 = _ARG1, tmp2 = _ARG2; tmp1 = _ARG1, tmp2 = _ARG2;
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
prod = sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2);
if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM))
_ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
else else

2
include/chibi/sexp.h
View file

@ -632,7 +632,7 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) #define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG)))
#define sexp_fx_div(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) #define sexp_fx_div(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b)))
#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) #define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b)))
#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(int)*8 - 1))) #define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1)))
#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) #define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a))))
#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) #define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a)

40
opt/bignum.c
View file

@ -130,17 +130,11 @@ double sexp_bignum_to_double (sexp a) {
sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) { sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) {
sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a),
carry=b, i, n; carry=b, i=0, n;
for (i=0; i<len; i++) { do { n = data[i];
n = data[i];
data[i] += carry; data[i] += carry;
if (n > (SEXP_UINT_T_MAX - carry)) { carry = (n > (SEXP_UINT_T_MAX - carry));
carry = 1; } while (++i<len && carry);
} else {
carry = 0;
break;
}
}
if (carry) { if (carry) {
a = sexp_copy_bignum(ctx, NULL, a, len+1); a = sexp_copy_bignum(ctx, NULL, a, len+1);
sexp_bignum_data(a)[len] = 1; sexp_bignum_data(a)[len] = 1;
@ -149,11 +143,11 @@ sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) {
} }
sexp sexp_bignum_fxsub (sexp ctx, sexp a, sexp_uint_t b) { sexp sexp_bignum_fxsub (sexp ctx, sexp a, sexp_uint_t b) {
sexp_uint_t *data=sexp_bignum_data(a), borrow=b, i=0, n; sexp_uint_t *data=sexp_bignum_data(a), borrow, i=0, n;
for (borrow=b; borrow; i++) { for (borrow=b; borrow; i++) {
n = data[i]; n = data[i];
data[i] -= borrow; data[i] -= borrow;
borrow = ((n < borrow) ? 1 : 0); borrow = (n < borrow);
} }
return a; return a;
} }
@ -179,7 +173,7 @@ sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) {
} }
sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r; sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0;
int i; int i;
sexp_luint_t n = 0; sexp_luint_t n = 0;
for (i=len-1; i>=offset; i--) { for (i=len-1; i>=offset; i--) {
@ -470,13 +464,13 @@ static int sexp_number_types[] =
{0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0}; {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0};
static int sexp_number_type (sexp a) { static int sexp_number_type (sexp a) {
return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&1111] return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15]
: sexp_fixnump(a); : sexp_fixnump(a);
} }
sexp sexp_add (sexp ctx, sexp a, sexp b) { sexp sexp_add (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b), t; int at=sexp_number_type(a), bt=sexp_number_type(b), t;
sexp r; sexp r=SEXP_VOID;
if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;}
switch ((at << 2) + bt) { switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
@ -484,7 +478,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
r = sexp_type_exception(ctx, "+: not a number", a); r = sexp_type_exception(ctx, "+: not a number", a);
break; break;
case SEXP_NUM_FIX_FIX: case SEXP_NUM_FIX_FIX:
r = sexp_fx_add(a, b); /* XXXX check overflow */ r = sexp_fx_add(a, b); /* VM catches this case */
break; break;
case SEXP_NUM_FIX_FLO: case SEXP_NUM_FIX_FLO:
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b));
@ -507,7 +501,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
sexp sexp_sub (sexp ctx, sexp a, sexp b) { sexp sexp_sub (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b); int at=sexp_number_type(a), bt=sexp_number_type(b);
sexp r; sexp r=SEXP_VOID;
switch ((at << 2) + bt) { switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
@ -517,7 +511,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
r = sexp_type_exception(ctx, "-: not a number", b); r = sexp_type_exception(ctx, "-: not a number", b);
break; break;
case SEXP_NUM_FIX_FIX: case SEXP_NUM_FIX_FIX:
r = sexp_fx_sub(a, b); /* XXXX check overflow */ r = sexp_fx_sub(a, b); /* VM catches this case */
break; break;
case SEXP_NUM_FIX_FLO: case SEXP_NUM_FIX_FLO:
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b));
@ -550,7 +544,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
sexp sexp_mul (sexp ctx, sexp a, sexp b) { sexp sexp_mul (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b), t; int at=sexp_number_type(a), bt=sexp_number_type(b), t;
sexp r; sexp r=SEXP_VOID;
if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;}
switch ((at << 2) + bt) { switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
@ -583,7 +577,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) {
sexp sexp_div (sexp ctx, sexp a, sexp b) { sexp sexp_div (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b); int at=sexp_number_type(a), bt=sexp_number_type(b);
double f; double f;
sexp r, rem; sexp r=SEXP_VOID, rem;
switch ((at << 2) + bt) { switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
@ -632,7 +626,7 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
sexp sexp_quotient (sexp ctx, sexp a, sexp b) { sexp sexp_quotient (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b); int at=sexp_number_type(a), bt=sexp_number_type(b);
sexp r; sexp r=SEXP_VOID;
switch ((at << 2) + bt) { switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
@ -665,7 +659,7 @@ sexp sexp_quotient (sexp ctx, sexp a, sexp b) {
sexp sexp_remainder (sexp ctx, sexp a, sexp b) { sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b); int at=sexp_number_type(a), bt=sexp_number_type(b);
sexp r; sexp r=SEXP_VOID;
switch ((at << 2) + bt) { switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
@ -698,7 +692,7 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
sexp sexp_compare (sexp ctx, sexp a, sexp b) { sexp sexp_compare (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b); int at=sexp_number_type(a), bt=sexp_number_type(b);
sexp r; sexp r=SEXP_VOID;
double f; double f;
if (at > bt) { if (at > bt) {
r = sexp_compare(ctx, b, a); r = sexp_compare(ctx, b, a);

12
tests/numeric-tests.scm
View file

@ -128,6 +128,12 @@
(-12884901889 4294967297 36893488151714070528 0 -4294967296)) (-12884901889 4294967297 36893488151714070528 0 -4294967296))
(sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) (sign-combinations (expt 2 32) (+ 1 (expt 2 33))))
(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296)
(18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296)
(-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296)
(-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296))
(sign-combinations (expt 2 32) (+ 1 (expt 2 64))))
;; bigger x big ;; bigger x big
(test '((12884901889 4294967297 36893488151714070528 2 1) (test '((12884901889 4294967297 36893488151714070528 2 1)
(-4294967297 -12884901889 -36893488151714070528 -2 -1) (-4294967297 -12884901889 -36893488151714070528 -2 -1)
@ -135,4 +141,10 @@
(-12884901889 -4294967297 36893488151714070528 2 -1)) (-12884901889 -4294967297 36893488151714070528 2 -1))
(sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) (sign-combinations (+ 1 (expt 2 33)) (expt 2 32)))
(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1)
(-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1)
(18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1)
(-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1))
(sign-combinations (+ 1 (expt 2 64)) (expt 2 32)))
(test-report) (test-report)