added support for wide integers to round(); [Bug 908375], reported by

Hemang Lavana.

3 files changed, 59 insertions, 40 deletions

diff --git a/ChangeLog b/ChangeLog
index e564824..56db783 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2004-07-03  Miguel Sofer <msofer@users.sf.net>
+
+	* generic/tclExecute.c (ExprRoundFunc):
+	* tests/expr-old.test (39.1): added support for wide integers to
+	round(); [Bug 908375], reported by Hemang Lavana. 
+
 2004-07-02  Jeff Hobbs  <jeffh@ActiveState.com>
 
 	* generic/regcomp.c (stid): correct minor pointer size error
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 4f3dff4..79b03b9 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.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: tclExecute.c,v 1.94.2.6 2004/05/25 00:08:23 hobbs Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.94.2.7 2004/07/03 22:13:10 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -5328,9 +5328,8 @@ ExprRoundFunc(interp, eePtr, clientData)
 {
     Tcl_Obj **stackPtr;        /* Cached evaluation stack base pointer. */
     register int stackTop;	/* Cached top index of evaluation stack. */
-    Tcl_Obj *valuePtr;
-    long iResult;
-    double d, temp;
+    Tcl_Obj *valuePtr, *resPtr;
+    double d;
     int result;
 
     /*
@@ -5350,57 +5349,56 @@ ExprRoundFunc(interp, eePtr, clientData)
 	result = TCL_ERROR;
 	goto done;
     }
-    
-    if (valuePtr->typePtr == &tclIntType) {
-	iResult = valuePtr->internalRep.longValue;
-    } else if (valuePtr->typePtr == &tclWideIntType) {
-	Tcl_WideInt w;
-	TclGetWide(w,valuePtr);
-	PUSH_OBJECT(Tcl_NewWideIntObj(w));
-	goto done;
+
+    if ((valuePtr->typePtr == &tclIntType) ||
+	    (valuePtr->typePtr == &tclWideIntType)) {
+	result = TCL_OK;
+	resPtr = valuePtr;
     } else {
 	d = valuePtr->internalRep.doubleValue;
 	if (d < 0.0) {
-	    if (d <= (((double) (long) LONG_MIN) - 0.5)) {
-		tooLarge:
-		Tcl_ResetResult(interp);
-		Tcl_AppendToObj(Tcl_GetObjResult(interp),
-		        "integer value too large to represent", -1);
-		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
-			"integer value too large to represent",
-			(char *) NULL);
-		result = TCL_ERROR;
-		goto done;
-	    }
-	    temp = (long) (d - 0.5);
+	    if (d <= Tcl_WideAsDouble(LLONG_MIN)-0.5) {
+		goto tooLarge;
+	    } else if (d <= (((double) (long) LONG_MIN) - 0.5)) {
+		resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(d - 0.5));
+	    } else {
+		resPtr = Tcl_NewLongObj((long) (d - 0.5));
+	    }			    
 	} else {
-	    if (d >= (((double) LONG_MAX + 0.5))) {
+	    if (d >= Tcl_WideAsDouble(LLONG_MAX)+0.5) {
 		goto tooLarge;
+	    } else if (d >= (((double) LONG_MAX + 0.5))) {
+		resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(d + 0.5));
+	    } else {
+		resPtr = Tcl_NewLongObj((long) (d + 0.5));
 	    }
-	    temp = (long) (d + 0.5);
-	}
-	if (IS_NAN(temp) || IS_INF(temp)) {
-	    TclExprFloatError(interp, temp);
-	    result = TCL_ERROR;
-	    goto done;
 	}
-	iResult = (long) temp;
     }
 
     /*
-     * Push a Tcl object with the result.
-     */
-    
-    PUSH_OBJECT(Tcl_NewLongObj(iResult));
-
-    /*
-     * Reflect the change to stackTop back in eePtr.
+     * Push the result object and free the argument Tcl_Obj.
      */
 
+    PUSH_OBJECT(resPtr);
+    
     done:
     TclDecrRefCount(valuePtr);
     DECACHE_STACK_INFO();
     return result;
+
+    /*
+     * Error return: result cannot be represented as an integer.
+     */
+    
+    tooLarge:
+    Tcl_ResetResult(interp);
+    Tcl_AppendToObj(Tcl_GetObjResult(interp),
+	    "integer value too large to represent", -1);
+    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
+	    "integer value too large to represent",
+	    (char *) NULL);
+    result = TCL_ERROR;
+    goto done;
 }
 
 static int
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 17d32d2..90f5cd0 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -13,7 +13,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: expr-old.test,v 1.16.2.1 2003/03/27 13:49:22 dkf Exp $
+# RCS: @(#) $Id: expr-old.test,v 1.16.2.2 2004/07/03 22:13:11 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2.1
@@ -982,6 +982,21 @@ test expr-old-38.1 {Verify Tcl_ExprString's basic operation} {
 } {5 10.2 1 {syntax error in expression "1+": premature end of expression}}
 }
 
+#
+# Test for bug #908375: rounding numbers that do not fit in a
+# long but do fit in a wide
+#
+
+test expr-old-39.1 {Rounding with wide result} {
+    set x 1.0e10
+    set y [expr $x + 0.1]
+    catch {
+	set x [list [expr {$x == round($y)}] [expr $x == -round(-$y)]]
+    }
+    set x
+} {1 1}
+unset x y
+
 # Special test for Pentium arithmetic bug of 1994:
 
 if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} {