hbytes/ulongs.c

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