2 * hbytes - hex-stringrep efficient byteblocks for Tcl
3 * Copyright 2006 Ian Jackson
5 * This program is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU General Public License as
7 * published by the Free Software Foundation; either version 2 of the
8 * License, or (at your option) any later version.
10 * This program is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
21 #include "chiark_tcl_hbytes.h"
23 /* nice simple functions */
25 int cht_do_ulong_int2ul(ClientData cd, Tcl_Interp *ip, int v,
27 if (v<0) return cht_staticerr(ip,"cannot convert"
28 " -ve integer to ulong","ULONG VALUE NEGATIVE");
33 int cht_do_ulong_add(ClientData cd, Tcl_Interp *ip,
34 uint32_t a, uint32_t b, uint32_t *result) {
39 int cht_do_ulong_multiply(ClientData cd, Tcl_Interp *ip,
40 uint32_t a, uint32_t b, uint32_t *result) {
45 int cht_do_ulong_subtract(ClientData cd, Tcl_Interp *ip,
46 uint32_t a, uint32_t b, uint32_t *result) {
51 int cht_do_ulong_compare(ClientData cd, Tcl_Interp *ip,
52 uint32_t a, uint32_t b, int *result) {
59 int cht_do_ulong_ul2int(ClientData cd, Tcl_Interp *ip,
60 uint32_t v, int *result) {
62 cht_staticerr(ip,"ulong too large"
63 " to fit in an int", "ULONG VALUE OVERFLOW");
68 int cht_do_ulong_mask(ClientData cd, Tcl_Interp *ip,
69 uint32_t a, uint32_t b, uint32_t *result) {
74 int cht_do_ulong_shift(ClientData cd, Tcl_Interp *ip, int right,
75 uint32_t v, int bits, uint32_t *result) {
76 if (bits < 0) { bits= -bits; right= !right; }
77 if (bits > 32) return cht_staticerr(ip,"shift out of range (32) bits",
78 "ULONG BITCOUNT OVERRUN");
79 *result= (bits==32 ? 0 :
80 right ? v >> bits : v << bits);
89 int (*reader_writer[2])(Tcl_Interp *ip, uint32_t *value_io,
90 int *ok_io, Tcl_Obj *arg);
93 static int bf_zero_read(Tcl_Interp *ip, uint32_t *value_io,
94 int *ok_io, Tcl_Obj *arg) {
95 if (*value_io) *ok_io= 0;
99 static int bf_zero_write(Tcl_Interp *ip, uint32_t *value_io,
100 int *ok_io, Tcl_Obj *arg) {
105 static int bf_ignore(Tcl_Interp *ip, uint32_t *value_io,
106 int *ok_io, Tcl_Obj *arg) {
110 static int bf_fixed_read(Tcl_Interp *ip, uint32_t *value_io,
111 int *ok_io, Tcl_Obj *arg) {
115 rc= cht_pat_ulong(ip, arg, &ul); if (rc) return rc;
116 if (*value_io != ul) *ok_io= 0;
120 static int bf_ulong_write(Tcl_Interp *ip, uint32_t *value_io,
121 int *ok_io, Tcl_Obj *arg) {
125 rc= cht_pat_ulong(ip, arg, &ul); if (rc) return rc;
130 static int bf_var_read(Tcl_Interp *ip, Tcl_Obj *varname, Tcl_Obj *val) {
132 rp= Tcl_ObjSetVar2(ip,varname,0,val,TCL_LEAVE_ERR_MSG);
133 if (!rp) return TCL_ERROR;
137 static int bf_ulong_read(Tcl_Interp *ip, uint32_t *value_io,
138 int *ok_io, Tcl_Obj *arg) {
139 return bf_var_read(ip,arg, cht_ret_ulong(ip,*value_io));
142 static int bf_uint_write(Tcl_Interp *ip, uint32_t *value_io,
143 int *ok_io, Tcl_Obj *arg) {
145 rc= cht_pat_int(ip, arg, &v); if (rc) return rc;
146 if (v<0) return cht_staticerr(ip,"value for bitfield is -ve",
147 "ULONG VALUE NEGATIVE");
152 static int bf_uint_read(Tcl_Interp *ip, uint32_t *value_io,
153 int *ok_io, Tcl_Obj *arg) {
154 if (*value_io > INT_MAX)
155 return cht_staticerr(ip,"value from bitfield"
156 " exceeds INT_MAX","ULONG VALUE OVERFLOW");
157 return bf_var_read(ip,arg, cht_ret_int(ip,*value_io));
160 #define BFT(t,a) { #t, a, { bf_read_##t, bf_write_##t } }
161 static const BitFieldType bitfieldtypes[]= {
162 { "zero", 0, { bf_zero_read, bf_zero_write } },
163 { "ignore", 0, { bf_ignore, bf_ignore } },
164 { "fixed", 1, { bf_fixed_read, bf_ulong_write } },
165 { "ulong", 1, { bf_ulong_read, bf_ulong_write } },
166 { "uint", 1, { bf_uint_read, bf_uint_write } },
170 static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
172 int objc, Tcl_Obj *const *objv) {
173 const BitFieldType *ftype;
176 uint32_t value, sz_mask, this_mask, this_field;
183 rc= Tcl_GetIntFromObj(ip,*++objv,&sz); if (rc) return rc;
185 return cht_staticerr(ip,"wrong # args: missing bitfield type",0);
188 return cht_staticerr(ip,"bitfield size is -ve",
189 "ULONG BITCOUNT NEGATIVE");
191 return cht_staticerr(ip,"total size of bitfields >32",
192 "ULONG BITCOUNT OVERRUN");
196 sz_mask= ~(~0UL << sz);
197 this_mask= (sz_mask << pos);
198 this_field= (value & this_mask) >> pos;
200 ftype= enum_lookup_cached(ip,*++objv,bitfieldtypes,"bitfield type");
201 if (!ftype) return TCL_ERROR;
203 if (ftype->want_arg) {
205 return cht_staticerr(ip,"wrong # args: missing arg for bitfield",0);
210 rc= ftype->reader_writer[writing](ip, &this_field, ok_r, arg);
213 if (!*ok_r) return TCL_OK;
215 if (this_field & ~sz_mask)
216 return cht_staticerr(ip,"bitfield value has more bits than bitfield",
217 "ULONG VALUE OVERFLOW");
220 value |= (this_field << pos);
224 cht_staticerr(ip,"bitfield sizes add up to <32","ULONG BITCOUNT UNDERRUN");
230 int cht_do_ulong_bitfields2ul(ClientData cd, Tcl_Interp *ip,
232 int objc, Tcl_Obj *const *objv,
237 rc= do_bitfields(ip,1,&ok,result,objc,objv);
242 int cht_do_ulong_ul2bitfields(ClientData cd, Tcl_Interp *ip,
244 int objc, Tcl_Obj *const *objv,
246 return do_bitfields(ip,0,result,&value,objc,objv);
251 int cht_pat_ulong(Tcl_Interp *ip, Tcl_Obj *o, uint32_t *val) {
254 rc= Tcl_ConvertToType(ip,o,&cht_ulong_type);
256 *val= *(const uint32_t*)&o->internalRep.longValue;
260 Tcl_Obj *cht_ret_ulong(Tcl_Interp *ip, uint32_t val) {
264 Tcl_InvalidateStringRep(o);
265 *(uint32_t*)&o->internalRep.longValue= val;
266 o->typePtr= &cht_ulong_type;
272 static void ulong_t_free(Tcl_Obj *o) { }
274 static void ulong_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
275 dup->internalRep= src->internalRep;
276 dup->typePtr= &cht_ulong_type;
279 static void ulong_t_ustr(Tcl_Obj *o) {
283 val= *(const uint32_t*)&o->internalRep.longValue;
284 snprintf(buf,sizeof(buf), "%08lx", (unsigned long)val);
285 cht_obj_updatestr_vstringls(o, buf, sizeof(buf)-1, (char*)0);
288 static int ulong_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
292 if (o->typePtr == &cht_hbytes_type) {
295 l= cht_hb_len(OBJ_HBYTES(o));
296 if (l > 4) return cht_staticerr(ip,"hbytes as ulong with length >4",
297 "HBYTES LENGTH OVERRUN");
299 memcpy((Byte*)&ul + 4 - l, cht_hb_data(OBJ_HBYTES(o)), l);
304 str= Tcl_GetString(o);
306 if (str[0]=='0' && str[1]=='b' && str[2]) {
307 ul= strtoul(str+2,&ep,2);
308 } else if (str[0]=='0' && str[1]=='d' && str[2]) {
309 ul= strtoul(str+2,&ep,10);
311 ul= strtoul(str,&ep,16);
313 if (*ep || errno) return cht_staticerr(ip, "bad unsigned long value", 0);
318 *(uint32_t*)&o->internalRep.longValue= ul;
319 o->typePtr= &cht_ulong_type;
323 Tcl_ObjType cht_ulong_type = {
325 ulong_t_free, ulong_t_dup, ulong_t_ustr, ulong_t_sfa