hbytes/ulongs.c

   1 /*
   2  */
   3
   4 #include "hbytes.h"
   5 #include "tables.h"
   6
   7 /* nice simple functions */
   8
   9 int do_ulong_int2ul(ClientData cd, Tcl_Interp *ip, int v,
  10                     uint32_t *result) {
  11   if (v<0) return
  12     staticerr(ip,"cannot convert -ve integer to ulong","ULONG VALUE NEGATIVE");
  13   *result= v;
  14   return TCL_OK;
  15 }
  16
  17 int do_ulong_add(ClientData cd, Tcl_Interp *ip,
  18                  uint32_t a, uint32_t b, uint32_t *result) {
  19   *result= a + b;
  20   return TCL_OK;
  21 }
  22
  23 int do_ulong_subtract(ClientData cd, Tcl_Interp *ip,
  24                       uint32_t a, uint32_t b, uint32_t *result) {
  25   *result= a - b;
  26   return TCL_OK;
  27 }
  28
  29 int do_ulong_compare(ClientData cd, Tcl_Interp *ip,
  30                      uint32_t a, uint32_t b, int *result) {
  31   *result=
  32     a == b ? 0 :
  33     a < b ? -1 : 1;
  34   return TCL_OK;
  35 }
  36
  37 int do_ulong_ul2int(ClientData cd, Tcl_Interp *ip,
  38                     uint32_t v, int *result) {
  39   if (v>INT_MAX) return
  40     staticerr(ip,"ulong too large to fit in an int", "ULONG VALUE OVERFLOW");
  41   *result= v;
  42   return TCL_OK;
  43 }
  44
  45 int do_ulong_mask(ClientData cd, Tcl_Interp *ip,
  46                   uint32_t a, uint32_t b, uint32_t *result) {
  47   *result= a & b;
  48   return TCL_OK;
  49 }
  50
  51 int do_ulong_shift(ClientData cd, Tcl_Interp *ip, int right,
  52                    uint32_t v, int bits, uint32_t *result) {
  53   if (bits < 0) { bits= -bits; right= !right; }
  54   if (bits > 32) return
  55     staticerr(ip,"shift out of range (32) bits", "ULONG BITCOUNT OVERRUN");
  56   *result= (bits==32 ? 0 :
  57             right ? v >> bits : v << bits);
  58   return TCL_OK;
  59 }
  60
  61 /* bitfields */
  62
  63 typedef struct {
  64   const char *name;
  65   int want_arg;
  66   int (*reader_writer[2])(Tcl_Interp *ip, uint32_t *value_io,
  67                           int *ok_io, Tcl_Obj *arg);
  68 } BitFieldType;
  69
  70 static int bf_zero_read(Tcl_Interp *ip, uint32_t *value_io,
  71                         int *ok_io, Tcl_Obj *arg) {
  72   if (*value_io) *ok_io= 0;
  73   return TCL_OK;
  74 }
  75
  76 static int bf_zero_write(Tcl_Interp *ip, uint32_t *value_io,
  77                          int *ok_io, Tcl_Obj *arg) {
  78   *value_io= 0;
  79   return TCL_OK;
  80 }
  81
  82 static int bf_ignore(Tcl_Interp *ip, uint32_t *value_io,
  83                      int *ok_io, Tcl_Obj *arg) {
  84   return TCL_OK;
  85 }
  86
  87 static int bf_fixed_read(Tcl_Interp *ip, uint32_t *value_io,
  88                          int *ok_io, Tcl_Obj *arg) {
  89   uint32_t ul;
  90   int rc;
  91
  92   rc= pat_ulong(ip, arg, &ul);  if (rc) return rc;
  93   if (*value_io != ul) *ok_io= 0;
  94   return TCL_OK;
  95 }
  96
  97 static int bf_ulong_write(Tcl_Interp *ip, uint32_t *value_io,
  98                           int *ok_io, Tcl_Obj *arg) {
  99   uint32_t ul;
 100   int rc;
 101
 102   rc= pat_ulong(ip, arg, &ul);  if (rc) return rc;
 103   *value_io= ul;
 104   return TCL_OK;
 105 }
 106
 107 static int bf_var_read(Tcl_Interp *ip, Tcl_Obj *varname, Tcl_Obj *val) {
 108   Tcl_Obj *rp;
 109   rp= Tcl_ObjSetVar2(ip,varname,0,val,TCL_LEAVE_ERR_MSG);
 110   if (!rp) return TCL_ERROR;
 111   return TCL_OK;
 112 }
 113
 114 static int bf_ulong_read(Tcl_Interp *ip, uint32_t *value_io,
 115                          int *ok_io, Tcl_Obj *arg) {
 116   return bf_var_read(ip,arg, ret_ulong(ip,*value_io));
 117 }
 118
 119 static int bf_uint_write(Tcl_Interp *ip, uint32_t *value_io,
 120                          int *ok_io, Tcl_Obj *arg) {
 121   int rc, v;
 122   rc= pat_int(ip, arg, &v);  if (rc) return rc;
 123   if (v<0) return
 124     staticerr(ip,"value for bitfield is -ve", "ULONG VALUE NEGATIVE");
 125   *value_io= v;
 126   return TCL_OK;
 127 }
 128
 129 static int bf_uint_read(Tcl_Interp *ip, uint32_t *value_io,
 130                         int *ok_io, Tcl_Obj *arg) {
 131   if (*value_io > INT_MAX) return
 132     staticerr(ip,"value from bitfield exceeds INT_MAX","ULONG VALUE OVERFLOW");
 133   return bf_var_read(ip,arg, ret_int(ip,*value_io));
 134 }
 135
 136 #define BFT(t,a) { #t, a, { bf_read_##t, bf_write_##t } }
 137 static const BitFieldType bitfieldtypes[]= {
 138   { "zero",   0, { bf_zero_read,  bf_zero_write  } },
 139   { "ignore", 0, { bf_ignore,     bf_ignore      } },
 140   { "fixed",  1, { bf_fixed_read, bf_ulong_write } },
 141   { "ulong",  1, { bf_ulong_read, bf_ulong_write } },
 142   { "uint",   1, { bf_uint_read,  bf_uint_write  } },
 143   { 0 }
 144 };
 145
 146 static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
 147                         uint32_t *value_io,
 148                         int objc, Tcl_Obj *const *objv) {
 149   const BitFieldType *ftype;
 150   Tcl_Obj *arg;
 151   int sz, pos, rc;
 152   uint32_t value, sz_mask, this_mask, this_field;
 153
 154   pos= 32;
 155   value= *value_io;
 156   *ok_r= 1;
 157
 158   while (--objc) {
 159     rc= Tcl_GetIntFromObj(ip,*++objv,&sz);  if (rc) return rc;
 160     if (!--objc) return staticerr(ip,"wrong # args: missing bitfield type",0);
 161
 162     if (sz<0)
 163       return staticerr(ip,"bitfield size is -ve", "ULONG BITCOUNT NEGATIVE");
 164     if (sz>pos) return
 165       staticerr(ip,"total size of bitfields >32", "ULONG BITCOUNT OVERRUN");
 166
 167     pos -= sz;
 168
 169     sz_mask= ~(~0UL << sz);
 170     this_mask= (sz_mask << pos);
 171     this_field= (value & this_mask) >> pos;
 172
 173     ftype= enum_lookup_cached(ip,*++objv,bitfieldtypes,"bitfield type");
 174     if (!ftype) return TCL_ERROR;
 175
 176     if (ftype->want_arg) {
 177       if (!--objc)
 178         return staticerr(ip,"wrong # args: missing arg for bitfield",0);
 179       arg= *++objv;
 180     } else {
 181       arg= 0;
 182     }
 183     rc= ftype->reader_writer[writing](ip, &this_field, ok_r, arg);
 184     if (rc) return rc;
 185
 186     if (!*ok_r) return TCL_OK;
 187
 188     if (this_field & ~sz_mask)
 189       return staticerr(ip,"bitfield value has more bits than bitfield",
 190                        "ULONG VALUE OVERFLOW");
 191
 192     value &= ~this_mask;
 193     value |= (this_field << pos);
 194   }
 195
 196   if (pos != 0) return
 197     staticerr(ip,"bitfield sizes add up to <32","ULONG BITCOUNT UNDERRUN");
 198
 199   *value_io= value;
 200   return TCL_OK;
 201 }
 202
 203 int do_ulong_bitfields2ul(ClientData cd, Tcl_Interp *ip,
 204                           uint32_t base,
 205                           int objc, Tcl_Obj *const *objv,
 206                           uint32_t *result) {
 207   int ok, rc;
 208
 209   *result= base;
 210   rc= do_bitfields(ip,1,&ok,result,objc,objv);
 211   assert(ok);
 212   return rc;
 213 }
 214
 215 int do_ulong_ul2bitfields(ClientData cd, Tcl_Interp *ip,
 216                           uint32_t value,
 217                           int objc, Tcl_Obj *const *objv,
 218                           int *result) {
 219   return do_bitfields(ip,0,result,&value,objc,objv);
 220 }
 221
 222 /* Arg parsing */
 223
 224 int pat_ulong(Tcl_Interp *ip, Tcl_Obj *o, uint32_t *val) {
 225   int rc;
 226
 227   rc= Tcl_ConvertToType(ip,o,&ulong_type);
 228   if (rc) return rc;
 229   *val= *(const uint32_t*)&o->internalRep.longValue;
 230   return TCL_OK;
 231 }
 232
 233 Tcl_Obj *ret_ulong(Tcl_Interp *ip, uint32_t val) {
 234   Tcl_Obj *o;
 235
 236   o= Tcl_NewObj();
 237   Tcl_InvalidateStringRep(o);
 238   *(uint32_t*)&o->internalRep.longValue= val;
 239   o->typePtr= &ulong_type;
 240   return o;
 241 }
 242
 243 /* Tcl ulong type */
 244
 245 static void ulong_t_free(Tcl_Obj *o) { }
 246
 247 static void ulong_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
 248   dup->internalRep= src->internalRep;
 249   dup->typePtr= &ulong_type;
 250 }
 251
 252 static void ulong_t_ustr(Tcl_Obj *o) {
 253   uint32_t val;
 254   char buf[11];
 255
 256   val= *(const uint32_t*)&o->internalRep.longValue;
 257
 258   assert(val <= 0xffffffffUL);
 259   snprintf(buf,sizeof(buf), "%08lx", (unsigned long)val);
 260
 261   obj_updatestr_vstringls(o, buf, sizeof(buf)-1, (char*)0);
 262 }
 263
 264 static int ulong_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
 265   char *str, *ep;
 266   uint32_t ul;
 267
 268   if (o->typePtr == &hbytes_type) {
 269     int l;
 270
 271     l= hbytes_len(OBJ_HBYTES(o));
 272     if (l > 4) return
 273       staticerr(ip,"hbytes as ulong with length >4","HBYTES LENGTH OVERRUN");
 274     ul= 0;
 275     memcpy((Byte*)&ul + 4 - l, hbytes_data(OBJ_HBYTES(o)), l);
 276     ul= htonl(ul);
 277
 278   } else {
 279
 280     str= Tcl_GetString(o);
 281     errno=0;
 282     if (str[0]=='0' && str[1]=='b' && str[2]) {
 283       ul= strtoul(str+2,&ep,2);
 284     } else if (str[0]=='0' && str[1]=='d' && str[2]) {
 285       ul= strtoul(str+2,&ep,10);
 286     } else {
 287       ul= strtoul(str,&ep,16);
 288     }
 289     if (*ep || errno) return staticerr(ip, "bad unsigned long value", 0);
 290
 291   }
 292
 293   objfreeir(o);
 294   *(uint32_t*)&o->internalRep.longValue= ul;
 295   o->typePtr= &ulong_type;
 296   return TCL_OK;
 297 }
 298
 299 Tcl_ObjType ulong_type = {
 300   "ulong-nearly",
 301   ulong_t_free, ulong_t_dup, ulong_t_ustr, ulong_t_sfa
 302 };