summaryrefslogtreecommitdiffstats
path: root/generic/tclBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r--generic/tclBasic.c821
1 files changed, 767 insertions, 54 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 87533ac..ac290b6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -20,10 +20,50 @@
#include "tclInt.h"
#include "tclOOInt.h"
#include "tclCompile.h"
-#include "tommath.h"
+#include "tclTomMath.h"
#include <math.h>
#include <assert.h>
+/*
+ * TCL_FPCLASSIFY_MODE:
+ * 0 - fpclassify
+ * 1 - _fpclass
+ * 2 - simulate
+ * 3 - __builtin_fpclassify
+ */
+
+#ifndef TCL_FPCLASSIFY_MODE
+#if defined(__MINGW32__) && defined(_X86_) /* mingw 32-bit */
+/*
+ * 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 using a
+ * version using a compiler built-in.
+ */
+#define TCL_FPCLASSIFY_MODE 1
+#elif defined(fpclassify) /* fpclassify */
+/*
+ * This is the C99 standard.
+ */
+#include <float.h>
+#define TCL_FPCLASSIFY_MODE 0
+#elif defined(_FPCLASS_NN) /* _fpclass */
+/*
+ * This case handles newer MSVC on Windows, which doesn't have the standard
+ * operation but does have something that can tell us the same thing.
+ */
+#define TCL_FPCLASSIFY_MODE 1
+#else /* !fpclassify && !_fpclass (older MSVC), simulate */
+/*
+ * Older MSVC on Windows. So broken that we just have to do it our way. This
+ * assumes that we're on x86 (or at least a system with classic little-endian
+ * double layout and a 32-bit 'int' type).
+ */
+#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 +169,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 +183,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;
@@ -171,9 +218,13 @@ static Tcl_NRPostProc TEOV_RunLeaveTraces;
static Tcl_NRPostProc EvalObjvCore;
static Tcl_NRPostProc Dispatch;
-static Tcl_ObjCmdProc NRCoroInjectObjCmd;
+static Tcl_ObjCmdProc NRInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;
static Tcl_ObjCmdProc CoroTypeObjCmd;
+static Tcl_ObjCmdProc TclNRCoroInjectObjCmd;
+static Tcl_ObjCmdProc TclNRCoroProbeObjCmd;
+static Tcl_NRPostProc InjectHandler;
+static Tcl_NRPostProc InjectHandlerPostCall;
MODULE_SCOPE const TclStubs tclStubs;
@@ -243,6 +294,8 @@ static const CmdInfo builtInCmds[] = {
{"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE},
{"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE},
{"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE},
+ {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE},
+ {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE},
{"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE},
{"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE},
{"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE},
@@ -250,6 +303,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},
@@ -366,6 +420,7 @@ static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = {
{"file", "size"},
{"file", "stat"},
{"file", "tail"},
+ {"file", "tempdir"},
{"file", "tempfile"},
{"file", "type"},
{"file", "volumes"},
@@ -417,7 +472,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 },
@@ -497,6 +558,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}
};
@@ -576,7 +645,7 @@ Tcl_CreateInterp(void)
char mathFuncName[32];
CallFrame *framePtr;
- TclInitSubsystems();
+ Tcl_InitSubsystems();
/*
* Panic if someone updated the CallFrame structure without also updating
@@ -588,13 +657,15 @@ Tcl_CreateInterp(void)
Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
}
-#if defined(_WIN32) && !defined(_WIN64)
- if (sizeof(time_t) != 4) {
- /*NOTREACHED*/
- Tcl_Panic("<time.h> is not compatible with MSVC");
- }
- if ((TclOffset(Tcl_StatBuf,st_atime) != 32)
- || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) {
+#if defined(_WIN32) && !defined(_WIN64) && !defined(_USE_64BIT_TIME_T)
+ /* If Tcl is compiled on Win32 using -D_USE_64BIT_TIME_T
+ * the result is a binary incompatible with the 'standard' build of
+ * Tcl: All extensions using Tcl_StatBuf need to be recompiled in
+ * the same way. Therefore, this is not officially supported.
+ * In stead, it is recommended to use Win64 or Tcl 9.0 (not released yet)
+ */
+ if ((offsetof(Tcl_StatBuf,st_atime) != 32)
+ || (offsetof(Tcl_StatBuf,st_ctime) != 40)) {
/*NOTREACHED*/
Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
}
@@ -976,7 +1047,7 @@ Tcl_CreateInterp(void)
/* Coroutine monkeybusiness */
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
- NRCoroInjectObjCmd, NULL, NULL);
+ NRInjectObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
CoroTypeObjCmd, NULL, NULL);
@@ -1228,8 +1299,8 @@ int
TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
- register const CmdInfo *cmdInfoPtr;
- register const UnsafeEnsembleInfo *unsafePtr;
+ const CmdInfo *cmdInfoPtr;
+ const UnsafeEnsembleInfo *unsafePtr;
if (interp == NULL) {
return TCL_ERROR;
@@ -2566,7 +2637,7 @@ TclCreateObjCommandInNs(
Tcl_Interp *interp,
const char *cmdName, /* Name of command, without any namespace
* components. */
- Tcl_Namespace *namespace, /* The namespace to create the command in */
+ Tcl_Namespace *namesp, /* The namespace to create the command in */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
ClientData clientData, /* Arbitrary value to pass to object
@@ -2580,7 +2651,7 @@ TclCreateObjCommandInNs(
ImportRef *oldRefPtr = NULL;
ImportedCmdData *dataPtr;
Tcl_HashEntry *hPtr;
- Namespace *nsPtr = (Namespace *) namespace;
+ Namespace *nsPtr = (Namespace *) namesp;
/*
* If the command name we seek to create already exists, we need to delete
@@ -2755,7 +2826,7 @@ int
TclInvokeStringCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
- register int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Command *cmdPtr = clientData;
@@ -2804,7 +2875,7 @@ TclInvokeObjectCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
- register const char **argv) /* Argument strings. */
+ const char **argv) /* Argument strings. */
{
Command *cmdPtr = clientData;
Tcl_Obj *objPtr;
@@ -3295,7 +3366,7 @@ Tcl_GetCommandFullName(
{
Interp *iPtr = (Interp *) interp;
- register Command *cmdPtr = (Command *) command;
+ Command *cmdPtr = (Command *) command;
char *name;
/*
@@ -3579,7 +3650,7 @@ CallCommandTraces(
* trigger, either TCL_TRACE_DELETE or
* TCL_TRACE_RENAME. */
{
- register CommandTrace *tracePtr;
+ CommandTrace *tracePtr;
ActiveCommandTrace active;
char *result;
Tcl_Obj *oldNamePtr = NULL;
@@ -3769,7 +3840,7 @@ CancelEvalProc(
void
TclCleanupCommand(
- register Command *cmdPtr) /* Points to the Command structure to
+ Command *cmdPtr) /* Points to the Command structure to
* be freed. */
{
if (cmdPtr->refCount-- <= 1) {
@@ -4160,7 +4231,7 @@ int
TclInterpReady(
Tcl_Interp *interp)
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
/*
* Reset both the interpreter's string and object results and clear out
@@ -4232,7 +4303,7 @@ TclResetCancellation(
Tcl_Interp *interp,
int force)
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
if (iPtr == NULL) {
return TCL_ERROR;
@@ -4274,7 +4345,7 @@ Tcl_Canceled(
Tcl_Interp *interp,
int flags)
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
/*
* Has the current script in progress for this interpreter been canceled
@@ -5795,7 +5866,7 @@ TclAdvanceLines(
const char *start,
const char *end)
{
- register const char *p;
+ const char *p;
for (p = start; p < end; p++) {
if (*p == '\n') {
@@ -5890,7 +5961,7 @@ TclArgumentEnter(
CmdFrame *cfPtr)
{
Interp *iPtr = (Interp *) interp;
- int new, i;
+ int isNew, i;
Tcl_HashEntry *hPtr;
CFWord *cfwPtr;
@@ -5906,8 +5977,8 @@ TclArgumentEnter(
if (cfPtr->line[i] < 0) {
continue;
}
- hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &new);
- if (new) {
+ hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &isNew);
+ if (isNew) {
/*
* The word is not on the stack yet, remember the current location
* and initialize references.
@@ -6321,7 +6392,7 @@ int
Tcl_EvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
- register Tcl_Obj *objPtr, /* Pointer to object containing commands to
+ Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags) /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
@@ -6334,7 +6405,7 @@ int
TclEvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
- register Tcl_Obj *objPtr, /* Pointer to object containing commands to
+ Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
@@ -6353,7 +6424,7 @@ int
TclNREvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
- register Tcl_Obj *objPtr, /* Pointer to object containing commands to
+ Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
@@ -6661,7 +6732,7 @@ Tcl_ExprLong(
const char *exprstring, /* Expression to evaluate. */
long *ptr) /* Where to store result. */
{
- register Tcl_Obj *exprPtr;
+ Tcl_Obj *exprPtr;
int result = TCL_OK;
if (*exprstring == '\0') {
/*
@@ -6688,7 +6759,7 @@ Tcl_ExprDouble(
const char *exprstring, /* Expression to evaluate. */
double *ptr) /* Where to store result. */
{
- register Tcl_Obj *exprPtr;
+ Tcl_Obj *exprPtr;
int result = TCL_OK;
if (*exprstring == '\0') {
@@ -6768,7 +6839,7 @@ int
Tcl_ExprLongObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
- register Tcl_Obj *objPtr, /* Expression to evaluate. */
+ Tcl_Obj *objPtr, /* Expression to evaluate. */
long *ptr) /* Where to store long result. */
{
Tcl_Obj *resultPtr;
@@ -6795,8 +6866,8 @@ Tcl_ExprLongObj(
return TCL_ERROR;
}
resultPtr = Tcl_NewBignumObj(&big);
- /* FALLTHROUGH */
}
+ /* FALLTHRU */
case TCL_NUMBER_INT:
case TCL_NUMBER_BIG:
result = TclGetLongFromObj(interp, resultPtr, ptr);
@@ -6815,7 +6886,7 @@ int
Tcl_ExprDoubleObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
- register Tcl_Obj *objPtr, /* Expression to evaluate. */
+ Tcl_Obj *objPtr, /* Expression to evaluate. */
double *ptr) /* Where to store double result. */
{
Tcl_Obj *resultPtr;
@@ -6851,7 +6922,7 @@ int
Tcl_ExprBooleanObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
- register Tcl_Obj *objPtr, /* Expression to evaluate. */
+ Tcl_Obj *objPtr, /* Expression to evaluate. */
int *ptr) /* Where to store 0/1 result. */
{
Tcl_Obj *resultPtr;
@@ -6963,7 +7034,7 @@ TclNRInvoke(
int objc,
Tcl_Obj *const objv[])
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
const char *cmdName; /* Name of the command from objv[0]. */
Tcl_HashEntry *hPtr = NULL;
@@ -7158,7 +7229,7 @@ Tcl_AddObjErrorInfo(
int length) /* The number of bytes in the message. If < 0,
* then append all bytes up to a NULL byte. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
/*
* If we are just starting to log an error, errorInfo is initialized from
@@ -7308,7 +7379,7 @@ Tcl_GlobalEval(
* command. */
const char *command) /* Command to evaluate. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr;
@@ -7574,7 +7645,7 @@ ExprIsqrtFunc(
if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
return TCL_ERROR;
}
- if (big.sign != MP_ZPOS) {
+ if (mp_isneg(&big)) {
mp_clear(&big);
goto negarg;
}
@@ -7820,7 +7891,7 @@ ExprAbsFunc(
}
goto unChanged;
} else if (l == WIDE_MIN) {
- TclInitBignumFromWideInt(&big, l);
+ mp_init_i64(&big, l);
goto tooLarge;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l));
@@ -7848,10 +7919,10 @@ ExprAbsFunc(
}
if (type == TCL_NUMBER_BIG) {
- if (((const mp_int *) ptr)->sign != MP_ZPOS) {
+ if (mp_isneg((const mp_int *) ptr)) {
Tcl_GetBignumFromObj(NULL, objv[1], &big);
tooLarge:
- mp_neg(&big, &big);
+ (void)mp_neg(&big, &big);
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
} else {
unChanged:
@@ -8276,6 +8347,395 @@ 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 /* TCL_FPCLASSIFY_MODE != 0 */
+ /*
+ * 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 /* !FP_NAN */
+
+#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 /* TCL_FPCLASSIFY_MODE not in (0..3) */
+#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
@@ -9278,27 +9738,47 @@ CoroTypeObjCmd(
/*
*----------------------------------------------------------------------
*
- * NRCoroInjectObjCmd --
+ * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd --
*
- * Implementation of [::tcl::unsupported::inject] command.
+ * Implementation of [coroinject] and [coroprobe] commands.
*
*----------------------------------------------------------------------
*/
+static inline CoroutineData *
+GetCoroutineFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ const char *errMsg)
+{
+ /*
+ * How to get a coroutine from its handle.
+ */
+
+ Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
+
+ if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
+ TclGetString(objPtr), NULL);
+ return NULL;
+ }
+ return cmdPtr->objClientData;
+}
+
static int
-NRCoroInjectObjCmd(
+TclNRCoroInjectObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- Command *cmdPtr;
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
/*
* Usage more or less like tailcall:
- * inject coroName cmd ?arg1 arg2 ...?
+ * coroinject coroName cmd ?arg1 arg2 ...?
*/
if (objc < 3) {
@@ -9306,16 +9786,249 @@ NRCoroInjectObjCmd(
return TCL_ERROR;
}
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
- if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
+ corPtr = GetCoroutineFromObj(interp, objv[1],
+ "can only inject a command into a coroutine");
+ if (!corPtr) {
+ return TCL_ERROR;
+ }
+ if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can only inject a command into a coroutine", -1));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
- TclGetString(objv[1]), NULL);
+ "can only inject a command into a suspended coroutine", -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
return TCL_ERROR;
}
- corPtr = cmdPtr->objClientData;
+ /*
+ * Add the callback to the coro's execEnv, so that it is the first thing
+ * to happen when the coro is resumed.
+ */
+
+ iPtr->execEnvPtr = corPtr->eePtr;
+ TclNRAddCallback(interp, InjectHandler, corPtr,
+ Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL);
+ iPtr->execEnvPtr = savedEEPtr;
+
+ return TCL_OK;
+}
+
+static int
+TclNRCoroProbeObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CoroutineData *corPtr;
+ ExecEnv *savedEEPtr = iPtr->execEnvPtr;
+ int numLevels, unused;
+ int *stackLevel = &unused;
+
+ /*
+ * Usage more or less like tailcall:
+ * coroprobe coroName cmd ?arg1 arg2 ...?
+ */
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
+ return TCL_ERROR;
+ }
+
+ corPtr = GetCoroutineFromObj(interp, objv[1],
+ "can only inject a probe command into a coroutine");
+ if (!corPtr) {
+ return TCL_ERROR;
+ }
+ if (!COR_IS_SUSPENDED(corPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only inject a probe command into a suspended coroutine",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Add the callback to the coro's execEnv, so that it is the first thing
+ * to happen when the coro is resumed.
+ */
+
+ iPtr->execEnvPtr = corPtr->eePtr;
+ TclNRAddCallback(interp, InjectHandler, corPtr,
+ Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr);
+ iPtr->execEnvPtr = savedEEPtr;
+
+ /*
+ * Now we immediately transfer control to the coroutine to run our probe.
+ * TRICKY STUFF copied from the [yield] implementation.
+ *
+ * Push the callback to restore the caller's context on yield back.
+ */
+
+ TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr,
+ NULL, NULL, NULL);
+
+ /*
+ * Record the stackLevel at which the resume is happening, then swap
+ * the interp's environment to make it suitable to run this coroutine.
+ */
+
+ corPtr->stackLevel = stackLevel;
+ numLevels = corPtr->auxNumLevels;
+ corPtr->auxNumLevels = iPtr->numLevels;
+
+ /*
+ * Do the actual stack swap.
+ */
+
+ SAVE_CONTEXT(corPtr->caller);
+ corPtr->callerEEPtr = iPtr->execEnvPtr;
+ RESTORE_CONTEXT(corPtr->running);
+ iPtr->execEnvPtr = corPtr->eePtr;
+ iPtr->numLevels += numLevels;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InjectHandler, InjectHandlerPostProc --
+ *
+ * Part of the implementation of [coroinject] and [coroprobe]. These are
+ * run inside the context of the coroutine being injected/probed into.
+ *
+ * InjectHandler runs a script (possibly adding arguments) in the context
+ * of the coroutine. The script is specified as a one-shot list (with
+ * reference count equal to 1) in data[1]. This function also arranges
+ * for InjectHandlerPostProc to be the part that runs after the script
+ * completes.
+ *
+ * InjectHandlerPostProc cleans up after InjectHandler (deleting the
+ * list) and, for the [coroprobe] command *only*, yields back to the
+ * caller context (i.e., where [coroprobe] was run).
+ *s
+ *----------------------------------------------------------------------
+ */
+
+static int
+InjectHandler(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CoroutineData *corPtr = data[0];
+ Tcl_Obj *listPtr = data[1];
+ int nargs = PTR2INT(data[2]);
+ ClientData isProbe = data[3];
+ int objc;
+ Tcl_Obj **objv;
+
+ if (!isProbe) {
+ /*
+ * If this is [coroinject], add the extra arguments now.
+ */
+
+ if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) {
+ Tcl_ListObjAppendElement(NULL, listPtr,
+ Tcl_NewStringObj("yield", -1));
+ } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) {
+ Tcl_ListObjAppendElement(NULL, listPtr,
+ Tcl_NewStringObj("yieldto", -1));
+ } else {
+ /*
+ * I don't think this is reachable...
+ */
+
+ Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs));
+ }
+ Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp));
+ }
+
+ /*
+ * Call the user's script; we're in the right place.
+ */
+
+ Tcl_IncrRefCount(listPtr);
+ TclMarkTailcall(interp);
+ TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr,
+ INT2PTR(nargs), isProbe);
+ TclListObjGetElements(NULL, listPtr, &objc, &objv);
+ return TclNREvalObjv(interp, objc, objv, 0, NULL);
+}
+
+static int
+InjectHandlerPostCall(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CoroutineData *corPtr = data[0];
+ Tcl_Obj *listPtr = data[1];
+ int nargs = PTR2INT(data[2]);
+ ClientData isProbe = data[3];
+ int numLevels;
+
+ /*
+ * Delete the command words for what we just executed.
+ */
+
+ Tcl_DecrRefCount(listPtr);
+
+ /*
+ * If we were doing a probe, splice ourselves back out of the stack
+ * cleanly here. General injection should instead just look after itself.
+ *
+ * Code from guts of [yield] implementation.
+ */
+
+ if (isProbe) {
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp,
+ "\n (injected coroutine probe command)");
+ }
+ corPtr->nargs = nargs;
+ corPtr->stackLevel = NULL;
+ numLevels = iPtr->numLevels;
+ iPtr->numLevels = corPtr->auxNumLevels;
+ corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NRInjectObjCmd --
+ *
+ * Implementation of [::tcl::unsupported::inject] command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NRInjectObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CoroutineData *corPtr;
+ ExecEnv *savedEEPtr = iPtr->execEnvPtr;
+
+ /*
+ * Usage more or less like tailcall:
+ * inject coroName cmd ?arg1 arg2 ...?
+ */
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
+ return TCL_ERROR;
+ }
+
+ corPtr = GetCoroutineFromObj(interp, objv[1],
+ "can only inject a command into a coroutine");
+ if (!corPtr) {
+ return TCL_ERROR;
+ }
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only inject a command into a suspended coroutine", -1));
generated by cgit v0.12 at 2025-04-04 05:31:13 (GMT)