/*
+ * hbytes - hex-stringrep efficient byteblocks for Tcl
+ * Copyright 2006 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+ * 02110-1301, USA.
*/
-#include "hbytes.h"
-#include "tables.h"
+#include "chiark_tcl_hbytes.h"
/* nice simple functions */
-int do_hbytes_clockincrement(ClientData cd, Tcl_Interp *ip,
- HBytes_Var value, int change, int *result) {
- Byte *data;
- int len, bv;
-
- if (change<-255 || change>255)
- return staticerr(ip,"clockincrement change must be in range -255..255");
-
- len= hbytes_len(value.hb);
- data= hbytes_data(value.hb) + len;
- while (len && change) {
- bv= *--data;
- bv += change;
- *data= bv;
- if (bv<0) change= -1;
- else if (bv>255) change= +1;
- else change= 0;
- len--;
- }
- *result= change;
+int cht_do_ulong_int2ul(ClientData cd, Tcl_Interp *ip, int v,
+ uint32_t *result) {
+ if (v<0) return cht_staticerr(ip,"cannot convert"
+ " -ve integer to ulong","ULONG VALUE NEGATIVE");
+ *result= v;
+ return TCL_OK;
+}
+int cht_do_ulong_add(ClientData cd, Tcl_Interp *ip,
+ uint32_t a, uint32_t b, uint32_t *result) {
+ *result= a + b;
return TCL_OK;
}
-
-int do_ulong_int2ul(ClientData cd, Tcl_Interp *ip, int v,
- unsigned long *result) {
- if (v<0) return staticerr(ip,"cannot convert -ve integer to ulong");
- *result= v;
+
+int cht_do_ulong_multiply(ClientData cd, Tcl_Interp *ip,
+ uint32_t a, uint32_t b, uint32_t *result) {
+ *result= a * b;
+ return TCL_OK;
+}
+
+int cht_do_ulong_subtract(ClientData cd, Tcl_Interp *ip,
+ uint32_t a, uint32_t b, uint32_t *result) {
+ *result= a - b;
return TCL_OK;
}
-int do_ulong_ul2int(ClientData cd, Tcl_Interp *ip,
- unsigned long v, int *result) {
- if (v>INT_MAX) return staticerr(ip,"ulong too large to fit in an int");
+int cht_do_ulong_compare(ClientData cd, Tcl_Interp *ip,
+ uint32_t a, uint32_t b, int *result) {
+ *result=
+ a == b ? 0 :
+ a < b ? -1 : 1;
+ return TCL_OK;
+}
+
+int cht_do_ulong_ul2int(ClientData cd, Tcl_Interp *ip,
+ uint32_t v, int *result) {
+ if (v>INT_MAX) return
+ cht_staticerr(ip,"ulong too large"
+ " to fit in an int", "ULONG VALUE OVERFLOW");
*result= v;
return TCL_OK;
}
-int do_ulong_mask(ClientData cd, Tcl_Interp *ip,
- unsigned long a, unsigned long b, unsigned long *result) {
+int cht_do_ulong_mask(ClientData cd, Tcl_Interp *ip,
+ uint32_t a, uint32_t b, uint32_t *result) {
*result= a & b;
return TCL_OK;
}
-int do_ulong_shift(ClientData cd, Tcl_Interp *ip, int right,
- unsigned long v, int bits, unsigned long *result) {
- if (bits > 32) return staticerr(ip,"shift out of range (32) bits");
+int cht_do_ulong_shift(ClientData cd, Tcl_Interp *ip, int right,
+ uint32_t v, int bits, uint32_t *result) {
+ if (bits < 0) { bits= -bits; right= !right; }
+ if (bits > 32) return cht_staticerr(ip,"shift out of range (32) bits",
+ "ULONG BITCOUNT OVERRUN");
*result= (bits==32 ? 0 :
right ? v >> bits : v << bits);
return TCL_OK;
}
-int do_ulong_compare(ClientData cd, Tcl_Interp *ip,
- unsigned long a, unsigned long b,
- int *result) {
- *result= (a==b) ? -1 : (a < b) ? -1 : 1;
- return TCL_OK;
-}
-
/* bitfields */
typedef struct {
const char *name;
int want_arg;
- int (*reader_writer[2])(Tcl_Interp *ip, unsigned long *value_io,
+ int (*reader_writer[2])(Tcl_Interp *ip, uint32_t *value_io,
int *ok_io, Tcl_Obj *arg);
} BitFieldType;
-static int bf_zero_read(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_zero_read(Tcl_Interp *ip, uint32_t *value_io,
int *ok_io, Tcl_Obj *arg) {
if (*value_io) *ok_io= 0;
return TCL_OK;
}
-static int bf_zero_write(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_zero_write(Tcl_Interp *ip, uint32_t *value_io,
int *ok_io, Tcl_Obj *arg) {
*value_io= 0;
return TCL_OK;
}
-static int bf_ignore(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_ignore(Tcl_Interp *ip, uint32_t *value_io,
int *ok_io, Tcl_Obj *arg) {
return TCL_OK;
}
-static int bf_fixed_read(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_fixed_read(Tcl_Interp *ip, uint32_t *value_io,
int *ok_io, Tcl_Obj *arg) {
- unsigned long ul;
+ uint32_t ul;
int rc;
- rc= pat_ulong(ip, arg, &ul); if (rc) return rc;
+ rc= cht_pat_ulong(ip, arg, &ul); if (rc) return rc;
if (*value_io != ul) *ok_io= 0;
return TCL_OK;
}
-static int bf_ulong_write(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_ulong_write(Tcl_Interp *ip, uint32_t *value_io,
int *ok_io, Tcl_Obj *arg) {
- unsigned long ul;
+ uint32_t ul;
int rc;
- rc= pat_ulong(ip, arg, &ul); if (rc) return rc;
+ rc= cht_pat_ulong(ip, arg, &ul); if (rc) return rc;
*value_io= ul;
return TCL_OK;
}
return TCL_OK;
}
-static int bf_ulong_read(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_ulong_read(Tcl_Interp *ip, uint32_t *value_io,
int *ok_io, Tcl_Obj *arg) {
- return bf_var_read(ip,arg, ret_ulong(ip,*value_io));
+ return bf_var_read(ip,arg, cht_ret_ulong(ip,*value_io));
}
-static int bf_uint_write(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_uint_write(Tcl_Interp *ip, uint32_t *value_io,
int *ok_io, Tcl_Obj *arg) {
int rc, v;
- rc= pat_int(ip, arg, &v); if (rc) return rc;
- if (v<0) return staticerr(ip,"value for bitfield is -ve");
+ rc= cht_pat_int(ip, arg, &v); if (rc) return rc;
+ if (v<0) return cht_staticerr(ip,"value for bitfield is -ve",
+ "ULONG VALUE NEGATIVE");
*value_io= v;
return TCL_OK;
}
-static int bf_uint_read(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_uint_read(Tcl_Interp *ip, uint32_t *value_io,
int *ok_io, Tcl_Obj *arg) {
if (*value_io > INT_MAX)
- return staticerr(ip,"value from bitfield exceeds INT_MAX");
- return bf_var_read(ip,arg, ret_int(ip,*value_io));
+ return cht_staticerr(ip,"value from bitfield"
+ " exceeds INT_MAX","ULONG VALUE OVERFLOW");
+ return bf_var_read(ip,arg, cht_ret_int(ip,*value_io));
}
#define BFT(t,a) { #t, a, { bf_read_##t, bf_write_##t } }
};
static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
- unsigned long *value_io,
+ uint32_t *value_io,
int objc, Tcl_Obj *const *objv) {
const BitFieldType *ftype;
Tcl_Obj *arg;
int sz, pos, rc;
- unsigned long value, sz_mask, this_mask, this_field;
+ uint32_t value, sz_mask, this_mask, this_field;
pos= 32;
value= *value_io;
while (--objc) {
rc= Tcl_GetIntFromObj(ip,*++objv,&sz); if (rc) return rc;
- if (!--objc) return staticerr(ip,"wrong # args: missing bitfield type");
+ if (!--objc)
+ return cht_staticerr(ip,"wrong # args: missing bitfield type",0);
- if (sz<0) return staticerr(ip,"bitfield size is -ve");
- if (sz>pos) return staticerr(ip,"total size of bitfields >32");
+ if (sz<0)
+ return cht_staticerr(ip,"bitfield size is -ve",
+ "ULONG BITCOUNT NEGATIVE");
+ if (sz>pos)
+ return cht_staticerr(ip,"total size of bitfields >32",
+ "ULONG BITCOUNT OVERRUN");
pos -= sz;
if (ftype->want_arg) {
if (!--objc)
- return staticerr(ip,"wrong # args: missing arg for bitfield");
+ return cht_staticerr(ip,"wrong # args: missing arg for bitfield",0);
arg= *++objv;
} else {
arg= 0;
if (!*ok_r) return TCL_OK;
if (this_field & ~sz_mask)
- return staticerr(ip,"bitfield value has more bits than bitfield");
+ return cht_staticerr(ip,"bitfield value has more bits than bitfield",
+ "ULONG VALUE OVERFLOW");
value &= ~this_mask;
value |= (this_field << pos);
}
- if (pos != 0)
- return staticerr(ip,"bitfield sizes add up to <32");
+ if (pos != 0) return
+ cht_staticerr(ip,"bitfield sizes add up to <32","ULONG BITCOUNT UNDERRUN");
*value_io= value;
return TCL_OK;
}
-int do_ulong_bitfields2ul(ClientData cd, Tcl_Interp *ip,
- unsigned long base,
+int cht_do_ulong_bitfields2ul(ClientData cd, Tcl_Interp *ip,
+ uint32_t base,
int objc, Tcl_Obj *const *objv,
- unsigned long *result) {
+ uint32_t *result) {
int ok, rc;
*result= base;
return rc;
}
-int do_ulong_ul2bitfields(ClientData cd, Tcl_Interp *ip,
- unsigned long value,
+int cht_do_ulong_ul2bitfields(ClientData cd, Tcl_Interp *ip,
+ uint32_t value,
int objc, Tcl_Obj *const *objv,
int *result) {
return do_bitfields(ip,0,result,&value,objc,objv);
}
-/* conversion to/from hbytes */
-
-#define SIZES \
- DO_SIZE(ulong, 4, 0xffffffffUL, \
- DO_BYTE(0,24) \
- DO_BYTE(1,16) \
- DO_BYTE(2,8) \
- DO_BYTE(3,0)) \
- DO_SIZE(ushort, 2, 0x0000ffffUL, \
- DO_BYTE(0,8) \
- DO_BYTE(1,0))
-
-#define DO_BYTE(index,shift) (data[index] << shift) |
-#define DO_SIZE(ulongint, len, max, bytes) \
- int do_hbytes_h2##ulongint(ClientData cd, Tcl_Interp *ip, \
- HBytes_Value hex, unsigned long *result) { \
- const Byte *data; \
- if (hbytes_len(&hex) != len) \
- return staticerr(ip, #ulongint " must be " #len " bytes"); \
- data= hbytes_data(&hex); \
- *result= (bytes 0); \
- return TCL_OK; \
- }
-SIZES
-#undef DO_BYTE
-#undef DO_SIZE
-
-#define DO_BYTE(index,shift) data[index]= (value >> shift);
-#define DO_SIZE(ulongint, len, max, bytes) \
- int do_hbytes_##ulongint##2h(ClientData cd, Tcl_Interp *ip, \
- unsigned long value, HBytes_Value *result) { \
- Byte *data; \
- if (value > max) return staticerr(ip, #ulongint " too big"); \
- data= hbytes_arrayspace(result,len); \
- bytes \
- return TCL_OK; \
- }
-SIZES
-#undef DO_BYTE
-#undef DO_SIZE
-
/* Arg parsing */
-int pat_ulong(Tcl_Interp *ip, Tcl_Obj *o, unsigned long *val) {
+int cht_pat_ulong(Tcl_Interp *ip, Tcl_Obj *o, uint32_t *val) {
int rc;
- rc= Tcl_ConvertToType(ip,o,&ulong_type);
+ rc= Tcl_ConvertToType(ip,o,&cht_ulong_type);
if (rc) return rc;
- *val= *(const unsigned long*)&o->internalRep.longValue;
+ *val= *(const uint32_t*)&o->internalRep.longValue;
return TCL_OK;
}
-Tcl_Obj *ret_ulong(Tcl_Interp *ip, unsigned long val) {
+Tcl_Obj *cht_ret_ulong(Tcl_Interp *ip, uint32_t val) {
Tcl_Obj *o;
o= Tcl_NewObj();
Tcl_InvalidateStringRep(o);
- *(unsigned long*)&o->internalRep.longValue= val;
- o->typePtr= &ulong_type;
+ *(uint32_t*)&o->internalRep.longValue= val;
+ o->typePtr= &cht_ulong_type;
return o;
}
static void ulong_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
dup->internalRep= src->internalRep;
- dup->typePtr= &ulong_type;
+ dup->typePtr= &cht_ulong_type;
}
static void ulong_t_ustr(Tcl_Obj *o) {
- unsigned long val;
- char buf[11];
+ uint32_t val;
+ char buf[9];
- val= *(const unsigned long*)&o->internalRep.longValue;
+ val= *(const uint32_t*)&o->internalRep.longValue;
assert(val <= 0xffffffffUL);
- snprintf(buf,sizeof(buf), "0x%08lx", val);
+ snprintf(buf,sizeof(buf), "%08lx", (unsigned long)val);
- obj_updatestr_vstringls(o, buf, sizeof(buf)-1, (char*)0);
+ cht_obj_updatestr_vstringls(o, buf, sizeof(buf)-1, (char*)0);
}
static int ulong_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
char *str, *ep;
- unsigned long ul;
+ uint32_t ul;
+
+ if (o->typePtr == &cht_hbytes_type) {
+ int l;
+ l= cht_hb_len(OBJ_HBYTES(o));
+ if (l > 4) return cht_staticerr(ip,"hbytes as ulong with length >4",
+ "HBYTES LENGTH OVERRUN");
+ ul= 0;
+ memcpy((Byte*)&ul + 4 - l, cht_hb_data(OBJ_HBYTES(o)), l);
+ ul= htonl(ul);
- str= Tcl_GetString(o);
- errno=0;
- if (str[0]=='0' && str[1]=='b' && str[2]) {
- ul= strtoul(str+2,&ep,2);
} else {
- ul= strtoul(str,&ep,0);
+
+ str= Tcl_GetString(o);
+ errno=0;
+ if (str[0]=='0' && str[1]=='b' && str[2]) {
+ ul= strtoul(str+2,&ep,2);
+ } else if (str[0]=='0' && str[1]=='d' && str[2]) {
+ ul= strtoul(str+2,&ep,10);
+ } else {
+ ul= strtoul(str,&ep,16);
+ }
+ if (*ep || errno) return cht_staticerr(ip, "bad unsigned long value", 0);
+
}
- if (*ep || errno) return staticerr(ip, "bad unsigned long value");
- objfreeir(o);
- *(unsigned long*)&o->internalRep.longValue= ul;
+ cht_objfreeir(o);
+ *(uint32_t*)&o->internalRep.longValue= ul;
+ o->typePtr= &cht_ulong_type;
return TCL_OK;
}
-Tcl_ObjType ulong_type = {
+Tcl_ObjType cht_ulong_type = {
"ulong-nearly",
ulong_t_free, ulong_t_dup, ulong_t_ustr, ulong_t_sfa
};
~ian / chiark-tcl.git / blobdiff