581 lines
17 KiB
C
581 lines
17 KiB
C
/* bitstring.c
|
|
*
|
|
* $Id$
|
|
*
|
|
* Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
|
|
* Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
|
|
*
|
|
* This software was derived from Elk 1.2, which was Copyright 1987, 1988,
|
|
* 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
|
|
* by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
|
|
* between TELES and Nixdorf Microprocessor Engineering, Berlin).
|
|
*
|
|
* Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
|
|
* owners or individual owners of copyright in this software, grant to any
|
|
* person or company a worldwide, royalty free, license to
|
|
*
|
|
* i) copy this software,
|
|
* ii) prepare derivative works based on this software,
|
|
* iii) distribute copies of this software or derivative works,
|
|
* iv) perform this software, or
|
|
* v) display this software,
|
|
*
|
|
* provided that this notice is not removed and that neither Oliver Laumann
|
|
* nor Teles nor Nixdorf are deemed to have made any representations as to
|
|
* the suitability of this software for any purpose nor are held responsible
|
|
* for any defects of this software.
|
|
*
|
|
* THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
|
|
*/
|
|
|
|
#include "config.h"
|
|
|
|
#include <string.h>
|
|
#include <stdlib.h>
|
|
|
|
#include "scheme.h"
|
|
|
|
#define BITSTRING(x) ((struct S_Bitstring *)POINTER(x))
|
|
|
|
struct S_Bitstring {
|
|
Object tag;
|
|
unsigned len; /* # of used bits; unused bits in MSB always 0 */
|
|
unsigned char data[1]; /* data[0] == LSB */
|
|
};
|
|
|
|
#define bits_to_bytes(b) (((b)+7)/8)
|
|
|
|
static int masks[] = { 0, 0x1, 0x2, 0x4, 0x8, 0x10, 0x20, 0x40, 0x80 };
|
|
static int masks2[] = { 0, 0x1, 0x3, 0x7, 0xF, 0x1F, 0x3F, 0x7F, 0xFF };
|
|
|
|
int T_Bitstring;
|
|
|
|
static Object P_Bitstringp(Object x) {
|
|
return TYPE(x) == T_Bitstring ? True : False;
|
|
}
|
|
|
|
static int Bitstring_Size(Object b) {
|
|
return sizeof(struct S_Bitstring) + bits_to_bytes(BITSTRING(b)->len) - 1;
|
|
}
|
|
|
|
static int Bitstring_Equal(Object b1, Object b2) {
|
|
struct S_Bitstring *a = BITSTRING(b1), *b = BITSTRING(b2);
|
|
|
|
if (a->len != b->len)
|
|
return 0;
|
|
return !memcmp(a->data, b->data, bits_to_bytes(a->len));
|
|
}
|
|
|
|
static Object P_Bitstring_Equalp(Object a, Object b) {
|
|
return Bitstring_Equal(a, b) ? True : False;
|
|
}
|
|
|
|
static char *Digits(unsigned char c, int n) {
|
|
static char buf[9];
|
|
int i = 0;
|
|
|
|
for (; n > 0; n--)
|
|
buf[i++] = c & masks[n] ? '1' : '0';
|
|
buf[i] = '\0';
|
|
return buf;
|
|
}
|
|
|
|
/* Print starting with MSB
|
|
*/
|
|
static int Bitstring_Print(Object x, Object port, int raw, int depth,
|
|
int length) {
|
|
int i, rem;
|
|
struct S_Bitstring *b = BITSTRING(x);
|
|
GC_Node2;
|
|
|
|
GC_Link2(x, port);
|
|
Printf(port, "#*");
|
|
i = bits_to_bytes(b->len) - 1;
|
|
rem = b->len;
|
|
if (rem % 8)
|
|
Printf(port, Digits(b->data[i--], rem));
|
|
for ( ; i >= 0; i--)
|
|
Printf(port, Digits(b->data[i], 8));
|
|
GC_Unlink;
|
|
return 0;
|
|
}
|
|
|
|
static Object Make_Bitstring(unsigned int len) {
|
|
Object b;
|
|
int nbytes = bits_to_bytes(len);
|
|
|
|
b = Alloc_Object(sizeof(struct S_Bitstring) + nbytes-1, T_Bitstring, 0);
|
|
memset((char *)BITSTRING(b)->data, 0, nbytes);
|
|
BITSTRING(b)->tag = Null;
|
|
BITSTRING(b)->len = len;
|
|
return b;
|
|
}
|
|
|
|
static void Fill_Bitstring(Object bs, int fill) {
|
|
struct S_Bitstring *b = BITSTRING(bs);
|
|
int i, rem;
|
|
unsigned char val = fill ? ~0 : 0;
|
|
|
|
i = bits_to_bytes(b->len) - 1;
|
|
if (val && (rem = b->len % 8))
|
|
b->data[i--] |= masks2[rem];
|
|
for ( ; i >= 0; i--)
|
|
b->data[i] = val;
|
|
}
|
|
|
|
static Object P_Make_Bitstring(Object len, Object init) {
|
|
Object ret;
|
|
int n, fill;
|
|
|
|
if ((n = Get_Integer(len)) < 0)
|
|
Range_Error(len);
|
|
Check_Type(init, T_Boolean);
|
|
fill = Truep(init);
|
|
ret = Make_Bitstring((unsigned)n);
|
|
if (fill)
|
|
Fill_Bitstring(ret, 1);
|
|
return ret;
|
|
}
|
|
|
|
static Object P_Bitstring_Length(Object bs) {
|
|
Check_Type(bs, T_Bitstring);
|
|
return Make_Unsigned(BITSTRING(bs)->len);
|
|
}
|
|
|
|
static int Ulong_Size(unsigned long ul) {
|
|
int n;
|
|
|
|
for (n = 0; ul; ul >>= 1, n++)
|
|
;
|
|
return n;
|
|
}
|
|
|
|
static Object Ulong_To_Bitstring(unsigned long ul, unsigned int len) {
|
|
Object ret;
|
|
struct S_Bitstring *b;
|
|
unsigned int i, siz = Ulong_Size(ul);
|
|
char buf[50];
|
|
|
|
ret = Make_Bitstring(len);
|
|
b = BITSTRING(ret);
|
|
if (siz > len) {
|
|
sprintf(buf, "length %u too small for integer %lu", len, ul);
|
|
Primitive_Error(buf);
|
|
}
|
|
for (i = 0; ul; ul >>= 8, i++)
|
|
b->data[i] = ul & 0xFF;
|
|
return ret;
|
|
}
|
|
|
|
static unsigned int Bigbits(struct S_Bignum *b) {
|
|
return b->usize ? (Ulong_Size((unsigned long)b->data[b->usize-1]) +
|
|
(b->usize-1) * sizeof(gran_t) * 8) : 0;
|
|
}
|
|
|
|
static Object Bignum_To_Bitstring(Object big, unsigned int len) {
|
|
char buf[50];
|
|
Object ret;
|
|
struct S_Bitstring *b;
|
|
struct S_Bignum *bn;
|
|
unsigned int k, i, n;
|
|
GC_Node;
|
|
|
|
if (Bigbits(BIGNUM(big)) > len) {
|
|
sprintf(buf, "length %u too small for integer ~s", len);
|
|
Primitive_Error(buf, big);
|
|
}
|
|
GC_Link(big);
|
|
ret = Make_Bitstring(len);
|
|
GC_Unlink;
|
|
b = BITSTRING(ret);
|
|
bn = BIGNUM(big);
|
|
n = bits_to_bytes(len);
|
|
for (i = k = 0; k < bn->usize; k++, i++) {
|
|
b->data[i] = bn->data[k] & 0xFF;
|
|
if (i < n)
|
|
b->data[++i] = bn->data[k] >> 8 & 0xFF;
|
|
}
|
|
return ret;
|
|
}
|
|
|
|
static Object P_Int_To_Bitstring(Object len, Object i) {
|
|
Object isneg;
|
|
int ilen;
|
|
|
|
if ((ilen = Get_Integer(len)) < 0)
|
|
Range_Error(len);
|
|
Check_Integer(i);
|
|
isneg = P_Negativep(i);
|
|
if (Truep(isneg))
|
|
Range_Error(i);
|
|
if (TYPE(i) == T_Fixnum)
|
|
return Ulong_To_Bitstring((unsigned long)FIXNUM(i), (unsigned)ilen);
|
|
return Bignum_To_Bitstring(i, (unsigned)ilen);
|
|
}
|
|
|
|
static Object Bitstring_To_Bignum (Object bs) {
|
|
struct S_Bitstring *b;
|
|
Object big;
|
|
int i, n, k;
|
|
gran_t digit;
|
|
GC_Node;
|
|
|
|
n = bits_to_bytes(BITSTRING(bs)->len);
|
|
GC_Link(bs);
|
|
big = Make_Uninitialized_Bignum((n+1)/2); /* assume sizeof(gran_t)==2 */
|
|
GC_Unlink;
|
|
b = BITSTRING(bs);
|
|
for (i = k = 0; i < n; k++, i++) {
|
|
digit = b->data[i];
|
|
if (!(i & 1))
|
|
digit |= (unsigned)b->data[++i] << 8;
|
|
BIGNUM(big)->data[k] = digit;
|
|
}
|
|
BIGNUM(big)->usize = k;
|
|
Bignum_Normalize_In_Place (BIGNUM(big));
|
|
return big;
|
|
}
|
|
|
|
static Object P_Bitstring_To_Int(Object bs) {
|
|
struct S_Bitstring *b;
|
|
unsigned int u = 0;
|
|
int i;
|
|
|
|
Check_Type(bs, T_Bitstring);
|
|
b = BITSTRING(bs);
|
|
|
|
/* If there are any 1 bits above the position which fits in an
|
|
* integer, use a bignum */
|
|
if (b->len >= FIXBITS)
|
|
{
|
|
if (b->data[sizeof(int) - 1] & (1 << 7))
|
|
return Bitstring_To_Bignum(bs);
|
|
|
|
for (i = sizeof(int); i < (int)bits_to_bytes(b->len); i++) {
|
|
if (b->data[i] != 0)
|
|
return Bitstring_To_Bignum(bs);
|
|
}
|
|
}
|
|
|
|
/* Otherwise, use an integer */
|
|
for (i = bits_to_bytes(b->len) - 1; i >= 0; i--)
|
|
u = u << 8 | b->data[i];
|
|
|
|
return Make_Integer(u);
|
|
}
|
|
|
|
static Object P_Bitstring_Ref(Object bs, Object inx) {
|
|
struct S_Bitstring *b;
|
|
int i;
|
|
|
|
Check_Type(bs, T_Bitstring);
|
|
b = BITSTRING(bs);
|
|
i = Get_Integer(inx);
|
|
if (i < 0 || i >= (int)b->len)
|
|
Range_Error(inx);
|
|
return b->data[i/8] & 1 << i % 8 ? True : False;
|
|
}
|
|
|
|
static Object P_Bitstring_Set(Object bs, Object inx, Object val) {
|
|
int old, i, j, mask;
|
|
struct S_Bitstring *b;
|
|
|
|
Check_Type(bs, T_Bitstring);
|
|
Check_Type(val, T_Boolean);
|
|
b = BITSTRING(bs);
|
|
i = Get_Integer(inx);
|
|
if (i < 0 || i >= (int)b->len)
|
|
Range_Error(inx);
|
|
j = i/8;
|
|
mask = 1 << i%8;
|
|
old = b->data[j] & mask;
|
|
if (Truep(val))
|
|
b->data[j] |= mask;
|
|
else
|
|
b->data[j] &= ~mask;
|
|
return old ? True : False;
|
|
}
|
|
|
|
static Object P_Bitstring_Zerop(Object bs) {
|
|
struct S_Bitstring *b;
|
|
int i;
|
|
|
|
Check_Type(bs, T_Bitstring);
|
|
b = BITSTRING(bs);
|
|
for (i = bits_to_bytes(b->len); --i >= 0 && b->data[i] == 0 ;)
|
|
;
|
|
return i < 0 ? True : False;
|
|
}
|
|
|
|
static Object P_Bitstring_Fill(Object bs, Object fill) {
|
|
Check_Type(bs, T_Bitstring);
|
|
Check_Type(fill, T_Boolean);
|
|
Fill_Bitstring(bs, Truep(fill));
|
|
return Void;
|
|
}
|
|
|
|
#define bitop(name, op) static void name(struct S_Bitstring *a,\
|
|
struct S_Bitstring *b) {\
|
|
int i, rem;\
|
|
\
|
|
if (a->len != b->len) {\
|
|
printf("bitstrings must be of same length\n"); exit(1);\
|
|
}\
|
|
i = bits_to_bytes(a->len) - 1;\
|
|
rem = a->len % 8;\
|
|
if (rem % 8) {\
|
|
a->data[i] op b->data[i];\
|
|
a->data[i--] &= masks2[rem];\
|
|
}\
|
|
for ( ; i >= 0; i--)\
|
|
a->data[i] op b->data[i];\
|
|
}
|
|
|
|
bitop(bmove, =)
|
|
bitop(bnot, = ~)
|
|
bitop(band, &=)
|
|
bitop(bor, |=)
|
|
bitop(bandnot, &= ~)
|
|
bitop(bxor, ^=)
|
|
|
|
static Object Bit_Operation(Object b1, Object b2, void (*fun)()) {
|
|
struct S_Bitstring *a, *b;
|
|
|
|
Check_Type(b1, T_Bitstring);
|
|
Check_Type(b2, T_Bitstring);
|
|
a = BITSTRING(b1);
|
|
b = BITSTRING(b2);
|
|
if (a->len != b->len)
|
|
Primitive_Error("bitstrings must have identical length");
|
|
fun(a, b);
|
|
return Void;
|
|
}
|
|
|
|
static Object P_Bitstring_Move(Object a, Object b) {
|
|
return Bit_Operation(a, b, bmove);
|
|
}
|
|
|
|
static Object P_Bitstring_Not(Object a, Object b) {
|
|
return Bit_Operation(a, b, bnot);
|
|
}
|
|
|
|
static Object P_Bitstring_And(Object a, Object b) {
|
|
return Bit_Operation(a, b, band);
|
|
}
|
|
|
|
static Object P_Bitstring_Or(Object a, Object b) {
|
|
return Bit_Operation(a, b, bor);
|
|
}
|
|
|
|
static Object P_Bitstring_Andnot(Object a, Object b) {
|
|
return Bit_Operation(a, b, bandnot);
|
|
}
|
|
|
|
static Object P_Bitstring_Xor(Object a, Object b) {
|
|
return Bit_Operation(a, b, bxor);
|
|
}
|
|
|
|
static Object P_Substring_Move(Object b1, Object from, Object to,
|
|
Object b2, Object dst) {
|
|
struct S_Bitstring *a, *b;
|
|
int start1, end1, start2, end2, len, off1, off2, i, j;
|
|
unsigned char mask;
|
|
|
|
Check_Type(b1, T_Bitstring);
|
|
Check_Type(b2, T_Bitstring);
|
|
a = BITSTRING(b1);
|
|
b = BITSTRING(b2);
|
|
start1 = Get_Integer(from);
|
|
end1 = Get_Integer(to);
|
|
start2 = Get_Integer(dst);
|
|
len = end1 - start1;
|
|
end2 = start2 + len;
|
|
|
|
if (start1 < 0 || start1 > end1)
|
|
Range_Error(from);
|
|
if (end1 > (int)a->len)
|
|
Range_Error(to);
|
|
if (start2 < 0 || end2 > (int)b->len)
|
|
Range_Error(dst);
|
|
|
|
if (a == b && start2 < start1) { /* copy forward (LSB to MSB) */
|
|
off1 = start1 % 8;
|
|
off2 = start2 % 8;
|
|
i = start1 / 8;
|
|
j = start2 / 8;
|
|
if (off1 == off2) {
|
|
if (off1) {
|
|
mask = 0xFF & ~masks2[off1];
|
|
if (off1 + len < 8)
|
|
mask &= masks2[off1+len];
|
|
b->data[j] = (b->data[j] & ~mask) | (a->data[i] & mask);
|
|
len -= 8 - off1; i++; j++;
|
|
}
|
|
for (; len >= 8; len -= 8)
|
|
b->data[j++] = a->data[i++];
|
|
if (len > 0) {
|
|
mask = masks2[len];
|
|
b->data[j] = (b->data[j] & ~mask) | (a->data[i] & mask);
|
|
}
|
|
} else {
|
|
unsigned char dmask;
|
|
int n, delta, shift;
|
|
|
|
while (len > 0) {
|
|
shift = delta = off2 - off1;
|
|
if (shift < 0)
|
|
shift = -shift;
|
|
n = 8 - off1;
|
|
mask = 0xFF & ~masks2[off1];
|
|
if (len < n) {
|
|
n = len;
|
|
mask &= masks2[off1+len];
|
|
}
|
|
if (8 - off2 >= n) { /* rest of src byte fits into dst byte */
|
|
|
|
if (delta > 0) {
|
|
dmask = mask << shift;
|
|
b->data[j] = (b->data[j] & ~dmask) |
|
|
(a->data[i] & mask) << shift;
|
|
} else {
|
|
dmask = mask >> shift;
|
|
b->data[j] = (b->data[j] & ~dmask) |
|
|
(unsigned int)(a->data[i] & mask) >> shift;
|
|
}
|
|
} else { /* nope, copy as many bits as fit into dst bye */
|
|
|
|
n = 8 - off2;
|
|
mask &= masks2[off1+n];
|
|
dmask = mask << shift;
|
|
b->data[j] = (b->data[j] & ~dmask) |
|
|
(a->data[i] & mask) << shift;
|
|
}
|
|
|
|
if (off1 + n >= 8) i++;
|
|
if (off2 + n >= 8) j++;
|
|
off1 = (off1 + n) % 8;
|
|
off2 = (off2 + n) % 8;
|
|
len -= n;
|
|
}
|
|
}
|
|
} else { /* copy backwards (MSB to LSB) */
|
|
|
|
if ((off1 = end1 % 8 - 1) < 0) off1 = 7;
|
|
if ((off2 = end2 % 8 - 1) < 0) off2 = 7;
|
|
i = (end1 - 1) / 8;
|
|
j = (end2 - 1) / 8;
|
|
if (off1 == off2) {
|
|
if (off1 < 7) {
|
|
if (len <= off1)
|
|
mask = masks2[len] << (off1-len+1);
|
|
else
|
|
mask = masks2[off1+1];
|
|
b->data[j] = (b->data[j] & ~mask) | (a->data[i] & mask);
|
|
len -= off1+1; i--; j--;
|
|
}
|
|
for (; len >= 8; len -= 8)
|
|
b->data[j--] = a->data[i--];
|
|
if (len > 0) {
|
|
mask = masks2[len] << (8 - len);
|
|
b->data[j] = (b->data[j] & ~mask) | (a->data[i] & mask);
|
|
}
|
|
} else {
|
|
unsigned char dmask;
|
|
int n, delta, shift;
|
|
|
|
while (len > 0) {
|
|
shift = delta = off2 - off1;
|
|
if (shift < 0)
|
|
shift = -shift;
|
|
n = off1 + 1;
|
|
mask = masks2[n];
|
|
if (len < n) {
|
|
mask = masks2[len] << (n-len);
|
|
n = len;
|
|
}
|
|
if (off2 + 1 >= n) { /* rest of src byte fits into dst byte */
|
|
|
|
if (delta > 0) {
|
|
dmask = mask << shift;
|
|
b->data[j] = (b->data[j] & ~dmask) |
|
|
(a->data[i] & mask) << shift;
|
|
} else {
|
|
dmask = mask >> shift;
|
|
b->data[j] = (b->data[j] & ~dmask) |
|
|
(unsigned int)(a->data[i] & mask) >> shift;
|
|
}
|
|
} else { /* nope, copy as many bits as fit into dst bye */
|
|
|
|
n = off2 + 1;
|
|
mask = masks2[n] << (off1-n+1);
|
|
dmask = mask >> shift;
|
|
b->data[j] = (b->data[j] & ~dmask) |
|
|
(unsigned int)(a->data[i] & mask) >> shift;
|
|
}
|
|
|
|
if (off1 - n < 0) i--;
|
|
if (off2 - n < 0) j--;
|
|
if ((off1 -= n) < 0) off1 += 8;
|
|
if ((off2 -= n) < 0) off2 += 8;
|
|
len -= n;
|
|
}
|
|
}
|
|
}
|
|
return Void;
|
|
}
|
|
|
|
/*ARGSUSED*/
|
|
static Object Bitstring_Read(Object port, int chr, int konst) {
|
|
int c, str, i;
|
|
FILE *f;
|
|
char buf[1024], *p = buf;
|
|
Object ret;
|
|
|
|
f = PORT(port)->file;
|
|
str = PORT(port)->flags & P_STRING;
|
|
while (1) {
|
|
Reader_Getc;
|
|
if (c == EOF)
|
|
Reader_Sharp_Eof;
|
|
if (Whitespace (c) || Delimiter (c))
|
|
break;
|
|
if (p == buf+1024)
|
|
Reader_Error(port, "bitstring constant too long for reader");
|
|
if (c != '0' && c != '1')
|
|
Reader_Error(port, "bad digit in bitstring constant");
|
|
*p++ = c;
|
|
}
|
|
Reader_Ungetc;
|
|
ret = Make_Bitstring(p-buf);
|
|
for (i = 0; p > buf; i++)
|
|
if (*--p == '1')
|
|
BITSTRING(ret)->data[i/8] |= 1 << i%8;
|
|
return ret;
|
|
}
|
|
|
|
#define Def_Prim Define_Primitive
|
|
|
|
void elk_init_lib_bitstring() {
|
|
T_Bitstring = Define_Type(0, "bitstring", Bitstring_Size, 0,
|
|
Bitstring_Equal, Bitstring_Equal, Bitstring_Print, NOFUNC);
|
|
Define_Reader('*', Bitstring_Read);
|
|
Def_Prim(P_Bitstringp, "bitstring?", 1, 1, EVAL);
|
|
Def_Prim(P_Bitstring_Equalp, "bitstring=?", 2, 2, EVAL);
|
|
Def_Prim(P_Make_Bitstring, "make-bitstring", 2, 2, EVAL);
|
|
Def_Prim(P_Bitstring_Length, "bitstring-length", 1, 1, EVAL);
|
|
Def_Prim(P_Int_To_Bitstring, "unsigned-integer->bitstring", 2, 2, EVAL);
|
|
Def_Prim(P_Bitstring_To_Int, "bitstring->unsigned-integer", 1, 1, EVAL);
|
|
Def_Prim(P_Bitstring_Ref, "bitstring-ref", 2, 2, EVAL);
|
|
Def_Prim(P_Bitstring_Set, "bitstring-set!", 3, 3, EVAL);
|
|
Def_Prim(P_Bitstring_Zerop, "bitstring-zero?", 1, 1, EVAL);
|
|
Def_Prim(P_Bitstring_Fill, "bitstring-fill!", 2, 2, EVAL);
|
|
Def_Prim(P_Bitstring_Move, "bitstring-move!", 2, 2, EVAL);
|
|
Def_Prim(P_Bitstring_Not, "bitstring-not!", 2, 2, EVAL);
|
|
Def_Prim(P_Bitstring_And, "bitstring-and!", 2, 2, EVAL);
|
|
Def_Prim(P_Bitstring_Or, "bitstring-or!", 2, 2, EVAL);
|
|
Def_Prim(P_Bitstring_Andnot, "bitstring-andnot!", 2, 2, EVAL);
|
|
Def_Prim(P_Bitstring_Xor, "bitstring-xor!", 2, 2, EVAL);
|
|
Def_Prim(P_Substring_Move, "bitstring-substring-move!", 5, 5, EVAL);
|
|
P_Provide (Intern ("bitstring.la"));
|
|
}
|