summaryrefslogtreecommitdiffstats
path: root/bytenumb.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:37 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:37 -0800
commit710a97992705d67c3ded0d4b270c5978ce29b11f (patch)
treeddcb2f7a91cbb86ce582e74227768b7b898c29e1 /bytenumb.c
parent50eb784bfcf15ee3c6b0b53d747db92673395040 (diff)
downloadscm-710a97992705d67c3ded0d4b270c5978ce29b11f.tar.gz
scm-710a97992705d67c3ded0d4b270c5978ce29b11f.zip
Import Upstream version 5e4upstream/5e4
Diffstat (limited to 'bytenumb.c')
-rw-r--r--bytenumb.c469
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"); */
+}