[kennykb-numerics-branch]

        * generic/tclBasic.c:   Revised implementation of the ceil(.) and
        * generic/tclInt.h:     floor(.) math functions in light of the
        * generic/tclStrToD.c:  revised comparison operators, so that it
        is always true that ($x <= ceil($x)) and ($x >= floor($x)).  The
        simple approach of "convert to double and call ceil() or floor()"
        could not guarantee that.

4 files changed, 169 insertions, 5 deletions

diff --git a/ChangeLog b/ChangeLog
index fcc7931..9efa152 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -15,6 +15,13 @@
 
 	[kennykb-numerics-branch]
 
+	* generic/tclBasic.c:	Revised implementation of the ceil(.) and
+	* generic/tclInt.h:	floor(.) math functions in light of the
+	* generic/tclStrToD.c:	revised comparison operators, so that it
+	is always true that ($x <= ceil($x)) and ($x >= floor($x)).  The	
+	simple approach of "convert to double and call ceil() or floor()"
+	could not guarantee that.
+
 	* generic/tclExecute.c:	Bug fix: TclBignumToDouble return -Inf when
 	appropriate.  Removed declarations of removed routines.
 
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index e4cd336..6547b34 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.26 2005/08/23 19:22:12 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.136.2.27 2005/08/24 21:49:22 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -57,10 +57,14 @@ static int	ExprBinaryFunc _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
 static int	ExprBoolFunc _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+static int	ExprCeilFunc _ANSI_ARGS_((ClientData clientData,
+		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
 static int	ExprDoubleFunc _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
 static int	ExprEntierFunc _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
+static int	ExprFloorFunc _ANSI_ARGS_((ClientData clientData,
+		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
 static int	ExprIntFunc _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv));
 static int	ExprRandFunc _ANSI_ARGS_((ClientData clientData,
@@ -246,13 +250,13 @@ BuiltinFuncDef BuiltinFuncTable[] = {
     { "::tcl::mathfunc::atan",	ExprUnaryFunc,	(ClientData) atan 	},
     { "::tcl::mathfunc::atan2",	ExprBinaryFunc,	(ClientData) atan2 	},
     { "::tcl::mathfunc::bool",	ExprBoolFunc,	NULL			},
-    { "::tcl::mathfunc::ceil",	ExprUnaryFunc,	(ClientData) ceil 	},
+    { "::tcl::mathfunc::ceil",	ExprCeilFunc,	NULL		 	},
     { "::tcl::mathfunc::cos",	ExprUnaryFunc,	(ClientData) cos 	},
     { "::tcl::mathfunc::cosh",	ExprUnaryFunc,	(ClientData) cosh	},
     { "::tcl::mathfunc::double",ExprDoubleFunc,	NULL			},
     { "::tcl::mathfunc::entier",ExprEntierFunc,	NULL			},
     { "::tcl::mathfunc::exp",	ExprUnaryFunc,	(ClientData) exp	},
-    { "::tcl::mathfunc::floor",	ExprUnaryFunc,	(ClientData) floor 	},
+    { "::tcl::mathfunc::floor",	ExprFloorFunc,	NULL		 	},
     { "::tcl::mathfunc::fmod",	ExprBinaryFunc,	(ClientData) fmod	},
     { "::tcl::mathfunc::hypot",	ExprBinaryFunc,	(ClientData) hypot 	},
     { "::tcl::mathfunc::int",	ExprIntFunc,	NULL			},
@@ -4957,6 +4961,80 @@ Tcl_GetVersion(majorV, minorV, patchLevelV, type)
  */
 
 static int
+ExprCeilFunc(clientData, interp, objc, objv)
+    ClientData clientData;	/* Contains the address of a procedure that
+				 * takes one double argument and returns a
+				 * double result. */
+    Tcl_Interp *interp;		/* The interpreter in which to execute the
+				 * function. */
+    int objc;			/* Actual parameter count */
+    Tcl_Obj *CONST *objv;	/* Actual parameter list */
+{
+    int code;
+    double d;
+    mp_int big;
+
+    if (objc != 2) {
+	MathFuncWrongNumArgs(interp, 2, objc, objv);
+	return TCL_ERROR;
+    }
+    code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
+#ifdef ACCEPT_NAN
+    if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
+	Tcl_SetObjResult(interp, objv[1]);
+	return TCL_OK;
+    }
+#endif
+    if (code != TCL_OK) {
+	return TCL_ERROR;
+    }
+    if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
+	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big)));
+	mp_clear(&big);
+    } else {
+	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
+    }
+    return TCL_OK;
+}
+
+static int
+ExprFloorFunc(clientData, interp, objc, objv)
+    ClientData clientData;	/* Contains the address of a procedure that
+				 * takes one double argument and returns a
+				 * double result. */
+    Tcl_Interp *interp;		/* The interpreter in which to execute the
+				 * function. */
+    int objc;			/* Actual parameter count */
+    Tcl_Obj *CONST *objv;	/* Actual parameter list */
+{
+    int code;
+    double d;
+    mp_int big;
+
+    if (objc != 2) {
+	MathFuncWrongNumArgs(interp, 2, objc, objv);
+	return TCL_ERROR;
+    }
+    code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
+#ifdef ACCEPT_NAN
+    if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
+	Tcl_SetObjResult(interp, objv[1]);
+	return TCL_OK;
+    }
+#endif
+    if (code != TCL_OK) {
+	return TCL_ERROR;
+    }
+    if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
+	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big)));
+	mp_clear(&big);
+    } else {
+	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
+    }
+    return TCL_OK;
+}
+
+static int
 ExprUnaryFunc(clientData, interp, objc, objv)
     ClientData clientData;	/* Contains the address of a procedure that
 				 * takes one double argument and returns a
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1da991d..74d4eb2 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.32 2005/08/23 19:15:40 kennykb Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.202.2.33 2005/08/24 21:49:22 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -1966,6 +1966,7 @@ MODULE_SCOPE void	TclAppendObjToErrorInfo _ANSI_ARGS_((
 MODULE_SCOPE int	TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
 			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
 MODULE_SCOPE double     TclBignumToDouble _ANSI_ARGS_((mp_int* bignum));
+MODULE_SCOPE double	TclCeil _ANSI_ARGS_((mp_int* a));
 MODULE_SCOPE int	TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
 			    CONST char *value));
 MODULE_SCOPE void	TclCleanupLiteralTable _ANSI_ARGS_((
@@ -2003,6 +2004,7 @@ MODULE_SCOPE void	TclFinalizeObjects _ANSI_ARGS_((void));
 MODULE_SCOPE void	TclFinalizePreserve _ANSI_ARGS_((void));
 MODULE_SCOPE void	TclFinalizeSynchronization _ANSI_ARGS_((void));
 MODULE_SCOPE void	TclFinalizeThreadData _ANSI_ARGS_((void));
+MODULE_SCOPE double	TclFloor _ANSI_ARGS_((mp_int* a));
 MODULE_SCOPE void	TclFormatNaN _ANSI_ARGS_((double value, char* buffer));
 MODULE_SCOPE int	TclFSFileAttrIndex _ANSI_ARGS_((Tcl_Obj *pathPtr,
 			    CONST char *attributeName, int *indexPtr));
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 89e97f3..e8e8f7a 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -14,7 +14,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.33 2005/08/24 18:56:32 kennykb Exp $
+ * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.34 2005/08/24 21:49:23 dgp Exp $
  *
  *----------------------------------------------------------------------
  */
@@ -2262,6 +2262,83 @@ TclBignumToDouble(mp_int *a)	/* Integer to convert. */
 	return -r;
     }
 }
+
+double
+TclCeil(mp_int *a)	/* Integer to convert. */
+{
+    double r = 0.0;
+    mp_int b;
+
+    mp_init(&b);
+    if (a->sign == MP_NEG) {
+	mp_neg(a, &b);
+	r = -TclFloor(&b);
+    } else {
+	int bits = mp_count_bits(a);
+
+	if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
+	    r = HUGE_VAL;
+	} else {
+	    int i, exact = 1, shift = mantBits - bits;
+
+	    if (shift > 0) {
+		mp_mul_2d(a, shift, &b);
+	    } else if (shift < 0) {
+		mp_int d;
+		mp_init(&d);
+		mp_div_2d(a, -shift, &b, &d);
+		exact = mp_iszero(&d);
+		mp_clear(&d);
+	    } else {
+		mp_copy(a, &b);
+	    }
+	    if (!exact) {
+		mp_add_d(&b, 1, &b);
+	    }
+	    for (i=b.used-1 ; i>=0 ; --i) {
+		r = ldexp(r, DIGIT_BIT) + b.dp[i];
+	    }
+	    r = ldexp(r, bits - mantBits);
+	}
+    }
+    mp_clear(&b);
+    return r;
+}
+
+double
+TclFloor(mp_int *a)	/* Integer to convert. */
+{
+    double r = 0.0;
+    mp_int b;
+
+    mp_init(&b);
+    if (a->sign == MP_NEG) {
+	mp_neg(a, &b);
+	r = -TclCeil(&b);
+    } else {
+	int bits = mp_count_bits(a);
+
+	if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
+	    r = DBL_MAX;
+	} else {
+	    int i, shift = mantBits - bits;
+
+	    if (shift > 0) {
+		mp_mul_2d(a, shift, &b);
+	    } else if (shift < 0) {
+		mp_div_2d(a, -shift, &b, NULL);
+	    } else {
+		mp_copy(a, &b);
+	    }
+	    for (i=b.used-1 ; i>=0 ; --i) {
+		r = ldexp(r, DIGIT_BIT) + b.dp[i];
+	    }
+	    r = ldexp(r, bits - mantBits);
+	}
+    }
+    mp_clear(&b);
+    return r;
+}
 
 /*
  *----------------------------------------------------------------------