From c2eeda3f09a8b05e10e5f8f968fc28bb2dcf3750 Mon Sep 17 00:00:00 2001 From: pspjuth Date: Sun, 19 Nov 2017 18:40:13 +0000 Subject: Changed math functions min and max to C implementations. --- generic/tclBasic.c | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclExecute.c | 2 -- generic/tclInt.h | 2 ++ library/init.tcl | 37 ---------------------------- tests/expr-old.test | 20 ++++++++++++--- 5 files changed, 87 insertions(+), 43 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index acdcf41..eefb102 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -118,6 +118,8 @@ static Tcl_ObjCmdProc ExprEntierFunc; static Tcl_ObjCmdProc ExprFloorFunc; static Tcl_ObjCmdProc ExprIntFunc; static Tcl_ObjCmdProc ExprIsqrtFunc; +static Tcl_ObjCmdProc ExprMaxFunc; +static Tcl_ObjCmdProc ExprMinFunc; static Tcl_ObjCmdProc ExprRandFunc; static Tcl_ObjCmdProc ExprRoundFunc; static Tcl_ObjCmdProc ExprSqrtFunc; @@ -321,6 +323,8 @@ static const BuiltinFuncDef BuiltinFuncTable[] = { { "isqrt", ExprIsqrtFunc, NULL }, { "log", ExprUnaryFunc, (ClientData) log }, { "log10", ExprUnaryFunc, (ClientData) log10 }, + { "max", ExprMaxFunc, NULL }, + { "min", ExprMinFunc, NULL }, { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, @@ -7677,6 +7681,71 @@ ExprWideFunc( return TCL_OK; } +/* + * Common implmentation of max() and min(). + */ +static int +ExprMaxMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv, /* Actual parameter vector. */ + int op) /* Comparison direction */ +{ + Tcl_Obj *res; + double d; + int type, i; + ClientData ptr; + + if (objc < 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + res = objv[1]; + for (i = 1; i < objc; i++) { + if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + /* + * Get the error message for NaN. + */ + + Tcl_GetDoubleFromObj(interp, objv[i], &d); + return TCL_ERROR; + } + if (TclCompareTwoNumbers(objv[i], res) == op) { + res = objv[i]; + } + } + + Tcl_SetObjResult(interp, res); + return TCL_OK; +} + +static int +ExprMaxFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_GT); +} + +static int +ExprMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_LT); +} + static int ExprRandFunc( ClientData clientData, /* Ignored. */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 761a23e..c4aa381 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -744,8 +744,6 @@ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, - Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, int opcode, Tcl_Obj **constants, Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); diff --git a/generic/tclInt.h b/generic/tclInt.h index 91c8b96..64c60e4 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2878,6 +2878,8 @@ MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; +MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, diff --git a/library/init.tcl b/library/init.tcl index c31eea3..d5beb69 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -73,43 +73,6 @@ namespace eval tcl { encoding dirs $Path } } - - # TIP #255 min and max functions - namespace eval mathfunc { - proc min {args} { - if {![llength $args]} { - return -code error \ - "too few arguments to math function \"min\"" - } - set val Inf - foreach arg $args { - # This will handle forcing the numeric value without - # ruining the internal type of a numeric object - if {[catch {expr {double($arg)}} err]} { - return -code error $err - } - if {$arg < $val} {set val $arg} - } - return $val - } - proc max {args} { - if {![llength $args]} { - return -code error \ - "too few arguments to math function \"max\"" - } - set val -Inf - foreach arg $args { - # This will handle forcing the numeric value without - # ruining the internal type of a numeric object - if {[catch {expr {double($arg)}} err]} { - return -code error $err - } - if {$arg > $val} {set val $arg} - } - return $val - } - namespace export min max - } } # Windows specific end of initialization diff --git a/tests/expr-old.test b/tests/expr-old.test index 06a00ba..262a71b 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -1159,8 +1159,8 @@ test expr-old-40.2 {min math function} -body { expr {min(0.0)} } -result 0.0 test expr-old-40.3 {min math function} -body { - list [catch {expr {min()}} msg] $msg -} -result {1 {too few arguments to math function "min"}} + expr {min()} +} -returnCodes error -result {too few arguments for math function "min"} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] @@ -1170,6 +1170,12 @@ test expr-old-40.5 {min math function} -body { test expr-old-40.6 {min math function} -body { expr {min(300, "0xFF")} } -result 255 +test expr-old-40.7 {min math function} -body { + expr min(1[string repeat 0 10000], 1e300) +} -result 1e+300 +test expr-old-40.8 {min math function} -body { + expr {min(0, "a")} +} -returnCodes error -match glob -result * test expr-old-41.1 {max math function} -body { expr {max(0)} @@ -1178,8 +1184,8 @@ test expr-old-41.2 {max math function} -body { expr {max(0.0)} } -result 0.0 test expr-old-41.3 {max math function} -body { - list [catch {expr {max()}} msg] $msg -} -result {1 {too few arguments to math function "max"}} + expr {max()} +} -returnCodes error -result {too few arguments for math function "max"} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] @@ -1189,6 +1195,12 @@ test expr-old-41.5 {max math function} -body { test expr-old-41.6 {max math function} -body { expr {max(200, "0xFF")} } -result 255 +test expr-old-41.7 {max math function} -body { + expr max(1[string repeat 0 10000], 1e300) +} -result 1[string repeat 0 10000] +test expr-old-41.8 {max math function} -body { + expr {max(0, "a")} +} -returnCodes error -match glob -result * # Special test for Pentium arithmetic bug of 1994: -- cgit v0.12