+/* nice simple functions */
+
+int do_ulong_int2ul(ClientData cd, Tcl_Interp *ip, int v,
+ uint32_t *result) {
+ if (v<0) return
+ staticerr(ip,"cannot convert -ve integer to ulong","ULONG VALUE NEGATIVE");
+ *result= v;
+ return TCL_OK;
+}
+
+int 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_multiply(ClientData cd, Tcl_Interp *ip,
+ uint32_t a, uint32_t b, uint32_t *result) {
+ *result= a * b;
+ return TCL_OK;
+}
+
+int 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_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 do_ulong_ul2int(ClientData cd, Tcl_Interp *ip,
+ uint32_t v, int *result) {
+ if (v>INT_MAX) return
+ 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,
+ 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,
+ uint32_t v, int bits, uint32_t *result) {
+ if (bits < 0) { bits= -bits; right= !right; }
+ if (bits > 32) return
+ staticerr(ip,"shift out of range (32) bits", "ULONG BITCOUNT OVERRUN");
+ *result= (bits==32 ? 0 :
+ right ? v >> bits : v << bits);
+ return TCL_OK;
+}
+
+/* bitfields */
+
+typedef struct {
+ const char *name;
+ int want_arg;
+ 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, 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, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg) {
+ *value_io= 0;
+ return TCL_OK;
+}
+
+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, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg) {
+ uint32_t ul;
+ int rc;
+
+ rc= 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, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg) {
+ uint32_t ul;
+ int rc;
+
+ rc= pat_ulong(ip, arg, &ul); if (rc) return rc;
+ *value_io= ul;
+ return TCL_OK;
+}
+
+static int bf_var_read(Tcl_Interp *ip, Tcl_Obj *varname, Tcl_Obj *val) {
+ Tcl_Obj *rp;
+ rp= Tcl_ObjSetVar2(ip,varname,0,val,TCL_LEAVE_ERR_MSG);
+ if (!rp) return TCL_ERROR;
+ return TCL_OK;
+}
+
+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));
+}
+
+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", "ULONG VALUE NEGATIVE");
+ *value_io= v;
+ return TCL_OK;
+}
+
+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","ULONG VALUE OVERFLOW");
+ return bf_var_read(ip,arg, ret_int(ip,*value_io));
+}
+
+#define BFT(t,a) { #t, a, { bf_read_##t, bf_write_##t } }
+static const BitFieldType bitfieldtypes[]= {
+ { "zero", 0, { bf_zero_read, bf_zero_write } },
+ { "ignore", 0, { bf_ignore, bf_ignore } },
+ { "fixed", 1, { bf_fixed_read, bf_ulong_write } },
+ { "ulong", 1, { bf_ulong_read, bf_ulong_write } },
+ { "uint", 1, { bf_uint_read, bf_uint_write } },
+ { 0 }
+};
+
+static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
+ uint32_t *value_io,
+ int objc, Tcl_Obj *const *objv) {
+ const BitFieldType *ftype;
+ Tcl_Obj *arg;
+ int sz, pos, rc;
+ uint32_t value, sz_mask, this_mask, this_field;
+
+ pos= 32;
+ value= *value_io;
+ *ok_r= 1;
+
+ while (--objc) {
+ rc= Tcl_GetIntFromObj(ip,*++objv,&sz); if (rc) return rc;
+ if (!--objc) return staticerr(ip,"wrong # args: missing bitfield type",0);
+
+ if (sz<0)
+ return staticerr(ip,"bitfield size is -ve", "ULONG BITCOUNT NEGATIVE");
+ if (sz>pos) return
+ staticerr(ip,"total size of bitfields >32", "ULONG BITCOUNT OVERRUN");
+
+ pos -= sz;
+
+ sz_mask= ~(~0UL << sz);
+ this_mask= (sz_mask << pos);
+ this_field= (value & this_mask) >> pos;
+
+ ftype= enum_lookup_cached(ip,*++objv,bitfieldtypes,"bitfield type");
+ if (!ftype) return TCL_ERROR;
+
+ if (ftype->want_arg) {
+ if (!--objc)
+ return staticerr(ip,"wrong # args: missing arg for bitfield",0);
+ arg= *++objv;
+ } else {
+ arg= 0;
+ }
+ rc= ftype->reader_writer[writing](ip, &this_field, ok_r, arg);
+ if (rc) return rc;
+
+ if (!*ok_r) return TCL_OK;
+
+ if (this_field & ~sz_mask)
+ return staticerr(ip,"bitfield value has more bits than bitfield",
+ "ULONG VALUE OVERFLOW");
+
+ value &= ~this_mask;
+ value |= (this_field << pos);