hbytes/ulongs.c

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