hbytes/ulongs.c

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