Stopped sign-bit propagation in [binary scan] of wide values. [Bug #690774]

3 files changed, 35 insertions, 21 deletions

diff --git a/ChangeLog b/ChangeLog
index 4d63e28..868aece 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2003-02-21  Donal K. Fellows  <fellowsd@cs.man.ac.uk>
+
+	* tests/binary.test (binary-44.[34]): 
+	* generic/tclBinary.c (ScanNumber): Fixed problem with unwanted
+	sign-bit propagation when scanning wide ints. [Bug #690774]
+
 2003-02-21  Daniel Steffen  <das@users.sourceforge.net>
 
 	* mac/tclMacChan.c (TclpCutFileChannel, TclpSpliceFileChannel):
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index c8ff568..4dfb505 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBinary.c,v 1.12 2002/02/15 14:28:48 dkf Exp $
+ * RCS: @(#) $Id: tclBinary.c,v 1.13 2003/02/21 21:54:11 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -1588,7 +1588,7 @@ ScanNumber(buffer, type, numberCachePtrPtr)
 				 * different numbers have been scanned. */
 {
     long value;
-    Tcl_WideInt wvalue;
+    Tcl_WideUInt uwvalue;
 
     /*
      * We cannot rely on the compiler to properly sign extend integer values
@@ -1678,25 +1678,25 @@ ScanNumber(buffer, type, numberCachePtrPtr)
 		}
 	    }
 	case 'w':
-	    value = (long) (buffer[4] 
-		    | (buffer[5] << 8)
-		    | (buffer[6] << 16)
-		    | (buffer[7] << 24));
-	    wvalue = ((Tcl_WideInt) value) << 32 | (buffer[0] 
-		    | (buffer[1] << 8)
-		    | (buffer[2] << 16)
-		    | (buffer[3] << 24));
-	    return Tcl_NewWideIntObj(wvalue);
+	    uwvalue =  ((Tcl_WideUInt) buffer[0])
+		    | (((Tcl_WideUInt) buffer[1]) << 8)
+		    | (((Tcl_WideUInt) buffer[2]) << 16)
+		    | (((Tcl_WideUInt) buffer[3]) << 24)
+		    | (((Tcl_WideUInt) buffer[4]) << 32)
+		    | (((Tcl_WideUInt) buffer[5]) << 40)
+		    | (((Tcl_WideUInt) buffer[6]) << 48)
+		    | (((Tcl_WideUInt) buffer[7]) << 56);
+	    return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
 	case 'W':
-	    value = (long) (buffer[3] 
-		    | (buffer[2] << 8)
-		    | (buffer[1] << 16)
-		    | (buffer[0] << 24));
-	    wvalue = ((Tcl_WideInt) value) << 32 | (buffer[7] 
-		    | (buffer[6] << 8)
-		    | (buffer[5] << 16)
-		    | (buffer[4] << 24));
-	    return Tcl_NewWideIntObj(wvalue);
+	    uwvalue =  ((Tcl_WideUInt) buffer[7])
+		    | (((Tcl_WideUInt) buffer[6]) << 8)
+		    | (((Tcl_WideUInt) buffer[5]) << 16)
+		    | (((Tcl_WideUInt) buffer[4]) << 24)
+		    | (((Tcl_WideUInt) buffer[3]) << 32)
+		    | (((Tcl_WideUInt) buffer[2]) << 40)
+		    | (((Tcl_WideUInt) buffer[1]) << 48)
+		    | (((Tcl_WideUInt) buffer[0]) << 56);
+	    return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
 	case 'f': {
 	    float fvalue;
 	    memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
diff --git a/tests/binary.test b/tests/binary.test
index 7fd6871..967fcbc 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: binary.test,v 1.10 2002/10/03 13:34:32 dkf Exp $
+# RCS: @(#) $Id: binary.test,v 1.11 2003/02/21 21:54:11 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -1476,6 +1476,14 @@ test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} {
     binary scan lcTolleH w x
     set x
 } 5216694956358656876
+test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
+    binary scan [binary format w [expr {wide(3) << 31}]] w x
+    set x
+} 6442450944
+test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
+    binary scan [binary format W [expr {wide(3) << 31}]] W x
+    set x
+} 6442450944
 
 test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} {
     binary scan [binary format sws 16450 -1 19521] c* x