diff options
| -rw-r--r-- | generic/tclBasic.c | 280 | ||||
| -rw-r--r-- | tests/expr.test | 145 |
2 files changed, 419 insertions, 6 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d7eaf80..d11411d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -129,6 +129,12 @@ static Tcl_ObjCmdProc ExprDoubleFunc; static Tcl_ObjCmdProc ExprFloorFunc; static Tcl_ObjCmdProc ExprIntFunc; static Tcl_ObjCmdProc ExprIsqrtFunc; +static Tcl_ObjCmdProc ExprIsFiniteFunc; +static Tcl_ObjCmdProc ExprIsInfinityFunc; +static Tcl_ObjCmdProc ExprIsNaNFunc; +static Tcl_ObjCmdProc ExprIsNormalFunc; +static Tcl_ObjCmdProc ExprIsSubnormalFunc; +static Tcl_ObjCmdProc ExprIsUnorderedFunc; static Tcl_ObjCmdProc ExprMaxFunc; static Tcl_ObjCmdProc ExprMinFunc; static Tcl_ObjCmdProc ExprRandFunc; @@ -137,6 +143,7 @@ static Tcl_ObjCmdProc ExprSqrtFunc; static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; +static Tcl_ObjCmdProc FloatClassifyObjCmd; static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; @@ -256,6 +263,7 @@ static const CmdInfo builtInCmds[] = { {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE}, {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE}, + {"fpclassify", FloatClassifyObjCmd, NULL, NULL, CMD_IS_SAFE}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, @@ -424,7 +432,13 @@ static const BuiltinFuncDef BuiltinFuncTable[] = { { "fmod", ExprBinaryFunc, (ClientData) fmod }, { "hypot", ExprBinaryFunc, (ClientData) hypot }, { "int", ExprIntFunc, NULL }, + { "isfinite", ExprIsFiniteFunc, NULL }, + { "isinf", ExprIsInfinityFunc, NULL }, + { "isnan", ExprIsNaNFunc, NULL }, + { "isnormal", ExprIsNormalFunc, NULL }, { "isqrt", ExprIsqrtFunc, NULL }, + { "issubnormal", ExprIsSubnormalFunc, NULL, }, + { "isunordered", ExprIsUnorderedFunc, NULL, }, { "log", ExprUnaryFunc, (ClientData) log }, { "log10", ExprUnaryFunc, (ClientData) log10 }, { "max", ExprMaxFunc, NULL }, @@ -8283,6 +8297,272 @@ ExprSrandFunc( /* *---------------------------------------------------------------------- * + * Double Classification Functions -- + * + * This page contains the functions that implement all of the built-in + * math functions for classifying IEEE doubles. + * + * These have to be a little bit careful while Tcl_GetDoubleFromObj() + * rejects NaN values, which these functions *explicitly* accept. + * + * Results: + * Each function returns TCL_OK if it succeeds and pushes an Tcl object + * holding the result. If it fails it returns TCL_ERROR and leaves an + * error message in the interpreter's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprIsFiniteFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 0; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type != TCL_NUMBER_NAN) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + type = fpclassify(d); + result = (type != FP_INFINITE && type != FP_NAN); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +ExprIsInfinityFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 0; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type != TCL_NUMBER_NAN) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + result = (fpclassify(d) == FP_INFINITE); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +ExprIsNaNFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 1; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type != TCL_NUMBER_NAN) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + result = (fpclassify(d) == FP_NAN); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +ExprIsNormalFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 0; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type != TCL_NUMBER_NAN) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + result = (fpclassify(d) == FP_NORMAL); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +ExprIsSubnormalFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 0; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type != TCL_NUMBER_NAN) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + result = (fpclassify(d) == FP_SUBNORMAL); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +ExprIsUnorderedFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 0; + + if (objc != 3) { + MathFuncWrongNumArgs(interp, 3, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + result = 1; + } else { + d = *((const double *) ptr); + result |= isnan(d); + } + + if (TclGetNumberFromObj(interp, objv[2], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + result = 1; + } else { + d = *((const double *) ptr); + result |= isnan(d); + } + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +FloatClassifyObjCmd( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + Tcl_Obj *objPtr; + ClientData ptr; + int type; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "floatValue"); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + goto gotNaN; + } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + switch (fpclassify(d)) { + case FP_INFINITE: + TclNewLiteralStringObj(objPtr, "infinite"); + break; + case FP_NAN: + gotNaN: + TclNewLiteralStringObj(objPtr, "nan"); + break; + case FP_NORMAL: + TclNewLiteralStringObj(objPtr, "normal"); + break; + case FP_SUBNORMAL: + TclNewLiteralStringObj(objPtr, "subnormal"); + break; + case FP_ZERO: + TclNewLiteralStringObj(objPtr, "zero"); + break; + default: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to classify number: %f", d)); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * MathFuncWrongNumArgs -- * * Generate an error message when a math function presents the wrong diff --git a/tests/expr.test b/tests/expr.test index cb0c24d..cbfc29c 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -133,7 +133,7 @@ proc do_twelve_days {} { unset xxx return $result } - + # start of tests catch {unset a b i x} @@ -7162,14 +7162,147 @@ test expr-52.1 { ::tcl::unsupported::representation $a]] } {0 0 1 1} +foreach func {isfinite isinf isnan isnormal issubnormal} { + test expr-53.1.$func {float classification: basic arg handling} -body { + expr ${func}() + } -returnCodes error -result "too few arguments for math function \"$func\"" + test expr-53.2.$func {float classification: basic arg handling} -body { + expr ${func}(1,2) + } -returnCodes error -result "too many arguments for math function \"$func\"" + test expr-53.3.$func {float classification: basic arg handling} -body { + expr ${func}(true) + } -returnCodes error -result {expected number but got "true"} + test expr-53.4.$func {float classification: basic arg handling} -body { + expr ${func}("gorp") + } -returnCodes error -result {expected number but got "gorp"} + test expr-53.5.$func {float classification: basic arg handling} -body { + expr ${func}(1.0) + } -match glob -result * + test expr-53.6.$func {float classification: basic arg handling} -body { + expr ${func}(0x123) + } -match glob -result * +} +test expr-54.0 {float classification: isfinite} {expr {isfinite(1.0)}} 1 +test expr-54.1 {float classification: isfinite} {expr {isfinite(-1.0)}} 1 +test expr-54.2 {float classification: isfinite} {expr {isfinite(0.0)}} 1 +test expr-54.3 {float classification: isfinite} {expr {isfinite(-0.0)}} 1 +test expr-54.4 {float classification: isfinite} {expr {isfinite(1/Inf)}} 1 +test expr-54.5 {float classification: isfinite} {expr {isfinite(-1/Inf)}} 1 +test expr-54.6 {float classification: isfinite} {expr {isfinite(1e-314)}} 1 +test expr-54.7 {float classification: isfinite} {expr {isfinite(inf)}} 0 +test expr-54.8 {float classification: isfinite} {expr {isfinite(-inf)}} 0 +test expr-54.9 {float classification: isfinite} {expr {isfinite(NaN)}} 0 -# cleanup -if {[info exists a]} { - unset a +test expr-55.0 {float classification: isinf} {expr {isinf(1.0)}} 0 +test expr-55.1 {float classification: isinf} {expr {isinf(-1.0)}} 0 +test expr-55.2 {float classification: isinf} {expr {isinf(0.0)}} 0 +test expr-55.3 {float classification: isinf} {expr {isinf(-0.0)}} 0 +test expr-55.4 {float classification: isinf} {expr {isinf(1/Inf)}} 0 +test expr-55.5 {float classification: isinf} {expr {isinf(-1/Inf)}} 0 +test expr-55.6 {float classification: isinf} {expr {isinf(1e-314)}} 0 +test expr-55.7 {float classification: isinf} {expr {isinf(inf)}} 1 +test expr-55.8 {float classification: isinf} {expr {isinf(-inf)}} 1 +test expr-55.9 {float classification: isinf} {expr {isinf(NaN)}} 0 + +test expr-56.0 {float classification: isnan} {expr {isnan(1.0)}} 0 +test expr-56.1 {float classification: isnan} {expr {isnan(-1.0)}} 0 +test expr-56.2 {float classification: isnan} {expr {isnan(0.0)}} 0 +test expr-56.3 {float classification: isnan} {expr {isnan(-0.0)}} 0 +test expr-56.4 {float classification: isnan} {expr {isnan(1/Inf)}} 0 +test expr-56.5 {float classification: isnan} {expr {isnan(-1/Inf)}} 0 +test expr-56.6 {float classification: isnan} {expr {isnan(1e-314)}} 0 +test expr-56.7 {float classification: isnan} {expr {isnan(inf)}} 0 +test expr-56.8 {float classification: isnan} {expr {isnan(-inf)}} 0 +test expr-56.9 {float classification: isnan} {expr {isnan(NaN)}} 1 + +test expr-57.0 {float classification: isnormal} {expr {isnormal(1.0)}} 1 +test expr-57.1 {float classification: isnormal} {expr {isnormal(-1.0)}} 1 +test expr-57.2 {float classification: isnormal} {expr {isnormal(0.0)}} 0 +test expr-57.3 {float classification: isnormal} {expr {isnormal(-0.0)}} 0 +test expr-57.4 {float classification: isnormal} {expr {isnormal(1/Inf)}} 0 +test expr-57.5 {float classification: isnormal} {expr {isnormal(-1/Inf)}} 0 +test expr-57.6 {float classification: isnormal} {expr {isnormal(1e-314)}} 0 +test expr-57.7 {float classification: isnormal} {expr {isnormal(inf)}} 0 +test expr-57.8 {float classification: isnormal} {expr {isnormal(-inf)}} 0 +test expr-57.9 {float classification: isnormal} {expr {isnormal(NaN)}} 0 + +test expr-58.0 {float classification: issubnormal} {expr {issubnormal(1.0)}} 0 +test expr-58.1 {float classification: issubnormal} {expr {issubnormal(-1.0)}} 0 +test expr-58.2 {float classification: issubnormal} {expr {issubnormal(0.0)}} 0 +test expr-58.3 {float classification: issubnormal} {expr {issubnormal(-0.0)}} 0 +test expr-58.4 {float classification: issubnormal} {expr {issubnormal(1/Inf)}} 0 +test expr-58.5 {float classification: issubnormal} {expr {issubnormal(-1/Inf)}} 0 +test expr-58.6 {float classification: issubnormal} {expr {issubnormal(1e-314)}} 1 +test expr-58.7 {float classification: issubnormal} {expr {issubnormal(inf)}} 0 +test expr-58.8 {float classification: issubnormal} {expr {issubnormal(-inf)}} 0 +test expr-58.9 {float classification: issubnormal} {expr {issubnormal(NaN)}} 0 + +test expr-59.0 {float classification: fpclassify} {fpclassify 1.0} normal +test expr-59.1 {float classification: fpclassify} {fpclassify -1.0} normal +test expr-59.2 {float classification: fpclassify} {fpclassify 0.0} zero +test expr-59.3 {float classification: fpclassify} {fpclassify -0.0} zero +test expr-59.4 {float classification: fpclassify} {fpclassify [expr 1/Inf]} zero +test expr-59.5 {float classification: fpclassify} {fpclassify [expr -1/Inf]} zero +test expr-59.6 {float classification: fpclassify} {fpclassify 1e-314} subnormal +test expr-59.7 {float classification: fpclassify} {fpclassify inf} infinite +test expr-59.8 {float classification: fpclassify} {fpclassify -inf} infinite +test expr-59.9 {float classification: fpclassify} {fpclassify NaN} nan +test expr-59.10 {float classification: fpclassify} -returnCodes error -body { + fpclassify +} -result {wrong # args: should be "fpclassify floatValue"} +test expr-59.11 {float classification: fpclassify} -returnCodes error -body { + fpclassify a b +} -result {wrong # args: should be "fpclassify floatValue"} +test expr-59.12 {float classification: fpclassify} -returnCodes error -body { + fpclassify gorp +} -result {expected number but got "gorp"} + +test expr-60.1 {float classification: basic arg handling} -body { + expr isunordered() +} -returnCodes error -result {too few arguments for math function "isunordered"} +test expr-60.2 {float classification: basic arg handling} -body { + expr isunordered(1) +} -returnCodes error -result {too few arguments for math function "isunordered"} +test expr-60.3 {float classification: basic arg handling} -body { + expr {isunordered(1, 2, 3)} +} -returnCodes error -result {too many arguments for math function "isunordered"} +test expr-60.4 {float classification: basic arg handling} -body { + expr {isunordered(true, 1.0)} +} -returnCodes error -result {expected number but got "true"} +test expr-60.5 {float classification: basic arg handling} -body { + expr {isunordered("gorp", 1.0)} +} -returnCodes error -result {expected number but got "gorp"} +test expr-60.6 {float classification: basic arg handling} -body { + expr {isunordered(0x123, 1.0)} +} -match glob -result * +test expr-60.7 {float classification: basic arg handling} -body { + expr {isunordered(1.0, true)} +} -returnCodes error -result {expected number but got "true"} +test expr-60.8 {float classification: basic arg handling} -body { + expr {isunordered(1.0, "gorp")} +} -returnCodes error -result {expected number but got "gorp"} +test expr-60.9 {float classification: basic arg handling} -body { + expr {isunordered(1.0, 0x123)} +} -match glob -result * + +# Big matrix of comparisons, but it's just a binary isinf() +set values {1.0 -1.0 0.0 -0.0 1e-314 Inf -Inf NaN} +set results {0 0 0 0 0 0 0 1} +set ctr 0 +foreach v1 $values r1 $results { + foreach v2 $values r2 $results { + test expr-61.[incr ctr] "float classification: isunordered($v1,$v2)" { + expr {isunordered($v1, $v2)} + } [expr {$r1 || $r2}] + } } -catch {unset min} -catch {unset max} +unset -nocomplain values results ctr + +# cleanup +unset -nocomplain a +unset -nocomplain min +unset -nocomplain max ::tcltest::cleanupTests return |