diff options
Diffstat (limited to 'bytenumb.c')
| -rw-r--r-- | bytenumb.c | 469 |
1 files changed, 469 insertions, 0 deletions
diff --git a/bytenumb.c b/bytenumb.c new file mode 100644 index 0000000..ba7e584 --- /dev/null +++ b/bytenumb.c @@ -0,0 +1,469 @@ +/* "bytenumb.scm" Byte integer and IEEE floating-point conversions. */ +/* Copyright (C) 2007 Aubrey Jaffer */ +/* */ +/* Permission to copy this software, to modify it, to redistribute it, */ +/* to distribute modified versions, and to use it for any purpose is */ +/* granted, subject to the following restrictions and understandings. */ +/* */ +/* 1. Any copy made of this software must include this copyright notice */ +/* in full. */ +/* */ +/* 2. I have made no warranty or representation that the operation of */ +/* this software will be error-free, and I am under no obligation to */ +/* provide any services, by way of maintenance, update, or otherwise. */ +/* */ +/* 3. In conjunction with products arising from the use of this */ +/* material, there shall be no use of my name in any advertising, */ +/* promotional, or sales literature without prior written consent in */ +/* each case. */ + +/* For documentation see: */ +/* http://cvs.savannah.gnu.org/viewcvs/slib/slib/bytenumb.scm?view=markup */ + +#include <stdlib.h> +#include <math.h> + +#include "scm.h" + +int get_bytes_length(obj) + SCM obj; +{ + array_dim *s; + if (IMP(obj)) return -1; + switch (TYP7(obj)) { + case tc7_string: + case tc7_VfixN8: + case tc7_VfixZ8: + return LENGTH(obj); + case tc7_smob: + if (!ARRAYP(obj)) return -1; + if (1 != ARRAY_NDIM(obj)) return -1; + s = ARRAY_DIMS(obj); + if (1 != s[0].inc) return -1; + return s[0].ubnd - s[0].lbnd; + default: return -1; + } +} + +static char s_wrong_length[] = "wrong length"; +static SCM list_of_0; + +char * get_bytes(obj, minlen, s_name) + SCM obj; + int minlen; + const char *s_name; +{ + ASRTER(NIMP(obj) && (TYP7(obj)==tc7_string || + TYP7(obj)==tc7_VfixN8 || + TYP7(obj)==tc7_VfixZ8), + obj, ARG1, s_name); + { + int byvlen = get_bytes_length(obj); + ASRTER(byvlen >= minlen, obj, s_wrong_length, s_name); + return (char*)scm_addr(cons(obj, list_of_0), s_name); + } +} + +static char s_bytes_to_integer[] = "bytes->integer"; +SCM scm_bytes_to_integer(sbyts, sn) + SCM sbyts; + SCM sn; +{ + long n = INUM(sn); + if (!(n)) return INUM0; + { + int cnt = abs(n); + char *byts = get_bytes(sbyts, cnt, s_bytes_to_integer); + int iu = 0, id = cnt - sizeof(BIGDIG); + sizet ndigs = (cnt + sizeof(BIGDIG) - 1) / sizeof(BIGDIG); + int negp = (0x80 & byts[0]) && (0 > n); + SCM retval = mkbig(ndigs, negp); + BIGDIG *digs = BDIGITS(retval), carry = 1; + if (negp) + for (; iu < ndigs; iu++) { + int j = 0; + unsigned long dig = 0; + for (; j < sizeof(BIGDIG); j++) { + dig = (dig<<8) + + (0xFF ^ ((id + j >= 0) ? (((unsigned char *)byts)[id + j]) : 255)); + /* printf("byts[%d + %d] = %lx\n", id, j, 0xFF & dig); */ + } + dig = dig + carry; + digs[iu] = dig; + carry = dig >> (8 * sizeof(BIGDIG)); + /* printf("id = %d; iu = %d; dig = %04lx\n", id, iu, dig); */ + id = id - sizeof(BIGDIG); + } else + for (; iu < ndigs; iu++) { + int j = 0; + BIGDIG dig = 0; + for (; j < sizeof(BIGDIG); j++) { + dig = (dig<<8) + + ((id + j >= 0) ? (((unsigned char *)byts)[id + j]) : 0); + } + digs[iu] = dig; + /* printf("id = %d; iu = %d; dig = %04x\n", id, iu, dig); */ + id = id - sizeof(BIGDIG); + } + return normbig(retval); + } +} + +static char s_integer_to_bytes[] = "integer->bytes"; +SCM scm_integer_to_bytes(sn, slen) + SCM sn; + SCM slen; +{ + ASRTER(INUMP(slen), slen, ARG2, s_integer_to_bytes); + { + int len = INUM(slen); + SCM sbyts = make_string(scm_iabs(slen), MAKICHR(0)); + char *byts = CHARS(sbyts); + if (INUMP(sn)) { + int idx = -1 + (abs(len)); + long n = num2long(sn, (char *)ARG1, s_integer_to_bytes); + if ((0 > n) && (0 > len)) { + long res = -1 - n; + while (!(0 > idx)) { + byts[idx--] = 0xFF ^ (res % 0x100); + res = res>>8; + } + } + else { + unsigned long res = n; + while (!(0 > idx)) { + byts[idx--] = res % 0x100; + res = res>>8; + } + } + } else { + ASRTER(NIMP(sn) && BIGP(sn), sn, ARG1, s_integer_to_bytes); + { + BIGDIG *digs = BDIGITS(sn), borrow = 1; + sizet ndigs = NUMDIGS(sn); + int iu = 0, id = abs(len) - 1; + unsigned long dig; + if ((0 > len) && (TYP16(sn)==tc16_bigneg)) + for (; 0 <= id ; iu++) { + sizet j = sizeof(BIGDIG); + dig = (iu < ndigs) ? digs[iu] : 0; + dig = dig ^ ((1 << (8 * sizeof(BIGDIG))) - 1); + /* printf("j = %d; id = %d; iu = %d; dig = %04x; borrow = %d\n", j, id, iu, dig, borrow); */ + for (; 0 < j-- && 0 <= id;) { + /* printf("byts[%d] = %02x\n", id, 0xFF & dig); */ + int dg = (0xFF & dig) + borrow; + borrow = dg >> 8; + ((unsigned char *)byts)[id--] = dg; + dig = (dig)>>8; + } + } + else + for (; 0 <= id ; iu++) { + BIGDIG dig = (iu < ndigs) ? digs[iu] : 0; + sizet j = sizeof(BIGDIG); + /* printf("j = %d; id = %d; iu = %d; dig = %04x\n", j, id, iu, dig); */ + for (; 0 < j-- && 0 <= id;) { + /* printf("byts[%d] = %02x\n", id, 0xFF & dig); */ + ((unsigned char *)byts)[id--] = 0xFF & dig; + dig = (dig>>8); + } + } + } + } + return sbyts; + } +} + +static char s_bytes_to_ieee_float[] = "bytes->ieee-float"; +SCM scm_bytes_to_ieee_float(sbyts) + SCM sbyts; +{ + char *byts = get_bytes(sbyts, 4, s_bytes_to_ieee_float); + int len = LENGTH(sbyts); + int s = (1<<(7)) & ((((unsigned char*)(byts))[0])); + int e = ((0x7f&((((unsigned char*)(byts))[0])))<<1) + + ((0x80&((((unsigned char*)(byts))[1])))>>7); + float f = (((unsigned char*)(byts))[ -1 + (len)]); + int idx = -2 + (len); + while (!((idx)<=1)) { + { + int T_idx = -1 + (idx); + f = ((((unsigned char*)(byts))[idx])) + ((f) / 0x100); + idx = T_idx; + } + } + f = ((0x7f&((((unsigned char*)(byts))[1]))) + ((f) / 0x100)) / 0x80; + if ((0<(e)) + && ((e)<0xff)) + return makdbl(ldexpf((s ? -1 : 1) * (1 + (f)), (e) - 0x7f), 0.0); + else if (!(e)) + if (!(f)) return flo0; + else return makdbl(ldexpf((s ? -1 : 1) * (f), -126), 0.0); + else if (f) + return scm_narn; + else return makdbl((s ? -(1.0) : 1.0) / 0.0, 0.0); +} + +static char s_bytes_to_ieee_double[] = "bytes->ieee-double"; +SCM scm_bytes_to_ieee_double(sbyts) + SCM sbyts; +{ + char *byts = get_bytes(sbyts, 8, s_bytes_to_ieee_double); + int len = LENGTH(sbyts); + int s = (1<<(7)) & ((((unsigned char*)(byts))[0])); + int e = ((0x7f&((((unsigned char*)(byts))[0])))<<4) + + ((0xf0&((((unsigned char*)(byts))[1])))>>4); + double f = (((unsigned char*)(byts))[ -1 + (len)]); + int idx = -2 + (len); + while (!((idx)<=1)) { + { + int T_idx = -1 + (idx); + f = ((((unsigned char*)(byts))[idx])) + ((f) / 0x100); + idx = T_idx; + } + } + f = ((0xf&((((unsigned char*)(byts))[1]))) + ((f) / 0x100)) / 0x10; + if ((0<(e)) + && ((e)<0x7ff)) + return makdbl(ldexp((s ? -1 : 1) * (1 + (f)), (e) - 0x3ff), 0.0); + else if (!(e)) + if (!(f)) return flo0; + else return makdbl(ldexp((s ? -1 : 1) * (f), -1022), 0.0); + else if (f) + return scm_narn; + else return makdbl((s ? -(1.0) : 1.0) / 0.0, 0.0); +} + +static char s_ieee_float_to_bytes[] = "ieee-float->bytes"; +SCM scm_ieee_float_to_bytes(in_flt) + SCM in_flt; +{ + double dbl = num2dbl(in_flt, (char *)ARG1, s_ieee_float_to_bytes); + float flt = (float) dbl; + SCM sbyts = make_string(MAKINUM(4), MAKICHR(0)); + char *byts = CHARS(sbyts); + int s = flt < 0.0; + int scl = 0x7f; + flt = fabs(flt); + if (0.0==flt) { + if (s) + byts[0] = 0x80; + return sbyts; + } + else if (flt != flt) { + byts[0] = 0x7f; + byts[1] = 0xc0; + return sbyts; + } + else goto L_scale; + L_out: + { + float T_flt = 0x80 * (flt); + int val = (int)(floor(0x80 * (flt))); + int idx = 1; + float flt = T_flt; + while (!((idx) > 3)) { + byts[idx] = val; + { + float T_flt = 0x100 * ((flt) - (val)); + int T_val = (int)(floor(0x100 * ((flt) - (val)))); + idx = 1 + (idx); + flt = T_flt; + val = T_val; + } + } + byts[1] = (0x80 & (scl<<7)) | (0x7f & (((unsigned char*)(byts))[1])); + byts[0] = (s ? 0x80 : 0) + ((scl)>>1); + return sbyts; + } + L_scale: + if (!(scl)) { + flt = (flt)/2; + goto L_out; + } + else if ((flt)>=0x10) { + float flt16 = (flt) / 0x10; + if ((flt16)==(flt)) { + byts[0] = s ? 0xff : 0x7f; + byts[1] = 0x80; + return sbyts; + } + else { + flt = flt16; + scl = (scl) + 4; + goto L_scale; + } + } + else if ((flt) >= 2) { + flt = (flt) / 2; + scl = (scl) + 1; + goto L_scale; + } + else if (((scl) >= 4) && ((0x10 * (flt))<1)) { + flt = (flt) * 0x10; + scl = (scl)+ -4; + goto L_scale; + } + else if ((flt)<1) { + flt = (flt) * 2; + scl = (scl) + -1; + goto L_scale; + } + else { + flt = -1+(flt); + goto L_out; + } +} + +static char s_ieee_double_to_bytes[] = "ieee-double->bytes"; +SCM scm_ieee_double_to_bytes(in_flt) + SCM in_flt; +{ + double flt = num2dbl(in_flt, (char *)ARG1, s_ieee_double_to_bytes); + SCM sbyts = make_string(MAKINUM(8), MAKICHR(0)); + char *byts = CHARS(sbyts); + int s = flt < 0.0; + int scl = 0x3ff; + flt = fabs(flt); + if (0.0==flt) { + if (s) + byts[0] = 0x80; + return sbyts; + } + else if (flt != flt) { + byts[0] = 0x7f; + byts[1] = 0xf8; + return sbyts; + } + else goto L_scale; + L_out: + { + double T_flt = 0x10 * (flt); + int val = (int)(floor(0x10 * (flt))); + int idx = 1; + double flt = T_flt; + while (!((idx) > 7)) { + byts[idx] = val; + { + double T_flt = 0x100 * (flt - val); + int T_val = (int)floor(0x100 * (flt - val)); + idx = 1 + (idx); + flt = T_flt; + val = T_val; + } + } + byts[1] = (0xf0 & (scl<<4)) | (0x0f & (((unsigned char*)(byts))[1])); + byts[0] = (s ? 0x80 : 0) + ((scl)>>4); + return sbyts; + } + L_scale: + if (!(scl)) { + flt = (flt) / 2; + goto L_out; + } + else if ((flt) >= 0x10) { + double flt16 = (flt) / 0x10; + if ((flt16)==(flt)) { + byts[0] = s ? 0xff : 0x7f; + byts[1] = 0xf0; + return sbyts; + } + else { + flt = flt16; + scl = (scl) + 4; + goto L_scale; + } + } + else if ((flt) >= 2) { + flt = (flt) / 2; + scl = (scl) + 1; + goto L_scale; + } + else if (((scl) >= 4) && ((0x10 * flt) < 1)) { + flt = (flt) * 0x10; + scl = (scl) + -4; + goto L_scale; + } + else if ((flt) < 1) { + flt = (flt) * 2; + scl = (scl) + -1; + goto L_scale; + } + else { + flt = -1 + (flt); + goto L_out; + } +} + +static char s_integer_byte_collate_M[] = "integer-byte-collate!"; +SCM scm_integer_byte_collate_M(byte_vector) + SCM byte_vector; +{ + char* bv = get_bytes(byte_vector, 1, s_integer_byte_collate_M); + bv[0] = 0x80^(bv[0]); + return byte_vector; +} + +static char s_ieee_byte_collate_M[] = "ieee-byte-collate!"; +SCM scm_ieee_byte_collate_M(byte_vector) + SCM byte_vector; +{ + char* byv = get_bytes(byte_vector, 4, s_ieee_byte_collate_M); + int byvlen = get_bytes_length(byte_vector); + if (0x80&(byv[0])) { + int idx = -1 + byvlen; + while (!(0 > (idx))) { + byv[idx] = 0xff^(byv[idx]); + idx = -1+(idx); + } + } + else + byv[0] = 0x80^(byv[0]); + return byte_vector; +} + +static char s_ieee_byte_decollate_M[] = "ieee-byte-decollate!"; +SCM scm_ieee_byte_decollate_M(byte_vector) + SCM byte_vector; +{ + char* byv = get_bytes(byte_vector, 4, s_ieee_byte_collate_M); + int byvlen = get_bytes_length(byte_vector); + if (!(0x80&(byv[0]))) { + int idx = -1 + byvlen; + while (!(0 > (idx))) { + byv[idx] = 0xff^(byv[idx]); + idx = -1+(idx); + } + } + else + byv[0] = 0x80^(byv[0]); + return byte_vector; +} + +static iproc subr1s[] = { + {s_bytes_to_ieee_float, scm_bytes_to_ieee_float}, + {s_bytes_to_ieee_double, scm_bytes_to_ieee_double}, + {s_ieee_float_to_bytes, scm_ieee_float_to_bytes}, + {s_ieee_double_to_bytes, scm_ieee_double_to_bytes}, + {s_integer_byte_collate_M, scm_integer_byte_collate_M}, + {s_ieee_byte_collate_M, scm_ieee_byte_collate_M}, + {s_ieee_byte_decollate_M, scm_ieee_byte_decollate_M}, + {0, 0}}; + +void init_bytenumb() +{ + list_of_0 = cons(INUM0, EOL); + scm_gc_protect(list_of_0); + make_subr(s_bytes_to_integer, tc7_subr_2, scm_bytes_to_integer); + make_subr(s_integer_to_bytes, tc7_subr_2, scm_integer_to_bytes); + init_iprocs(subr1s, tc7_subr_1); + scm_ldstr("\n\ +(define (integer-byte-collate byte-vector)\n\ + (integer-byte-collate! (bytes-copy byte-vector)))\n\ +(define (ieee-byte-collate byte-vector)\n\ + (ieee-byte-collate! (bytes-copy byte-vector)))\n\ +(define (ieee-byte-decollate byte-vector)\n\ + (ieee-byte-decollate! (bytes-copy byte-vector)))\n\ +"); + /* add_feature("byte-number"); */ +} |