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