mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 21:59:17 +02:00
8b5eb68238
They can be close()d explicitly with close-file-descriptor, and will close() on gc, but only explicitly closing the last port on them will close the fileno. Notably needed for network sockets where we open separate input and output ports on the same socket.
322 lines
10 KiB
C
322 lines
10 KiB
C
/* bit.c -- bitwise operators */
|
|
/* Copyright (c) 2009-2012 Alex Shinn. All rights reserved. */
|
|
/* BSD-style license: http://synthcode.com/license.txt */
|
|
|
|
#include <chibi/eval.h>
|
|
|
|
#ifndef PLAN9
|
|
#include <limits.h>
|
|
#else
|
|
#define CHAR_BIT 8
|
|
#endif
|
|
|
|
#if SEXP_USE_BIGNUMS
|
|
#include <chibi/bignum.h>
|
|
#else
|
|
#define sexp_bignum_normalize(x) x
|
|
#endif
|
|
|
|
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);
|
|
#if SEXP_USE_BIGNUMS
|
|
} 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);
|
|
else
|
|
res = sexp_copy_bignum(ctx, NULL, y, 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];
|
|
} else {
|
|
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
|
|
}
|
|
#endif
|
|
} else {
|
|
res = 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) {
|
|
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_ior(ctx, self, n, y, x);
|
|
#endif
|
|
else
|
|
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
|
|
#if SEXP_USE_BIGNUMS
|
|
} else if (sexp_bignump(x)) {
|
|
if (sexp_fixnump(y)) {
|
|
res = sexp_copy_bignum(ctx, NULL, x, 0);
|
|
sexp_bignum_data(res)[0] |= (sexp_uint_t)sexp_unbox_fixnum(y);
|
|
} else if (sexp_bignump(y)) {
|
|
if (sexp_bignum_length(x) >= sexp_bignum_length(y)) {
|
|
res = sexp_copy_bignum(ctx, NULL, x, 0);
|
|
len = sexp_bignum_length(y);
|
|
} else {
|
|
res = sexp_copy_bignum(ctx, NULL, y, 0);
|
|
len = sexp_bignum_length(x);
|
|
}
|
|
for (i=0; i<len; i++)
|
|
sexp_bignum_data(res)[i]
|
|
= sexp_bignum_data(x)[i] | sexp_bignum_data(y)[i];
|
|
} else {
|
|
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
|
|
}
|
|
#endif
|
|
} else {
|
|
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
|
|
}
|
|
return sexp_bignum_normalize(res);
|
|
}
|
|
|
|
static sexp sexp_bit_xor (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_make_fixnum(sexp_unbox_fixnum(x) ^ sexp_unbox_fixnum(y));
|
|
#if SEXP_USE_BIGNUMS
|
|
else if (sexp_bignump(y))
|
|
res = sexp_bit_xor(ctx, self, n, y, x);
|
|
#endif
|
|
else
|
|
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
|
|
#if SEXP_USE_BIGNUMS
|
|
} else if (sexp_bignump(x)) {
|
|
if (sexp_fixnump(y)) {
|
|
res = sexp_copy_bignum(ctx, NULL, x, 0);
|
|
sexp_bignum_data(res)[0] ^= sexp_unbox_fixnum(y);
|
|
} else if (sexp_bignump(y)) {
|
|
if (sexp_bignum_length(x) >= sexp_bignum_length(y)) {
|
|
res = sexp_copy_bignum(ctx, NULL, x, 0);
|
|
len = sexp_bignum_length(y);
|
|
} else {
|
|
res = sexp_copy_bignum(ctx, NULL, y, 0);
|
|
len = sexp_bignum_length(x);
|
|
}
|
|
for (i=0; i<len; i++)
|
|
sexp_bignum_data(res)[i]
|
|
= sexp_bignum_data(x)[i] ^ sexp_bignum_data(y)[i];
|
|
} else {
|
|
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
|
|
}
|
|
#endif
|
|
} else {
|
|
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
|
|
}
|
|
return sexp_bignum_normalize(res);
|
|
}
|
|
|
|
static int log2i(sexp_uint_t v) {
|
|
int i;
|
|
for (i = 0; i < sizeof(v)*8; i++)
|
|
if (((sexp_uint_t)1<<(i+1)) > v)
|
|
break;
|
|
return i;
|
|
}
|
|
|
|
/* should probably split into left and right shifts, that's a better */
|
|
/* interface anyway */
|
|
static sexp sexp_arithmetic_shift (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp count) {
|
|
sexp_uint_t tmp;
|
|
sexp_sint_t c;
|
|
#if SEXP_USE_BIGNUMS
|
|
sexp_sint_t len, offset, bit_shift, tail_shift, j;
|
|
sexp_gc_var1(res);
|
|
#else
|
|
sexp res;
|
|
#endif
|
|
if (! sexp_fixnump(count))
|
|
return sexp_type_exception(ctx, self, SEXP_FIXNUM, count);
|
|
c = sexp_unbox_fixnum(count);
|
|
if (c == 0) return i;
|
|
if (sexp_fixnump(i)) {
|
|
if (c < 0) {
|
|
res = sexp_make_fixnum(sexp_unbox_fixnum(i) >> -c);
|
|
} else {
|
|
#if SEXP_USE_BIGNUMS
|
|
if ((log2i(sexp_unbox_fixnum(i)) + c + 1)
|
|
< (sizeof(sexp_uint_t)*CHAR_BIT - SEXP_FIXNUM_BITS)) {
|
|
#endif
|
|
tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c;
|
|
res = sexp_make_fixnum(tmp * sexp_fx_sign(i));
|
|
#if SEXP_USE_BIGNUMS
|
|
} else {
|
|
sexp_gc_preserve1(ctx, res);
|
|
res = sexp_fixnum_to_bignum(ctx, i);
|
|
res = sexp_arithmetic_shift(ctx, self, n, res, count);
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
#endif
|
|
}
|
|
#if SEXP_USE_BIGNUMS
|
|
} else if (sexp_bignump(i)) {
|
|
len = sexp_bignum_hi(i);
|
|
if (c < 0) {
|
|
c = -c;
|
|
offset = c / (sizeof(sexp_uint_t)*CHAR_BIT);
|
|
bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT);
|
|
if (len < offset) {
|
|
res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1);
|
|
} else {
|
|
res = sexp_make_bignum(ctx, len - offset + 1);
|
|
sexp_bignum_sign(res) = sexp_bignum_sign(i);
|
|
for (j=len-offset-1, tmp=0; j>=0; j--) {
|
|
sexp_bignum_data(res)[j]
|
|
= (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp;
|
|
tmp = sexp_bignum_data(i)[j+offset]
|
|
<< (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift);
|
|
}
|
|
}
|
|
} else {
|
|
offset = c / (sizeof(sexp_uint_t)*CHAR_BIT);
|
|
bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT);
|
|
tail_shift = (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift);
|
|
res = sexp_make_bignum(ctx, len + offset + 1);
|
|
sexp_bignum_sign(res) = sexp_bignum_sign(i);
|
|
for (j=tmp=0; j<len; j++) {
|
|
sexp_bignum_data(res)[j+offset]
|
|
= (sexp_bignum_data(i)[j] << bit_shift) + tmp;
|
|
tmp = sexp_bignum_data(i)[j] >> tail_shift;
|
|
}
|
|
if (bit_shift != 0) sexp_bignum_data(res)[len+offset] = tmp;
|
|
}
|
|
#endif
|
|
} else {
|
|
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i);
|
|
}
|
|
return sexp_bignum_normalize(res);
|
|
}
|
|
|
|
/* bit-count and integer-length were adapted from: */
|
|
/* http://graphics.stanford.edu/~seander/bithacks.html */
|
|
static sexp_uint_t bit_count (sexp_uint_t i) {
|
|
i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3);
|
|
i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3)
|
|
+ ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3));
|
|
i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15;
|
|
return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255))
|
|
>> (sizeof(i) - 1) * CHAR_BIT);
|
|
}
|
|
|
|
static sexp sexp_bit_count (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
|
sexp res;
|
|
sexp_sint_t i;
|
|
#if SEXP_USE_BIGNUMS
|
|
sexp_uint_t count;
|
|
#endif
|
|
if (sexp_fixnump(x)) {
|
|
i = sexp_unbox_fixnum(x);
|
|
res = sexp_make_fixnum(bit_count(i<0 ? ~i : i));
|
|
#if SEXP_USE_BIGNUMS
|
|
} else if (sexp_bignump(x)) {
|
|
for (i=count=0; i<sexp_bignum_length(x); i++)
|
|
count += bit_count(sexp_bignum_data(x)[i]);
|
|
res = sexp_make_fixnum(count);
|
|
#endif
|
|
} else {
|
|
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
static const char log_table_256[256] =
|
|
{
|
|
#define LT(n) n, n, n, n, n, n, n, n, n, n, n, n, n, n, n, n
|
|
0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4,
|
|
LT(5), LT(6), LT(7), LT(7), LT(7), LT(7), LT(7),
|
|
LT(8), LT(8), LT(8), LT(8), LT(8), LT(8), LT(8), LT(8)
|
|
};
|
|
|
|
static sexp_uint_t integer_log2 (sexp_uint_t x) {
|
|
sexp_uint_t t, tt;
|
|
#if SEXP_64_BIT
|
|
if ((tt = x >> 32))
|
|
return integer_log2(tt) + 32;
|
|
else
|
|
#endif
|
|
if ((tt = x >> 16))
|
|
return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt];
|
|
else
|
|
return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x];
|
|
}
|
|
|
|
static sexp sexp_integer_length (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
|
|
sexp_sint_t tmp;
|
|
#if SEXP_USE_BIGNUMS
|
|
sexp_sint_t hi;
|
|
#endif
|
|
if (sexp_fixnump(x)) {
|
|
tmp = sexp_unbox_fixnum(x);
|
|
return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp));
|
|
#if SEXP_USE_BIGNUMS
|
|
} else if (sexp_bignump(x)) {
|
|
hi = sexp_bignum_hi(x);
|
|
return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi-1])
|
|
+ (hi-1)*sizeof(sexp_uint_t)*CHAR_BIT);
|
|
#endif
|
|
} else {
|
|
return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
|
|
}
|
|
}
|
|
|
|
static sexp sexp_bit_set_p (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp x) {
|
|
#if SEXP_USE_BIGNUMS
|
|
sexp_uint_t pos;
|
|
#endif
|
|
if (! sexp_fixnump(i))
|
|
return sexp_type_exception(ctx, self, SEXP_FIXNUM, i);
|
|
if (sexp_fixnump(x)) {
|
|
return sexp_make_boolean(sexp_unbox_fixnum(x) & (1UL<<sexp_unbox_fixnum(i)));
|
|
#if SEXP_USE_BIGNUMS
|
|
} else if (sexp_bignump(x)) {
|
|
pos = sexp_unbox_fixnum(i) / (sizeof(sexp_uint_t)*CHAR_BIT);
|
|
return sexp_make_boolean((pos < sexp_bignum_length(x))
|
|
&& (sexp_bignum_data(x)[pos]
|
|
& (1UL<<(sexp_unbox_fixnum(i)
|
|
- pos*sizeof(sexp_uint_t)*CHAR_BIT))));
|
|
#endif
|
|
} else {
|
|
return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
|
|
}
|
|
}
|
|
|
|
sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) {
|
|
if (!(sexp_version_compatible(ctx, version, sexp_version)
|
|
&& sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
|
|
return SEXP_ABI_ERROR;
|
|
sexp_define_foreign(ctx, env, "bit-and", 2, sexp_bit_and);
|
|
sexp_define_foreign(ctx, env, "bit-ior", 2, sexp_bit_ior);
|
|
sexp_define_foreign(ctx, env, "bit-xor", 2, sexp_bit_xor);
|
|
sexp_define_foreign(ctx, env, "arithmetic-shift", 2, sexp_arithmetic_shift);
|
|
sexp_define_foreign(ctx, env, "bit-count", 1, sexp_bit_count);
|
|
sexp_define_foreign(ctx, env, "integer-length", 1, sexp_integer_length);
|
|
sexp_define_foreign(ctx, env, "bit-set?", 2, sexp_bit_set_p);
|
|
return SEXP_VOID;
|
|
}
|
|
|