diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 441 |
1 files changed, 439 insertions, 2 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d7eaf80..09c785e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -24,6 +24,33 @@ #include <math.h> #include <assert.h> +/* + * TCL_FPCLASSIFY_MODE: + * 0 - fpclassify + * 1 - _fpclass + * 2 - simulate + * 3 - __builtin_fpclassify + */ + +#ifndef TCL_FPCLASSIFY_MODE +/* + * MINGW x86 (tested up to gcc 8.1) seems to have a bug in fpclassify, + * [fpclassify 1e-314], x86 => normal, x64 => subnormal, so switch to _fpclass + */ +# if ( defined(__MINGW32__) && defined(_X86_) ) /* mingw 32-bit */ +# define TCL_FPCLASSIFY_MODE 1 +# elif defined(fpclassify) /* fpclassify */ +# include <float.h> +# define TCL_FPCLASSIFY_MODE 0 +# elif defined(_FPCLASS_NN) /* _fpclass */ +# define TCL_FPCLASSIFY_MODE 1 +# else /* !fpclassify && !_fpclass (older MSVC), simulate */ +# define TCL_FPCLASSIFY_MODE 2 +# endif /* !fpclassify */ +/* actually there is no fallback to builtin fpclassify */ +#endif /* !TCL_FPCLASSIFY_MODE */ + + #define INTERP_STACK_INITIAL_SIZE 2000 #define CORO_STACK_INITIAL_SIZE 200 @@ -129,6 +156,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 +170,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 +290,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 +459,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 }, @@ -504,6 +545,14 @@ static const OpCmdInfo mathOpCmds[] = { /* unused */ {0}, NULL}, { "eq", TclSortingOpCmd, TclCompileStreqOpCmd, /* unused */ {0}, NULL}, + { "lt", TclSortingOpCmd, TclCompileStrLtOpCmd, + /* unused */ {0}, NULL}, + { "le", TclSortingOpCmd, TclCompileStrLeOpCmd, + /* unused */ {0}, NULL}, + { "gt", TclSortingOpCmd, TclCompileStrGtOpCmd, + /* unused */ {0}, NULL}, + { "ge", TclSortingOpCmd, TclCompileStrGeOpCmd, + /* unused */ {0}, NULL}, { NULL, NULL, NULL, {0}, NULL} }; @@ -600,8 +649,8 @@ Tcl_CreateInterp(void) /*NOTREACHED*/ Tcl_Panic("<time.h> is not compatible with MSVC"); } - if ((TclOffset(Tcl_StatBuf,st_atime) != 32) - || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) { + if ((offsetof(Tcl_StatBuf,st_atime) != 32) + || (offsetof(Tcl_StatBuf,st_ctime) != 40)) { /*NOTREACHED*/ Tcl_Panic("<sys/stat.h> is not compatible with MSVC"); } @@ -8283,6 +8332,394 @@ 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. + * + *---------------------------------------------------------------------- + * + * Older MSVC is supported by Tcl, but doesn't have fpclassify(). Of course. + * But it does sometimes have _fpclass() which does almost the same job; if + * even that is absent, we grobble around directly in the platform's binary + * representation of double. + * + * The ClassifyDouble() function makes all that conform to a common API + * (effectively the C99 standard API renamed), and just delegates to the + * standard macro on platforms that do it correctly. + */ + +static inline int +ClassifyDouble( + double d) +{ +#if TCL_FPCLASSIFY_MODE == 0 + return fpclassify(d); +#else /* !fpclassify */ + /* + * If we don't have fpclassify(), we also don't have the values it returns. + * Hence we define those here. + */ +# ifndef FP_NAN +# define FP_NAN 1 /* Value is NaN */ +# define FP_INFINITE 2 /* Value is an infinity */ +# define FP_ZERO 3 /* Value is a zero */ +# define FP_NORMAL 4 /* Value is a normal float */ +# define FP_SUBNORMAL 5 /* Value has lost accuracy */ +#endif + +# if TCL_FPCLASSIFY_MODE == 3 + return __builtin_fpclassify(FP_NAN, FP_INFINITE, FP_NORMAL, FP_SUBNORMAL, FP_ZERO, d); +# elif TCL_FPCLASSIFY_MODE == 2 + /* + * We assume this hack is only needed on little-endian systems. + * Specifically, x86 running Windows. It's fairly easy to enable for + * others if they need it (because their libc/libm is broken) but we'll + * jump that hurdle when requred. We can solve the word ordering then. + */ + + union { + double d; /* Interpret as double */ + struct { + unsigned int low; /* Lower 32 bits */ + unsigned int high; /* Upper 32 bits */ + } w; /* Interpret as unsigned integer words */ + } doubleMeaning; /* So we can look at the representation of a + * double directly. Platform (i.e., processor) + * specific; this is for x86 (and most other + * little-endian processors, but those are + * untested). */ + unsigned int exponent, mantissaLow, mantissaHigh; + /* The pieces extracted from the double. */ + int zeroMantissa; /* Was the mantissa zero? That's special. */ + + /* + * Shifts and masks to use with the doubleMeaning variable above. + */ + +# define EXPONENT_MASK 0x7ff /* 11 bits (after shifting) */ +# define EXPONENT_SHIFT 20 /* Moves exponent to bottom of word */ +# define MANTISSA_MASK 0xfffff /* 20 bits (plus 32 from other word) */ + + /* + * Extract the exponent (11 bits) and mantissa (52 bits). Note that we + * totally ignore the sign bit. + */ + + doubleMeaning.d = d; + exponent = (doubleMeaning.w.high >> EXPONENT_SHIFT) & EXPONENT_MASK; + mantissaLow = doubleMeaning.w.low; + mantissaHigh = doubleMeaning.w.high & MANTISSA_MASK; + zeroMantissa = (mantissaHigh == 0 && mantissaLow == 0); + + /* + * Look for the special cases of exponent. + */ + + switch (exponent) { + case 0: + /* + * When the exponent is all zeros, it's a ZERO or a SUBNORMAL. + */ + + return zeroMantissa ? FP_ZERO : FP_SUBNORMAL; + case EXPONENT_MASK: + /* + * When the exponent is all ones, it's an INF or a NAN. + */ + + return zeroMantissa ? FP_INFINITE : FP_NAN; + default: + /* + * Everything else is a NORMAL double precision float. + */ + + return FP_NORMAL; + } +# elif TCL_FPCLASSIFY_MODE == 1 + switch (_fpclass(d)) { + case _FPCLASS_NZ: + case _FPCLASS_PZ: + return FP_ZERO; + case _FPCLASS_NN: + case _FPCLASS_PN: + return FP_NORMAL; + case _FPCLASS_ND: + case _FPCLASS_PD: + return FP_SUBNORMAL; + case _FPCLASS_NINF: + case _FPCLASS_PINF: + return FP_INFINITE; + default: + Tcl_Panic("result of _fpclass() outside documented range!"); + case _FPCLASS_QNAN: + case _FPCLASS_SNAN: + return FP_NAN; + } +# else /* unknown TCL_FPCLASSIFY_MODE */ +# error "unknown or unexpected TCL_FPCLASSIFY_MODE" +# endif /* TCL_FPCLASSIFY_MODE */ +#endif /* !fpclassify */ +} + +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 = ClassifyDouble(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 = (ClassifyDouble(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 = (ClassifyDouble(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 = (ClassifyDouble(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 = (ClassifyDouble(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 = (ClassifyDouble(d) == FP_NAN); + } + + 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 |= (ClassifyDouble(d) == FP_NAN); + } + + 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 (ClassifyDouble(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 |