better core algorithm selection and new core alg suites

[chiark-tcl.git] / hbytes / ulongs.c

diff --git a/hbytes/ulongs.c b/hbytes/ulongs.c
index e352ba1e9691dbb0dc1d32d252e5ba3a26796af5..4652fd695c2816029fe8cd3f391a89aca76d22dd 100644 (file)
--- a/hbytes/ulongs.c
+++ b/hbytes/ulongs.c
@@ -8,7 +8,8 @@
 
 int do_ulong_int2ul(ClientData cd, Tcl_Interp *ip, int v,
                    uint32_t *result) {
-  if (v<0) return staticerr(ip,"cannot convert -ve integer to ulong");
+  if (v<0) return
+    staticerr(ip,"cannot convert -ve integer to ulong","ULONG VALUE NEGATIVE");
   *result= v;
   return TCL_OK;
 }
@@ -19,6 +20,12 @@ int do_ulong_add(ClientData cd, Tcl_Interp *ip,
   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;
@@ -35,7 +42,8 @@ int do_ulong_compare(ClientData cd, Tcl_Interp *ip,
 
 int do_ulong_ul2int(ClientData cd, Tcl_Interp *ip,
                    uint32_t v, int *result) {
-  if (v>INT_MAX) return staticerr(ip,"ulong too large to fit in an int");
+  if (v>INT_MAX) return
+    staticerr(ip,"ulong too large to fit in an int", "ULONG VALUE OVERFLOW");
   *result= v;
   return TCL_OK;
 }
@@ -48,7 +56,9 @@ int do_ulong_mask(ClientData cd, Tcl_Interp *ip,
   
 int do_ulong_shift(ClientData cd, Tcl_Interp *ip, int right,
                   uint32_t v, int bits, uint32_t *result) {
-  if (bits > 32) return staticerr(ip,"shift out of range (32) bits");
+  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;
@@ -116,15 +126,16 @@ 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, 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));
 }
 
@@ -152,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;
 
@@ -168,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;
@@ -179,14 +192,15 @@ 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;
@@ -243,7 +257,7 @@ static void ulong_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
 
 static void ulong_t_ustr(Tcl_Obj *o) {
   uint32_t val;
-  char buf[11];
+  char buf[9];
 
   val= *(const uint32_t*)&o->internalRep.longValue;
 
@@ -261,7 +275,8 @@ static int ulong_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
     int l;
 
     l= hbytes_len(OBJ_HBYTES(o));
-    if (l > 4) return staticerr(ip, "hbytes as ulong must be of length < 4");
+    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);
@@ -277,7 +292,7 @@ static int ulong_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
     } else {
       ul= strtoul(str,&ep,16);
     }
-    if (*ep || errno) return staticerr(ip, "bad unsigned long value");
+    if (*ep || errno) return staticerr(ip, "bad unsigned long value", 0);
 
   }