One less crazy long/wide aunt in the attic [Bug 868489]

3 files changed, 212 insertions, 26 deletions

diff --git a/ChangeLog b/ChangeLog
index 270ef94..f79d516 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2004-09-10  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
 
+	* generic/tclObj.c (SetIntOrWideFromAny): Rewritten integral value
+	parsing code so that values do not flip so easily between numeric
+	representations. Thanks to KBK for this! [Bug 868489]
+
 	* generic/tclIO.c (Tcl_Seek): Make sure wide seeks do not fail to
 	set ::errorCode on error. [Bug 1025359]
 
diff --git a/generic/tclObj.c b/generic/tclObj.c
index c5d3c7c..1c23c8b 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclObj.c,v 1.63 2004/07/07 08:21:26 dkf Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.64 2004/09/10 21:29:42 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -94,11 +94,14 @@ static int		SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
 			    Tcl_Obj *objPtr));
 static int		SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
 			    Tcl_Obj *objPtr));
+static int		SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp,
+							 Tcl_Obj *objPtr));
 static void		UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
 static void		UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
 static void		UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
 static int		SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
 			    Tcl_Obj *objPtr));
+
 #ifndef TCL_WIDE_INT_IS_LONG
 static void		UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr));
 #endif
@@ -1909,19 +1912,57 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr)
     register int *intPtr;	/* Place to store resulting int. */
 {
     register long l;
+    Tcl_WideInt w;
     int result;
 
-    if (objPtr->typePtr != &tclIntType) {
-	result = SetIntFromAny(interp, objPtr);
-	if (result != TCL_OK) {
+    /* If the object isn't already an integer of any width, try to
+     * convert it to one.
+     */
+
+    if ( objPtr->typePtr != &tclIntType
+	 && objPtr->typePtr != &tclWideIntType ) {
+	result = SetIntOrWideFromAny( interp, objPtr );
+	if ( result != TCL_OK ) {
 	    return result;
 	}
     }
-    l = objPtr->internalRep.longValue;
+
+    /* Object should now be either int or wide. Get its value. */
+
+    if ( objPtr->typePtr == &tclIntType ) {
+	l = objPtr->internalRep.longValue;
+
+#ifndef TCL_WIDE_INT_IS_LONG
+
+    } else if ( objPtr->typePtr == &tclWideIntType ) {
+
+	/*
+	 * If the object is already a wide integer, don't convert it.
+	 * This code allows for any integer in the range -ULONG_MAX to
+	 * ULONG_MAX to be converted to a long, ignoring overflow.
+	 * The rule preserves existing semantics for conversion of
+	 * integers on input, but avoids inadvertent demotion of
+	 * wide integers to 32-bit ones in the internal rep.
+	 */
+	w = objPtr->internalRep.wideValue;
+	if ( w >= -(Tcl_WideInt)(ULONG_MAX)
+	     && w <= (Tcl_WideInt)(ULONG_MAX) ) {
+	    l = Tcl_WideAsLong( w );
+	} else {
+	    goto tooBig;
+	}
+
+#endif
+
+    } else {
+	Tcl_Panic( "string->integer conversion failed to convert the obj." );
+    }
+
     if (((long)((int)l)) == l) {
 	*intPtr = (int)objPtr->internalRep.longValue;
 	return TCL_OK;
     }
+  tooBig:
     if (interp != NULL) {
 	Tcl_ResetResult(interp);
 	Tcl_AppendToObj(Tcl_GetObjResult(interp),
@@ -1935,6 +1976,45 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr)
  *
  * SetIntFromAny --
  *
+ *	Attempts to force the internal representation for a Tcl object
+ *	to tclIntType, specifically.
+ *
+ * Results:
+ *	The return value is a standard object Tcl result.  If an
+ *	error occurs during conversion, an error message is left in
+ *	the interpreter's result unless "interp" is NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetIntFromAny(interp, objPtr)
+    Tcl_Interp* interp;		/* Tcl interpreter */
+    Tcl_Obj* objPtr;		/* Pointer to the object to convert */
+{
+    int result;
+
+    result = SetIntOrWideFromAny(interp, objPtr);
+    if (result != TCL_OK) {
+	return result;
+    }
+    if (objPtr->typePtr != &tclIntType) {
+	if (interp != NULL) {
+	    char *s = "integer value too large to represent";
+	    Tcl_ResetResult(interp);
+	    Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
+	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
+	}
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetIntOrWideFromAny --
+ *
  *	Attempt to generate an integer internal form for the Tcl object
  *	"objPtr".
  *
@@ -1951,7 +2031,7 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr)
  */
 
 static int
-SetIntFromAny(interp, objPtr)
+SetIntOrWideFromAny(interp, objPtr)
     Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
     register Tcl_Obj *objPtr;	/* The object to convert. */
 {
@@ -1959,7 +2039,9 @@ SetIntFromAny(interp, objPtr)
     char *string, *end;
     int length;
     register char *p;
-    long newLong;
+    unsigned long newLong;
+    int isNegative = 0;
+    int isWide = 0;
 
     /*
      * Get the string representation. Make it up-to-date if necessary.
@@ -1976,22 +2058,17 @@ SetIntFromAny(interp, objPtr)
      */
 
     errno = 0;
-#ifdef TCL_STRTOUL_SIGN_CHECK
     for (; isspace(UCHAR(*p)) ; p++) {	/* INTL: ISO space. */
 	/* Empty loop body. */
     }
     if (*p == '-') {
+	isNegative = 1;
 	p++;
-	newLong = -((long)strtoul(p, &end, 0));
     } else if (*p == '+') {
 	p++;
-	newLong = strtoul(p, &end, 0);
-    } else
-#else
-	newLong = strtoul(p, &end, 0);
-#endif
-    if (end == p) {
-	badInteger:
+    }
+    if (!isdigit(UCHAR(*p))) {
+      badInteger:
 	if (interp != NULL) {
 	    Tcl_Obj *msg =
 		    Tcl_NewStringObj("expected integer but got \"", -1);
@@ -2002,6 +2079,10 @@ SetIntFromAny(interp, objPtr)
 	}
 	return TCL_ERROR;
     }
+    newLong = strtoul(p, &end, 0);
+    if (end == p) {
+	goto badInteger;
+    }
     if (errno == ERANGE) {
 	if (interp != NULL) {
 	    char *s = "integer value too large to represent";
@@ -2025,6 +2106,18 @@ SetIntFromAny(interp, objPtr)
     }
 
     /*
+     * If the resulting integer will exceed the range of a long,
+     * put it into a wide instead.  (Tcl Bug #868489)
+     */
+
+#ifndef TCL_WIDE_INT_IS_LONG
+    if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1)
+	    || (!isNegative && newLong > LONG_MAX)) {
+	isWide = 1;
+    }
+#endif
+
+    /*
      * The conversion to int succeeded. Free the old internalRep before
      * setting the new one. We do this as late as possible to allow the
      * conversion code, in particular Tcl_GetStringFromObj, to use that old
@@ -2035,8 +2128,15 @@ SetIntFromAny(interp, objPtr)
 	oldTypePtr->freeIntRepProc(objPtr);
     }
 
-    objPtr->internalRep.longValue = newLong;
-    objPtr->typePtr = &tclIntType;
+    if (isWide) {
+	objPtr->internalRep.wideValue =
+		(isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong);
+	objPtr->typePtr = &tclWideIntType;
+    } else {
+	objPtr->internalRep.longValue =
+		(isNegative ? -(long)newLong : (long)newLong);
+	objPtr->typePtr = &tclIntType;
+    }
     return TCL_OK;
 }
 
@@ -2268,16 +2368,46 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr)
     register long *longPtr;	/* Place to store resulting long. */
 {
     register int result;
+    Tcl_WideInt w;
 
-    if (objPtr->typePtr == &tclIntType) {
-	*longPtr = objPtr->internalRep.longValue;
-	return TCL_OK;
+    if ( objPtr->typePtr != &tclIntType
+	 && objPtr->typePtr != &tclWideIntType ) {
+	result = SetIntOrWideFromAny( interp, objPtr );
+	if ( result != TCL_OK ) {
+	    return result;
+	}
     }
-    result = SetIntFromAny(interp, objPtr);
-    if (result == TCL_OK) {
-	*longPtr = objPtr->internalRep.longValue;
+
+#ifndef TCL_WIDE_INT_IS_LONG
+    
+    if ( objPtr->typePtr == &tclWideIntType ) {
+	/*
+	 * If the object is already a wide integer, don't convert it.
+	 * This code allows for any integer in the range -ULONG_MAX to
+	 * ULONG_MAX to be converted to a long, ignoring overflow.
+	 * The rule preserves existing semantics for conversion of
+	 * integers on input, but avoids inadvertent demotion of
+	 * wide integers to 32-bit ones in the internal rep.
+	 */
+	w = objPtr->internalRep.wideValue;
+	if ( w >= -(Tcl_WideInt)(ULONG_MAX)
+	     && w <= (Tcl_WideInt)(ULONG_MAX) ) {
+	    *longPtr = Tcl_WideAsLong( w );
+	    return TCL_OK;
+	} else {
+	    if (interp != NULL) {
+		Tcl_ResetResult(interp);
+		Tcl_AppendToObj(Tcl_GetObjResult(interp),
+				"integer value too large to represent", -1);
+	    }
+	    return TCL_ERROR;
+	}
     }
-    return result;
+
+#endif
+
+    *longPtr = objPtr->internalRep.longValue;
+    return TCL_OK;
 }
 
 /*
diff --git a/tests/obj.test b/tests/obj.test
index c802fb0..4d7a86b 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -11,14 +11,37 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: obj.test,v 1.10 2004/06/24 10:34:12 dkf Exp $
+# RCS: @(#) $Id: obj.test,v 1.11 2004/09/10 21:29:42 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
     namespace import -force ::tcltest::*
 }
 
+# Procedure to determine the integer range of the machine
+proc int_range {} {
+    for {set MIN_INT 1} {$MIN_INT > 0} {} {
+	set MIN_INT [expr {$MIN_INT << 1}]
+    }
+    set MAX_INT [expr {~ $MIN_INT}]
+    return [list $MIN_INT $MAX_INT]
+}
+
+# Procedure to determine the range of wide integers on the machine.
+proc wide_range {} {
+    for {set MIN_WIDE [expr {wide(1)}] } {$MIN_WIDE > wide(0)} {} {
+	set MIN_WIDE [expr {$MIN_WIDE << 1}]
+    }
+    set MAX_WIDE [expr {~ $MIN_WIDE}]
+    return [list $MIN_WIDE $MAX_WIDE]
+}
+
+foreach {MIN_INT  MAX_INT}  [int_range]  break
+foreach {MIN_WIDE MAX_WIDE} [wide_range] break
+
 testConstraint testobj [llength [info commands testobj]]
+testConstraint 32bit   [expr {$MAX_INT == 0x7fffffff}]
+testConstraint wideBiggerThanInt [expr {$MAX_WIDE > wide($MAX_INT)}]
 
 test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
     set r 1
@@ -596,6 +619,35 @@ test obj-32.1 {freeing very large object trees} {
     unset x
 } {}
 
+test obj-33.1 {integer overflow on input} {32bit wideBiggerThanInt} {
+    set x 0x8000; append x 0000
+    list [string is integer $x] [expr { wide($x) }]
+} {1 2147483648}
+test obj-33.2 {integer overflow on input} {32bit wideBiggerThanInt} {
+    set x 0xffff; append x ffff
+    list [string is integer $x] [expr { wide($x) }]
+} {1 4294967295}
+test obj-33.3 {integer overflow on input} {32bit wideBiggerThanInt} {
+    set x 0x10000; append x 0000
+    list [string is integer $x] [expr { wide($x) }]
+} {0 4294967296}
+test obj-33.4 {integer overflow on input} {32bit wideBiggerThanInt} {
+    set x -0x8000; append x 0000
+    list [string is integer $x] [expr { wide($x) }]
+} {1 -2147483648}
+test obj-33.5 {integer overflow on input} {32bit wideBiggerThanInt} {
+    set x -0x8000; append x 0001
+    list [string is integer $x] [expr { wide($x) }]
+} {1 -2147483649}
+test obj-33.6 {integer overflow on input} {32bit wideBiggerThanInt} {
+    set x -0xffff; append x ffff
+    list [string is integer $x] [expr { wide($x) }]
+} {1 -4294967295}
+test obj-33.7 {integer overflow on input} {32bit wideBiggerThanInt} {
+    set x -0x10000; append x 0000
+    list [string is integer $x] [expr { wide($x) }]
+} {0 -4294967296}
+
 if {[testConstraint testobj]} {
     testobj freeallvars
 }