Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-11 23:17:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fixing bitwise-and for negative bignums

Browse source 
(necessary for sha2 implementation on 32-bit machines).
This commit is contained in:
Alex Shinn 2014-06-29 11:28:56 +09:00
parent 5a510560ca
commit bb3ac57b6d
2 changed files with 64 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
lib/srfi/33/bit.c
View file

@ -16,40 +16,70 @@
#define sexp_bignum_normalize(x) x
#endif
static sexp sexp_twos_complement (sexp ctx, sexp x) {
int i;
sexp_gc_var1(res);
if (sexp_bignump(x) && sexp_bignum_sign(x) < 0) {
sexp_gc_preserve1(ctx, res);
res = sexp_copy_bignum(ctx, NULL, x, 0);
sexp_bignum_sign(res) = 1;
for (i = sexp_bignum_length(res)-1; i >= 0; i--)
sexp_bignum_data(res)[i] = ~sexp_bignum_data(res)[i];
res = sexp_bignum_fxadd(ctx, res, 1);
sexp_gc_release1(ctx);
return res;
}
return x;
}
static sexp sexp_fixnum_to_twos_complement (sexp ctx, sexp x, int len) {
int i;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_bignum(ctx, len);
for (i = len-1; i > 0; i--)
sexp_bignum_data(res)[i] = (sexp_uint_t)((sexp_sint_t)-1);
sexp_bignum_data(res)[0] = ~(-(sexp_unbox_fixnum(x)));
res = sexp_bignum_fxadd(ctx, res, 1);
sexp_gc_release1(ctx);
return res;
}
static sexp sexp_bit_and (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
sexp res;
#if SEXP_USE_BIGNUMS
sexp_sint_t len, i;
#endif
if (sexp_fixnump(x)) {
if (sexp_fixnump(y))
res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y);
#if SEXP_USE_BIGNUMS
else if (sexp_bignump(y))
res = sexp_bit_and(ctx, self, n, y, x);
#endif
else
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
sexp_gc_var3(res, x2, y2);
if (sexp_fixnump(x) && sexp_fixnump(y)) {
return (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); /* safe to AND tags */
#if SEXP_USE_BIGNUMS
} else if (sexp_fixnump(x) && sexp_bignump(y)) {
return sexp_bit_and(ctx, self, n, y, x);
} else if (sexp_bignump(x)) {
if (sexp_fixnump(y)) {
res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]);
} else if (sexp_bignump(y)) {
if (sexp_bignum_length(x) < sexp_bignum_length(y))
res = sexp_copy_bignum(ctx, NULL, x, 0);
sexp_gc_preserve3(ctx, res, x2, y2);
x2 = sexp_twos_complement(ctx, x);
y2 = sexp_twos_complement(ctx, y);
if (sexp_fixnump(y2) && sexp_negativep(y2))
y2 = sexp_fixnum_to_twos_complement(ctx, y2, sexp_bignum_length(x2));
if (sexp_fixnump(y2)) {
res = sexp_make_fixnum(sexp_unbox_fixnum(y2) & sexp_bignum_data(x2)[0]);
} else if (sexp_bignump(y2)) {
if (sexp_bignum_length(x2) < sexp_bignum_length(y2))
res = sexp_copy_bignum(ctx, NULL, x2, 0);
else
res = sexp_copy_bignum(ctx, NULL, y, 0);
res = sexp_copy_bignum(ctx, NULL, y2, 0);
for (i=0, len=sexp_bignum_length(res); i<len; i++)
sexp_bignum_data(res)[i]
= sexp_bignum_data(x)[i] & sexp_bignum_data(y)[i];
= sexp_bignum_data(x2)[i] & sexp_bignum_data(y2)[i];
} else {
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y2);
}
sexp_gc_release3(ctx);
return sexp_bignum_normalize(res);
#endif
} else {
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
}
return sexp_bignum_normalize(res);
}
static sexp sexp_bit_ior (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {

14
tests/srfi-33-tests.scm
View file

@ -3,6 +3,20 @@
(test-begin "srfi-33")
(test 0 (bitwise-and #b0 #b1))
(test 1 (bitwise-and #b1 #b1))
(test 0 (bitwise-and #b1 #b10))
(test #b10 (bitwise-and #b11 #b10))
(test #b101 (bitwise-and #b101 #b111))
(test #b111 (bitwise-and -1 #b111))
(test #b110 (bitwise-and -2 #b111))
(test 3769478 (bitwise-and -4290775858 1694076839))
(test 1680869008 (bitwise-and -193073517 1689392892))
;; (test -2600468497 (bitwise-ior 1694076839 -4290775858))
;; (test -184549633 (bitwise-ior -193073517 1689392892))
;; (test -2604237975 (bitwise-xor 1694076839 -4290775858))
;; (test -1865418641 (bitwise-xor -193073517 1689392892))
(test 1 (arithmetic-shift 1 0))
(test 2 (arithmetic-shift 1 1))
(test 4 (arithmetic-shift 1 2))