[kennykb-numerics-branch]

        * generic/tclBasic.c:   Re-implemented ExprRoundFunc to use
        TclGetNumberFromObj.

        * generic/tclInt.h:     Added new routine TclGetNumberFromObj to
        * generic/tclObj.c:     provide efficient access to the actual
        internal rep of a numeric Tcl_Obj without conversions.

4 files changed, 121 insertions, 96 deletions

diff --git a/ChangeLog b/ChangeLog
index 390e99b..66b3472 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2005-10-03  Don Porter  <dgp@users.sourceforge.net>
+
+	[kennykb-numerics-branch]
+
+	* generic/tclBasic.c:	Re-implemented ExprRoundFunc to use
+	TclGetNumberFromObj.
+
+	* generic/tclInt.h:	Added new routine TclGetNumberFromObj to
+	* generic/tclObj.c:	provide efficient access to the actual
+	internal rep of a numeric Tcl_Obj without conversions.
+
 2005-09-30  Don Porter  <dgp@users.sourceforge.net>
 
 	[kennykb-numerics-branch]
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index fcd7910..a957085 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -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: tclBasic.c,v 1.136.2.35 2005/09/16 19:29:02 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.136.2.36 2005/10/03 15:50:19 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -5591,114 +5591,60 @@ ExprRoundFunc(clientData, interp, objc, objv)
     int objc;			/* Actual parameter count */
     Tcl_Obj *CONST *objv;	/* Parameter vector */
 {
-    Tcl_Obj *valuePtr;
-    double d, fractPart, intPart;
-    mp_int big;
-#if 0
-    double i, f;
-    Tcl_Obj *resPtr;
-#endif
-
-    /*
-     * Check the argument count.
-     */
+    double d;
+    ClientData ptr;
+    int type;
 
     if (objc != 2) {
 	MathFuncWrongNumArgs(interp, 1, objc, objv);
 	return TCL_ERROR;
     }
-    valuePtr = objv[1];
-
-    /*
-     * Coerce the argument to a number. Integers are already rounded.
-     */
 
-#if 0
-    if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
+    if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
 	return TCL_ERROR;
     }
-    if ((valuePtr->typePtr == &tclIntType) ||
-	    (valuePtr->typePtr == &tclWideIntType)) {
-	Tcl_SetObjResult(interp, valuePtr);
-	return TCL_OK;
-    }
-    GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr);
-
-    /*
-     * Round the number to the nearest integer. I'd like to use round(), but
-     * it's C99 (or BSD), and not yet universal.
-     */
-
-    d = valuePtr->internalRep.doubleValue;
-    f = modf(d, &i);
-    if (d < 0.0) {
-	if (f <= -0.5) {
-	    i += -1.0;
-	}
-	if (i <= Tcl_WideAsDouble(LLONG_MIN)) {
-	    goto tooLarge;
-	} else if (d <= (double) LONG_MIN) {
-	    resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
-	} else {
-	    resPtr = Tcl_NewLongObj((long) i);
-	}
-    } else {
-	if (f >= 0.5) {
-	    i += 1.0;
-	}
-	if (i >= Tcl_WideAsDouble(LLONG_MAX)) {
-	    goto tooLarge;
-	} else if (i >= (double) LONG_MAX) {
-	    resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
-	} else {
-	    resPtr = Tcl_NewLongObj((long) i);
-	}
-    }
-    Tcl_SetObjResult(interp, resPtr);
-    return TCL_OK;
-
-    /*
-     * Error return: result cannot be represented as an integer.
-     */
+    if (type == TCL_NUMBER_DOUBLE) {
+	double fractPart, intPart;
+	long max = LONG_MAX, min = LONG_MIN;
 
-  tooLarge:
-    Tcl_SetObjResult(interp, Tcl_NewStringObj(
-	    "integer value too large to represent", -1));
-    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
-	    "integer value too large to represent", (char *) NULL);
-
-    return TCL_ERROR;
-#else
-    if (Tcl_GetDoubleFromObj(interp, valuePtr, &d) != TCL_OK) {
-	/* Non-numeric */
-	return TCL_ERROR;
-    }
-    if (Tcl_GetBignumFromObj(NULL, valuePtr, &big) == TCL_OK) {
-	/* Integers are already rounded */
-	mp_clear(&big);
-	Tcl_SetObjResult(interp, valuePtr);
-	return TCL_OK;
-    }
-    fractPart = modf(d, &intPart);
-    if (fractPart == 0.0) {
-	if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) {
-	    return TCL_ERROR;
-	}
-    } else {
-	if (TclInitBignumFromDouble(interp, intPart, &big) != TCL_OK) {
-	    return TCL_ERROR;
+	fractPart = modf(*((CONST double *)ptr), &intPart);
+	if (fractPart <= -0.5) {
+	    min++;
+	} else if (fractPart >= 0.5) {
+	    max--;
 	}
-	if (fractPart < 0.0) {
+	if ((intPart > (double)max) || (intPart < (double)min)) {
+	    mp_int big;
+	    if (TclInitBignumFromDouble(interp, intPart, &big) != TCL_OK) {
+		/* Infinity */
+		return TCL_ERROR;
+	    }
 	    if (fractPart <= -0.5) {
 		mp_sub_d(&big, 1, &big);
+	    } else if (fractPart >= 0.5) {
+		mp_add_d(&big, 1, &big);
 	    }
-	} else if (fractPart >= 0.5) {
-	    mp_add_d(&big, 1, &big);
+	    Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
+	    return TCL_OK;
+	} else {
+	    long result = (long)intPart;
+	    if (fractPart <= -0.5) {
+		result--;
+	    } else if (fractPart >= 0.5) {
+		result++;
+	    }
+	    Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
+	    return TCL_OK;
 	}
     }
-    Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
-    return TCL_OK;
-#endif
+    if (type != TCL_NUMBER_NAN) {
+	/* All integers are already rounded */
+	Tcl_SetObjResult(interp, objv[1]);
+	return TCL_OK;
+    }
+    /* Get the error message for NaN */
+    Tcl_GetDoubleFromObj(interp, objv[1], &d);
+    return TCL_ERROR;
 }
 
 static int
diff --git a/generic/tclInt.h b/generic/tclInt.h
index d71dadb..c098a11 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.202.2.40 2005/09/16 19:29:02 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.202.2.41 2005/10/03 15:50:19 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -1905,6 +1905,18 @@ typedef struct ProcessGlobalValue {
 				/* Use [scan] rules dealing with 0? prefixes */
 
 /*
+ *----------------------------------------------------------------------
+ * Type values TclGetNumberFromObj
+ *----------------------------------------------------------------------
+ */
+
+#define TCL_NUMBER_LONG		1
+#define TCL_NUMBER_WIDE		2
+#define TCL_NUMBER_BIG		3
+#define TCL_NUMBER_DOUBLE	4
+#define TCL_NUMBER_NAN		5
+
+/*
  *----------------------------------------------------------------
  * Variables shared among Tcl modules but not used by the outside world.
  *----------------------------------------------------------------
@@ -2049,6 +2061,9 @@ MODULE_SCOPE int	TclGetEncodingFromObj(Tcl_Interp *interp,
 			    Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr);
 MODULE_SCOPE int	TclGetNamespaceFromObj(Tcl_Interp *interp,
 			    Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
+MODULE_SCOPE int	TclGetNumberFromObj(Tcl_Interp *interp,
+			    Tcl_Obj *objPtr, ClientData *clientDataPtr,
+			    int *typePtr);
 MODULE_SCOPE int	TclGetOpenModeEx(Tcl_Interp *interp,
 			    CONST char *modeString, int *seekFlagPtr,
 			    int *binaryPtr);
diff --git a/generic/tclObj.c b/generic/tclObj.c
index f573741..f05ebba 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -12,7 +12,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.72.2.39 2005/09/27 18:42:54 dgp Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.72.2.40 2005/10/03 15:50:19 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -2936,6 +2936,59 @@ TclSetBignumIntRep(objPtr, bignumValue)
 /*
  *----------------------------------------------------------------------
  *
+ * TclGetNumberFromObj --
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *----------------------------------------------------------------------
+ */
+
+int TclGetNumberFromObj(interp, objPtr, clientDataPtr, typePtr)
+    Tcl_Interp *interp;
+    Tcl_Obj *objPtr;
+    ClientData *clientDataPtr;
+    int *typePtr;
+{
+    do {
+	if (objPtr->typePtr == &tclDoubleType) {
+	    if (TclIsNaN(objPtr->internalRep.doubleValue)) {
+		*typePtr = TCL_NUMBER_NAN;
+	    } else {
+		*typePtr = TCL_NUMBER_DOUBLE;
+	    }
+	    *clientDataPtr = &(objPtr->internalRep.doubleValue);
+	    return TCL_OK;
+	}
+	if (objPtr->typePtr == &tclIntType) {
+	    *typePtr = TCL_NUMBER_LONG;
+	    *clientDataPtr = &(objPtr->internalRep.longValue);
+	    return TCL_OK;
+	}
+	if (objPtr->typePtr == &tclBignumType) {
+	    static Tcl_ThreadDataKey bignumKey;
+	    mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int)sizeof(mp_int));
+	    UNPACK_BIGNUM( objPtr, *bigPtr );
+	    *typePtr = TCL_NUMBER_BIG;
+	    *clientDataPtr = bigPtr;
+	    return TCL_OK;
+	}
+#ifndef NO_WIDE_TYPE
+	if (objPtr->typePtr == &tclWideIntType) {
+	    *typePtr = TCL_NUMBER_WIDE;
+	    *clientDataPtr = &(objPtr->internalRep.wideValue);
+	    return TCL_OK;
+	}
+#endif
+    } while (TCL_OK ==
+	    TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
+    return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_DbIncrRefCount --
  *
  *	This procedure is normally called when debugging: i.e., when