TIP#299 IMPLEMENTATION

5 files changed, 235 insertions, 10 deletions

diff --git a/ChangeLog b/ChangeLog
index 93670c9..c5d9229 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -4,6 +4,14 @@
 	* libtommath/bn_mp_div.c:	bollixed 'cvs merge' operation
 	* libtommath/bncore.c:		that inadvertently committed some
 	* libtommath/tommath_class.h:	half-developed code.
+
+	TIP#299 IMPLEMENTATION
+
+	* doc/mathfunc.n:	Added isqrt() function to docs
+	* generic/tclBasic.c:	Added isqrt() math function (ExprIsqrtFunc)
+	* tests/expr.test (expr-47.*): Added tests for isqrt()
+	* tests/info.test (info-20.2): Added isqrt() to expected math
+	funcs.
 	
 2006-12-01  Don Porter  <dgp@users.sourceforge.net>
 
diff --git a/doc/mathfunc.n b/doc/mathfunc.n
index f115cf0..fdc92c7 100644
--- a/doc/mathfunc.n
+++ b/doc/mathfunc.n
@@ -6,7 +6,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: mathfunc.n,v 1.11 2006/07/28 10:38:00 das Exp $
+'\" RCS: @(#) $Id: mathfunc.n,v 1.12 2006/12/01 19:59:59 kennykb Exp $
 '\" 
 .so man.macros
 .TH mathfunc n 8.5 Tcl "Tcl Mathematical Functions"
@@ -51,6 +51,8 @@ package require \fBTcl 8.5\fR
 .br
 \fB::tcl::mathfunc::int\fR \fIarg\fR
 .br
+\fB::tcl::mathfunc::isqrt\fR \fIarg \F
+.br
 \fB::tcl::mathfunc::log\fR \fIarg\fR
 .br
 \fB::tcl::mathfunc::log10\fR \fIarg\fR
@@ -99,10 +101,10 @@ of which work solely with floating-point numbers unless otherwise noted:
 \fBatan2\fR	\fBbool\fR	\fBceil\fR	\fBcos\fR
 \fBcosh\fR	\fBdouble\fR	\fBentier\fR	\fBexp\fR
 \fBfloor\fR	\fBfmod\fR	\fBhypot\fR	\fBint\fR
-\fBlog\fR	\fBlog10\fR	\fBmax\fR	\fBmin\fR
-\fBpow\fR	\fBrand\fR	\fBround\fR	\fBsin\fR
-\fBsinh\fR	\fBsqrt\fR	\fBsrand\fR	\fBtan\fR
-\fBtanh\fR	\fBwide\fR
+\fBisqrt\fR	\fBlog\fR	\fBlog10\fR	\fBmax\fR
+\fBmin\fR	\fBpow\fR	\fBrand\fR	\fBround\fR
+\fBsin\fR	\fBsinh\fR	\fBsqrt\fR	\fBsrand\fR
+\fBtan\fR	\fBtanh\fR	\fBwide\fR
 .DE
 .PP
 .TP
@@ -185,6 +187,12 @@ to the machine word size are returned as an integer value.  For reference,
 the number of bytes in the machine word are stored in
 \fBtcl_platform(wordSize)\fR.
 .TP
+\fBisqrt(\fIarg\fB)\fR
+Computes the integer part of the square root of \fIarg\fR.  \fIArg\fR must be
+a positive value, either an integer or a floating point number.
+Unlike \fBsqrt\fR, which is limited to the precision of a floating point
+number, \fIisqrt\fR will return a result of arbitrary precision.
+.TP
 \fBlog(\fIarg\fB)\fR
 Returns the natural logarithm of \fIarg\fR.  \fIArg\fR must be a
 positive value.
@@ -261,4 +269,4 @@ Copyright (c) 1993 The Regents of the University of California.
 .br
 Copyright (c) 1994-2000 Sun Microsystems Incorporated.
 .br
-Copyright (c) 2005 by Kevin B. Kenny <kennykb@acm.org>. All rights reserved.
+Copyright (c) 2005, 2006 by Kevin B. Kenny <kennykb@acm.org>.
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a3fb387..1226323 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,16 +13,27 @@
  * 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.223 2006/12/01 15:55:44 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.224 2006/12/01 19:59:59 kennykb Exp $
  */
 
 #include "tclInt.h"
 #include "tclCompile.h"
 #include <float.h>
+#include <limits.h>
 #include <math.h>
 #include "tommath.h"
 
 /*
+ * Determine whether we're using IEEE floating point
+ */
+
+#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024)
+#   define IEEE_FLOATING_POINT
+/* Largest odd integer that can be represented exactly in a double */
+#   define MAX_EXACT 9007199254740991.0
+#endif
+
+/*
  * The following structure defines the client data for a math function
  * registered with Tcl_CreateMathFunc
  */
@@ -65,6 +76,8 @@ static int	ExprFloorFunc (ClientData clientData, Tcl_Interp *interp,
 		    int argc, Tcl_Obj *CONST *objv);
 static int	ExprIntFunc (ClientData clientData, Tcl_Interp *interp,
 		    int argc, Tcl_Obj *CONST *objv);
+static int	ExprIsqrtFunc (ClientData clientData, Tcl_Interp *interp,
+		    int argc, Tcl_Obj *CONST *objv);
 static int	ExprRandFunc (ClientData clientData, Tcl_Interp *interp,
 		    int argc, Tcl_Obj *CONST *objv);
 static int	ExprRoundFunc (ClientData clientData, Tcl_Interp *interp,
@@ -237,6 +250,7 @@ static const BuiltinFuncDef BuiltinFuncTable[] = {
     { "fmod",	ExprBinaryFunc,	(ClientData) fmod	},
     { "hypot",	ExprBinaryFunc,	(ClientData) hypot 	},
     { "int",	ExprIntFunc,	NULL			},
+    { "isqrt",	ExprIsqrtFunc,	NULL			},
     { "log",	ExprUnaryFunc,	(ClientData) log 	},
     { "log10",	ExprUnaryFunc,	(ClientData) log10 	},
     { "pow",	ExprBinaryFunc,	(ClientData) pow 	},
@@ -5598,6 +5612,110 @@ ExprFloorFunc(
 }
 
 static int
+ExprIsqrtFunc(
+    ClientData clientData,	/* Ignored */
+    Tcl_Interp* interp,		/* The interpreter in which to execute */
+    int objc,			/* Actual parameter count */
+    Tcl_Obj *CONST *objv)	/* Actual parameter list */
+{
+    ClientData ptr;
+    int type;
+    double d;
+    Tcl_WideInt w;
+    mp_int big;
+    int exact = 0;		/* Flag == 1 if the argument can be
+				 * represented in a double as an exact
+				 * integer */
+
+    /* Check syntax */
+    if (objc != 2) {
+	MathFuncWrongNumArgs(interp, 2, objc, objv);
+	return TCL_ERROR;
+    }
+
+    /* Make sure that the arg is a number */
+    if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    switch (type) {
+
+    case TCL_NUMBER_NAN:
+    {
+	Tcl_GetDoubleFromObj(interp, objv[1], &d);
+	return TCL_ERROR;
+    }
+
+    case TCL_NUMBER_DOUBLE:
+    {
+	d = *((CONST double *)ptr);
+	if (d < 0) {
+	    goto negarg;
+	}
+#ifdef IEEE_FLOATING_POINT
+	if (d <= MAX_EXACT) {
+	    exact = 1;
+	}
+#endif
+	if (!exact) {
+	    if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	}
+	break;
+    }
+    case TCL_NUMBER_BIG:
+    {
+	if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (SIGN(&big) == MP_NEG) {
+	    mp_clear(&big);
+	    goto negarg;
+	}
+	break;
+    }
+
+    default:
+    {
+	if (Tcl_GetWideIntFromObj(interp, objv[1], &w) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (w < 0) {
+	    goto negarg;
+	}
+	d = (double) w;
+#ifdef IEEE_FLOATING_POINT
+	if (d < MAX_EXACT) {
+	    exact = 1;
+	}
+#endif
+	if (!exact) {
+	    Tcl_GetBignumFromObj(interp, objv[1], &big);
+	}
+	break;
+    }
+    }
+
+    if (exact) {
+	Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d)));
+    } else {
+	mp_int root;
+	mp_init(&root);
+	mp_sqrt(&big, &root);
+	mp_clear(&big);
+	Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
+    }
+
+    return TCL_OK;
+
+  negarg:
+    Tcl_SetObjResult(interp,
+		     Tcl_NewStringObj("square root of negative argument", -1));
+    return TCL_ERROR;
+}
+
+static int
 ExprSqrtFunc(
     ClientData clientData,	/* Ignored */
     Tcl_Interp *interp,		/* The interpreter in which to execute the
diff --git a/tests/expr.test b/tests/expr.test
index 7064f17..51b66bd 100644
--- a/tests/expr.test
+++ b/tests/expr.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: expr.test,v 1.65 2006/11/05 03:33:57 dgp Exp $
+# RCS: @(#) $Id: expr.test,v 1.66 2006/12/01 20:00:00 kennykb Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2.1
@@ -6556,6 +6556,97 @@ test expr-46.19 {round() handling of long/bignum boundary} {
     expr {round(double(0x7fffffffffffffff))}
 } 9223372036854775808
 
+test expr-47.1 {isqrt() - arg count} {
+    list [catch {expr {isqrt(1,2)}} result] $result
+} {1 {too many arguments for math function "isqrt"}}
+
+test expr-47.2 {isqrt() - non-number} {
+    list [catch {expr {isqrt({rubbish})}} result] $result
+} {1 {expected number but got "rubbish"}}
+
+test expr-47.3 {isqrt() - NaN} ieeeFloatingPoint {
+    list [catch {expr {isqrt(NaN)}} result] $result
+} {1 {floating point value is Not a Number}}
+
+test expr-47.4 {isqrt() of negative floating point number} {
+    list [catch {expr {isqrt(-1.0)}} result] $result
+} {1 {square root of negative argument}}
+
+test expr-47.5 {isqrt() of floating point zero} {
+    expr isqrt(0.0)
+} 0
+
+test expr-47.6 {isqrt() of exact floating point numbers} {
+    set trouble {}
+    for {set i 0} {$i < 16} {incr i} {
+	set root [expr {1 << $i}]
+	set rm1 [expr {$root - 1}]
+	set arg [expr {pow(2., (2 * $i))}]
+	if {isqrt($arg-1) != $rm1} {
+	    append trouble "i = " $i ": isqrt( " $arg "-1) != " $rm1 "\n"
+	}
+	if {isqrt($arg) != $root} {
+	    append trouble "i = " $i ": isqrt( " $arg ") != " $root "\n"
+	}
+	if {isqrt($arg+1) != $root} {
+	    append trouble "i = " $i ": isqrt( " $arg "+1) != " $root "\n"
+	}
+    }
+    set trouble
+} {}
+
+test expr-47.7 {isqrt() of exact floating point numbers} ieeeFloatingPoint {
+    set trouble {}
+    for {set i 17} {$i < 27} {incr i} {
+	set root [expr {1 << $i}]
+	set rm1 [expr {$root - 1}]
+	set arg [expr {pow(2., (2 * $i))}]
+	if {isqrt($arg-1.0) != $rm1} {
+	    append trouble "i = " $i ": isqrt( " $arg "-1) != " $rm1 "\n"
+	}
+	if {isqrt($arg) != $root} {
+	    append trouble "i = " $i ": isqrt( " $arg ") != " $root "\n"
+	}
+	if {isqrt($arg+1.0) != $root} {
+	    append trouble "i = " $i ": isqrt( " $arg "+1) != " $root "\n"
+	}
+    }
+    set trouble
+} {}
+
+test expr-47.8 {isqrt of inexact floating point number} ieeeFloatingPoint {
+    expr isqrt(2[string repeat 0 34])
+} 141421356237309504
+
+test expr-47.9 {isqrt of negative int} {
+    list [catch {expr isqrt(-1)} result] $result
+} {1 {square root of negative argument}}
+
+test expr-47.10 {isqrt of negative bignum} {
+    list [catch {expr isqrt(-1[string repeat 0 1000])} result] $result
+} {1 {square root of negative argument}}
+
+test expr-47.11 {isqrt of zero} {
+    expr {isqrt(0)}
+} 0
+
+test expr-47.12 {isqrt of various sizes of integer} {
+    for {set i 0} {$i < 3000} {incr i} {
+	set root [expr {1 << $i}]
+	set rm1 [expr {$root - 1}]
+	set arg [expr {1 << (2 * $i)}]
+	if {isqrt($arg-1) != $rm1} {
+	    append trouble "i = " $i ": isqrt( " $arg "-1) != " $rm1 "\n"
+	}
+	if {isqrt($arg) != $root} {
+	    append trouble "i = " $i ": isqrt( " $arg ") != " $root "\n"
+	}
+	if {isqrt($arg+1) != $root} {
+	    append trouble "i = " $i ": isqrt( " $arg "+1) != " $root "\n"
+	}
+    }
+    set trouble
+} {}
 
 # cleanup
 if {[info exists a]} {
diff --git a/tests/info.test b/tests/info.test
index 7b7b867..82c942b 100644
--- a/tests/info.test
+++ b/tests/info.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: info.test,v 1.40 2006/11/28 22:20:29 andreas_kupries Exp $
+# RCS: @(#) $Id: info.test,v 1.41 2006/12/01 20:00:00 kennykb Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -644,7 +644,7 @@ test info-19.6 {info vars: Bug 1072654} -setup {
     namespace delete x
 } -result {}
 
-set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int log log10 max min pow rand round sin sinh sqrt srand tan tanh wide}
+set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isqrt log log10 max min pow rand round sin sinh sqrt srand tan tanh wide}
 # Check whether the extra testing functions are defined...
 if {!([catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} {
     set functions "T1 T2 T3 $functions"  ;# A lazy way of prepending!