hbytes/ulongs.c

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