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

diff --git a/hbytes/ulongs.c b/hbytes/ulongs.c
index 4962731..4652fd6 100644
--- a/hbytes/ulongs.c
+++ b/hbytes/ulongs.c
@@ -7,69 +7,92 @@
 /* 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");
+		    uint32_t *result) {
+  if (v<0) return
+    staticerr(ip,"cannot convert -ve integer to ulong","ULONG VALUE NEGATIVE");
   *result= v;
   return TCL_OK;
 }
   
+int do_ulong_add(ClientData cd, Tcl_Interp *ip,
+		 uint32_t a, uint32_t b, uint32_t *result) {
+  *result= a + b;
+  return TCL_OK;
+}
+  
+int do_ulong_multiply(ClientData cd, Tcl_Interp *ip,
+		      uint32_t a, uint32_t b, uint32_t *result) {
+  *result= a * b;
+  return TCL_OK;
+}
+  
+int do_ulong_subtract(ClientData cd, Tcl_Interp *ip,
+		      uint32_t a, uint32_t b, uint32_t *result) {
+  *result= a - b;
+  return TCL_OK;
+}
+  
+int do_ulong_compare(ClientData cd, Tcl_Interp *ip,
+		     uint32_t a, uint32_t b, int *result) {
+  *result=
+    a == b ? 0 :
+    a < b ? -1 : 1;
+  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");
+		    uint32_t v, int *result) {
+  if (v>INT_MAX) return
+    staticerr(ip,"ulong too large to fit in an int", "ULONG VALUE OVERFLOW");
   *result= v;
   return TCL_OK;
 }
 
 int do_ulong_mask(ClientData cd, Tcl_Interp *ip,
-		  unsigned long a, unsigned long b, unsigned long *result) {
+		  uint32_t a, uint32_t b, uint32_t *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");
+		   uint32_t v, int bits, uint32_t *result) {
+  if (bits < 0) { bits= -bits; right= !right; }
+  if (bits > 32) return
+    staticerr(ip,"shift out of range (32) bits", "ULONG BITCOUNT OVERRUN");
   *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 (*reader_writer[2])(Tcl_Interp *ip, uint32_t *value_io,
 			  int *ok_io, Tcl_Obj *arg);
 } BitFieldType;
 
-static int bf_zero_read(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_zero_read(Tcl_Interp *ip, uint32_t *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,
+static int bf_zero_write(Tcl_Interp *ip, uint32_t *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,
+static int bf_ignore(Tcl_Interp *ip, uint32_t *value_io,
 		     int *ok_io, Tcl_Obj *arg) {
   return TCL_OK;
 }
 
-static int bf_fixed_read(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_fixed_read(Tcl_Interp *ip, uint32_t *value_io,
 			 int *ok_io, Tcl_Obj *arg) {
-  unsigned long ul;
+  uint32_t ul;
   int rc;
   
   rc= pat_ulong(ip, arg, &ul);  if (rc) return rc;
@@ -77,9 +100,9 @@ static int bf_fixed_read(Tcl_Interp *ip, unsigned long *value_io,
   return TCL_OK;
 }
 
-static int bf_ulong_write(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_ulong_write(Tcl_Interp *ip, uint32_t *value_io,
 			  int *ok_io, Tcl_Obj *arg) {
-  unsigned long ul;
+  uint32_t ul;
   int rc;
   
   rc= pat_ulong(ip, arg, &ul);  if (rc) return rc;
@@ -94,24 +117,25 @@ static int bf_var_read(Tcl_Interp *ip, Tcl_Obj *varname, Tcl_Obj *val) {
   return TCL_OK;
 }
 
-static int bf_ulong_read(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_ulong_read(Tcl_Interp *ip, uint32_t *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,
+static int bf_uint_write(Tcl_Interp *ip, uint32_t *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");
+  if (v<0) return
+    staticerr(ip,"value for bitfield is -ve", "ULONG VALUE NEGATIVE");
   *value_io= v;
   return TCL_OK;
 }
 
-static int bf_uint_read(Tcl_Interp *ip, unsigned long *value_io,
+static int bf_uint_read(Tcl_Interp *ip, uint32_t *value_io,
 			int *ok_io, Tcl_Obj *arg) {
-  if (*value_io > INT_MAX)
-    return staticerr(ip,"value from bitfield exceeds INT_MAX");
+  if (*value_io > INT_MAX) return
+    staticerr(ip,"value from bitfield exceeds INT_MAX","ULONG VALUE OVERFLOW");
   return bf_var_read(ip,arg, ret_int(ip,*value_io));
 }
 
@@ -126,12 +150,12 @@ static const BitFieldType bitfieldtypes[]= {
 };
 
 static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
-			unsigned long *value_io,
+			uint32_t *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;
+  uint32_t value, sz_mask, this_mask, this_field;
   
   pos= 32;
   value= *value_io;
@@ -139,10 +163,12 @@ static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
 
   while (--objc) {
     rc= Tcl_GetIntFromObj(ip,*++objv,&sz);  if (rc) return rc;
-    if (!--objc) return staticerr(ip,"wrong # args: missing bitfield type");
+    if (!--objc) return staticerr(ip,"wrong # args: missing bitfield type",0);
 
-    if (sz<0) return staticerr(ip,"bitfield size is -ve");
-    if (sz>pos) return staticerr(ip,"total size of bitfields >32");
+    if (sz<0)
+      return staticerr(ip,"bitfield size is -ve", "ULONG BITCOUNT NEGATIVE");
+    if (sz>pos) return
+      staticerr(ip,"total size of bitfields >32", "ULONG BITCOUNT OVERRUN");
 
     pos -= sz;
 
@@ -155,7 +181,7 @@ static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
 
     if (ftype->want_arg) {
       if (!--objc)
-	return staticerr(ip,"wrong # args: missing arg for bitfield");
+	return staticerr(ip,"wrong # args: missing arg for bitfield",0);
       arg= *++objv;
     } else {
       arg= 0;
@@ -166,23 +192,24 @@ static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
     if (!*ok_r) return TCL_OK;
 
     if (this_field & ~sz_mask)
-      return staticerr(ip,"bitfield value has more bits than bitfield");
+      return staticerr(ip,"bitfield value has more bits than bitfield",
+		       "ULONG VALUE OVERFLOW");
     
     value &= ~this_mask;
     value |= (this_field << pos);
   }
 
-  if (pos != 0)
-    return staticerr(ip,"bitfield sizes add up to <32");
+  if (pos != 0) return
+    staticerr(ip,"bitfield sizes add up to <32","ULONG BITCOUNT UNDERRUN");
 
   *value_io= value;
   return TCL_OK;
 }
 
 int do_ulong_bitfields2ul(ClientData cd, Tcl_Interp *ip,
-			  unsigned long base,
+			  uint32_t base,
 			  int objc, Tcl_Obj *const *objv,
-			  unsigned long *result) {
+			  uint32_t *result) {
   int ok, rc;
   
   *result= base;
@@ -192,70 +219,29 @@ int do_ulong_bitfields2ul(ClientData cd, Tcl_Interp *ip,
 }
 
 int do_ulong_ul2bitfields(ClientData cd, Tcl_Interp *ip,
-			  unsigned long value,
+			  uint32_t 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)				\
-	  DO_BYTE(1,16)				\
-	  DO_BYTE(2,8)				\
-	  DO_BYTE(3,0))				\
-  DO_SIZE(ushort, 2, 0x0000ffffUL,		\
-	  DO_BYTE(0,8)				\
-	  DO_BYTE(1,0))
-
-#define DO_BYTE(index,shift) (data[index] << shift) |
-#define DO_SIZE(ulongint, len, max, bytes)				\
-  int do_hbytes_h2##ulongint(ClientData cd, Tcl_Interp *ip,		\
-			     HBytes_Value hex, unsigned long *result) {	\
-    const Byte *data;							\
-    if (hbytes_len(&hex) != len)					\
-      return staticerr(ip, #ulongint " must be " #len " bytes");	\
-    data= hbytes_data(&hex);						\
-    *result= (bytes  0);						\
-    return TCL_OK;							\
-  }
-SIZES
-#undef DO_BYTE
-#undef DO_SIZE
-
-#define DO_BYTE(index,shift) data[index]= (value >> shift);
-#define DO_SIZE(ulongint, len, max, bytes)				    \
-  int do_hbytes_##ulongint##2h(ClientData cd, Tcl_Interp *ip,		    \
-			       unsigned long value, HBytes_Value *result) { \
-    Byte *data;								    \
-    if (value > max) return staticerr(ip, #ulongint " too big");	    \
-    data= hbytes_arrayspace(result,len);				    \
-    bytes								    \
-    return TCL_OK;							    \
-  }
-SIZES
-#undef DO_BYTE
-#undef DO_SIZE
-
 /* Arg parsing */
 
-int pat_ulong(Tcl_Interp *ip, Tcl_Obj *o, unsigned long *val) {
+int pat_ulong(Tcl_Interp *ip, Tcl_Obj *o, uint32_t *val) {
   int rc;
   
   rc= Tcl_ConvertToType(ip,o,&ulong_type);
   if (rc) return rc;
-  *val= *(const unsigned long*)&o->internalRep.longValue;
+  *val= *(const uint32_t*)&o->internalRep.longValue;
   return TCL_OK;
 }
 
-Tcl_Obj *ret_ulong(Tcl_Interp *ip, unsigned long val) {
+Tcl_Obj *ret_ulong(Tcl_Interp *ip, uint32_t val) {
   Tcl_Obj *o;
 
   o= Tcl_NewObj();
   Tcl_InvalidateStringRep(o);
-  *(unsigned long*)&o->internalRep.longValue= val;
+  *(uint32_t*)&o->internalRep.longValue= val;
   o->typePtr= &ulong_type;
   return o;
 }
@@ -266,36 +252,53 @@ static void ulong_t_free(Tcl_Obj *o) { }
 
 static void ulong_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
   dup->internalRep= src->internalRep;
+  dup->typePtr= &ulong_type;
 }
 
 static void ulong_t_ustr(Tcl_Obj *o) {
-  unsigned long val;
-  char buf[11];
+  uint32_t val;
+  char buf[9];
 
-  val= *(const unsigned long*)&o->internalRep.longValue;
+  val= *(const uint32_t*)&o->internalRep.longValue;
 
   assert(val <= 0xffffffffUL);
-  snprintf(buf,sizeof(buf), "0x%08lx", val);
+  snprintf(buf,sizeof(buf), "%08lx", (unsigned long)val);
 
   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;
+  uint32_t ul;
 
+  if (o->typePtr == &hbytes_type) {
+    int l;
+
+    l= hbytes_len(OBJ_HBYTES(o));
+    if (l > 4) return
+      staticerr(ip,"hbytes as ulong with length >4","HBYTES LENGTH OVERRUN");
+    ul= 0;
+    memcpy((Byte*)&ul + 4 - l, hbytes_data(OBJ_HBYTES(o)), l);
+    ul= htonl(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);
+
+    str= Tcl_GetString(o);
+    errno=0;
+    if (str[0]=='0' && str[1]=='b' && str[2]) {
+      ul= strtoul(str+2,&ep,2);
+    } else if (str[0]=='0' && str[1]=='d' && str[2]) {
+      ul= strtoul(str+2,&ep,10);
+    } else {
+      ul= strtoul(str,&ep,16);
+    }
+    if (*ep || errno) return staticerr(ip, "bad unsigned long value", 0);
+
   }
-  if (*ep || errno) return staticerr(ip, "bad unsigned long value");
 
   objfreeir(o);
-  *(unsigned long*)&o->internalRep.longValue= ul;
+  *(uint32_t*)&o->internalRep.longValue= ul;
+  o->typePtr= &ulong_type;
   return TCL_OK;
 }