X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=chiark-tcl.git;a=blobdiff_plain;f=hbytes%2Fulongs.c;h=496273182d7c5df5981b6bede662901cd85aa60e;hp=8260a44bdd1abe69425b006635009c4745168c08;hb=79480f2c416419bcde9b9ac78f5f10bd4cc724e3;hpb=05bed2aad2154e0e8c084789387bf900c5ee513b

diff --git a/hbytes/ulongs.c b/hbytes/ulongs.c
index 8260a44..4962731 100644
--- a/hbytes/ulongs.c
+++ b/hbytes/ulongs.c
@@ -4,6 +4,202 @@
 #include "hbytes.h"
 #include "tables.h"
 
+/* nice simple functions */
+
+int do_ulong_int2ul(ClientData cd, Tcl_Interp *ip, int v,
+		    unsigned long *result) {
+  if (v<0) return staticerr(ip,"cannot convert -ve integer to ulong");
+  *result= v;
+  return TCL_OK;
+}
+  
+int do_ulong_ul2int(ClientData cd, Tcl_Interp *ip,
+		    unsigned long v, int *result) {
+  if (v>INT_MAX) return staticerr(ip,"ulong too large to fit in an int");
+  *result= v;
+  return TCL_OK;
+}
+
+int do_ulong_mask(ClientData cd, Tcl_Interp *ip,
+		  unsigned long a, unsigned long b, unsigned long *result) {
+  *result= a & b;
+  return TCL_OK;
+}
+  
+int do_ulong_shift(ClientData cd, Tcl_Interp *ip, int right,
+		   unsigned long v, int bits, unsigned long *result) {
+  if (bits > 32) return staticerr(ip,"shift out of range (32) bits");
+  *result= (bits==32 ? 0 :
+	    right ? v >> bits : v << bits);
+  return TCL_OK;
+}
+
+int do_ulong_compare(ClientData cd, Tcl_Interp *ip,
+		     unsigned long a, unsigned long b,
+		     int *result) {
+  *result= (a==b) ? -1 : (a < b) ? -1 : 1;
+  return TCL_OK;
+}
+
+/* bitfields */
+
+typedef struct {
+  const char *name;
+  int want_arg;
+  int (*reader_writer[2])(Tcl_Interp *ip, unsigned long *value_io,
+			  int *ok_io, Tcl_Obj *arg);
+} BitFieldType;
+
+static int bf_zero_read(Tcl_Interp *ip, unsigned long *value_io,
+			int *ok_io, Tcl_Obj *arg) {
+  if (*value_io) *ok_io= 0;
+  return TCL_OK;
+}
+
+static int bf_zero_write(Tcl_Interp *ip, unsigned long *value_io,
+			 int *ok_io, Tcl_Obj *arg) {
+  *value_io= 0;
+  return TCL_OK;
+}
+
+static int bf_ignore(Tcl_Interp *ip, unsigned long *value_io,
+		     int *ok_io, Tcl_Obj *arg) {
+  return TCL_OK;
+}
+
+static int bf_fixed_read(Tcl_Interp *ip, unsigned long *value_io,
+			 int *ok_io, Tcl_Obj *arg) {
+  unsigned long ul;
+  int rc;
+  
+  rc= pat_ulong(ip, arg, &ul);  if (rc) return rc;
+  if (*value_io != ul) *ok_io= 0;
+  return TCL_OK;
+}
+
+static int bf_ulong_write(Tcl_Interp *ip, unsigned long *value_io,
+			  int *ok_io, Tcl_Obj *arg) {
+  unsigned long ul;
+  int rc;
+  
+  rc= pat_ulong(ip, arg, &ul);  if (rc) return rc;
+  *value_io= ul;
+  return TCL_OK;
+}
+
+static int bf_var_read(Tcl_Interp *ip, Tcl_Obj *varname, Tcl_Obj *val) {
+  Tcl_Obj *rp;
+  rp= Tcl_ObjSetVar2(ip,varname,0,val,TCL_LEAVE_ERR_MSG);
+  if (!rp) return TCL_ERROR;
+  return TCL_OK;
+}
+
+static int bf_ulong_read(Tcl_Interp *ip, unsigned long *value_io,
+			 int *ok_io, Tcl_Obj *arg) {
+  return bf_var_read(ip,arg, ret_ulong(ip,*value_io));
+}
+
+static int bf_uint_write(Tcl_Interp *ip, unsigned long *value_io,
+			 int *ok_io, Tcl_Obj *arg) {
+  int rc, v;
+  rc= pat_int(ip, arg, &v);  if (rc) return rc;
+  if (v<0) return staticerr(ip,"value for bitfield is -ve");
+  *value_io= v;
+  return TCL_OK;
+}
+
+static int bf_uint_read(Tcl_Interp *ip, unsigned long *value_io,
+			int *ok_io, Tcl_Obj *arg) {
+  if (*value_io > INT_MAX)
+    return staticerr(ip,"value from bitfield exceeds INT_MAX");
+  return bf_var_read(ip,arg, ret_int(ip,*value_io));
+}
+
+#define BFT(t,a) { #t, a, { bf_read_##t, bf_write_##t } }
+static const BitFieldType bitfieldtypes[]= {
+  { "zero",   0, { bf_zero_read,  bf_zero_write  } },
+  { "ignore", 0, { bf_ignore,     bf_ignore      } },
+  { "fixed",  1, { bf_fixed_read, bf_ulong_write } },
+  { "ulong",  1, { bf_ulong_read, bf_ulong_write } },
+  { "uint",   1, { bf_uint_read,  bf_uint_write  } },
+  { 0 }
+};
+
+static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
+			unsigned long *value_io,
+			int objc, Tcl_Obj *const *objv) {
+  const BitFieldType *ftype;
+  Tcl_Obj *arg;
+  int sz, pos, rc;
+  unsigned long value, sz_mask, this_mask, this_field;
+  
+  pos= 32;
+  value= *value_io;
+  *ok_r= 1;
+
+  while (--objc) {
+    rc= Tcl_GetIntFromObj(ip,*++objv,&sz);  if (rc) return rc;
+    if (!--objc) return staticerr(ip,"wrong # args: missing bitfield type");
+
+    if (sz<0) return staticerr(ip,"bitfield size is -ve");
+    if (sz>pos) return staticerr(ip,"total size of bitfields >32");
+
+    pos -= sz;
+
+    sz_mask= ~(~0UL << sz);
+    this_mask= (sz_mask << pos);
+    this_field= (value & this_mask) >> pos;
+    
+    ftype= enum_lookup_cached(ip,*++objv,bitfieldtypes,"bitfield type");
+    if (!ftype) return TCL_ERROR;
+
+    if (ftype->want_arg) {
+      if (!--objc)
+	return staticerr(ip,"wrong # args: missing arg for bitfield");
+      arg= *++objv;
+    } else {
+      arg= 0;
+    }
+    rc= ftype->reader_writer[writing](ip, &this_field, ok_r, arg);
+    if (rc) return rc;
+
+    if (!*ok_r) return TCL_OK;
+
+    if (this_field & ~sz_mask)
+      return staticerr(ip,"bitfield value has more bits than bitfield");
+    
+    value &= ~this_mask;
+    value |= (this_field << pos);
+  }
+
+  if (pos != 0)
+    return staticerr(ip,"bitfield sizes add up to <32");
+
+  *value_io= value;
+  return TCL_OK;
+}
+
+int do_ulong_bitfields2ul(ClientData cd, Tcl_Interp *ip,
+			  unsigned long base,
+			  int objc, Tcl_Obj *const *objv,
+			  unsigned long *result) {
+  int ok, rc;
+  
+  *result= base;
+  rc= do_bitfields(ip,1,&ok,result,objc,objv);
+  assert(ok);
+  return rc;
+}
+
+int do_ulong_ul2bitfields(ClientData cd, Tcl_Interp *ip,
+			  unsigned long value,
+			  int objc, Tcl_Obj *const *objv,
+			  int *result) {
+  return do_bitfields(ip,0,result,&value,objc,objv);
+}
+
+/* conversion to/from hbytes */
+
 #define SIZES					\
   DO_SIZE(ulong, 4, 0xffffffffUL,		\
 	  DO_BYTE(0,24)				\
@@ -43,19 +239,67 @@ SIZES
 #undef DO_BYTE
 #undef DO_SIZE
 
-int pat_ulong(Tcl_Interp *ip, Tcl_Obj *obj, unsigned long *val) {
-  char *str, *ep;
+/* Arg parsing */
 
-  str= Tcl_GetString(obj);
-  errno= 0;
-  *val= strtoul(str,&ep,0);
-  if (*ep || errno) return staticerr(ip, "bad unsigned value");
+int pat_ulong(Tcl_Interp *ip, Tcl_Obj *o, unsigned long *val) {
+  int rc;
+  
+  rc= Tcl_ConvertToType(ip,o,&ulong_type);
+  if (rc) return rc;
+  *val= *(const unsigned long*)&o->internalRep.longValue;
   return TCL_OK;
 }
 
 Tcl_Obj *ret_ulong(Tcl_Interp *ip, unsigned long val) {
+  Tcl_Obj *o;
+
+  o= Tcl_NewObj();
+  Tcl_InvalidateStringRep(o);
+  *(unsigned long*)&o->internalRep.longValue= val;
+  o->typePtr= &ulong_type;
+  return o;
+}
+
+/* Tcl ulong type */
+
+static void ulong_t_free(Tcl_Obj *o) { }
+
+static void ulong_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
+  dup->internalRep= src->internalRep;
+}
+
+static void ulong_t_ustr(Tcl_Obj *o) {
+  unsigned long val;
   char buf[11];
+
+  val= *(const unsigned long*)&o->internalRep.longValue;
+
   assert(val <= 0xffffffffUL);
   snprintf(buf,sizeof(buf), "0x%08lx", val);
-  return Tcl_NewStringObj(buf,sizeof(buf)-1);
+
+  obj_updatestr_vstringls(o, buf, sizeof(buf)-1, (char*)0);
+}
+
+static int ulong_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
+  char *str, *ep;
+  unsigned long ul;
+
+
+  str= Tcl_GetString(o);
+  errno=0;
+  if (str[0]=='0' && str[1]=='b' && str[2]) {
+    ul= strtoul(str+2,&ep,2);
+  } else {
+    ul= strtoul(str,&ep,0);
+  }
+  if (*ep || errno) return staticerr(ip, "bad unsigned long value");
+
+  objfreeir(o);
+  *(unsigned long*)&o->internalRep.longValue= ul;
+  return TCL_OK;
 }
+
+Tcl_ObjType ulong_type = {
+  "ulong-nearly",
+  ulong_t_free, ulong_t_dup, ulong_t_ustr, ulong_t_sfa
+};