summaryrefslogtreecommitdiffstats
path: root/generic/tclBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r--generic/tclBasic.c1757
1 files changed, 1464 insertions, 293 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5975fd3..45a430f 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -5,13 +5,13 @@
* including interpreter creation and deletion, command creation and
* deletion, and command/script execution.
*
- * Copyright (c) 1987-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
- * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
- * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net>
+ * Copyright © 1987-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 2001, 2002 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 2006-2008 Joe Mistachkin. All rights reserved.
+ * Copyright © 2008 Miguel Sofer <msofer@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -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
@@ -66,12 +106,23 @@ typedef struct {
char *result; /* The script cancellation result or NULL for
* a default result. */
int length; /* Length of the above error message. */
- ClientData clientData; /* Ignored */
+ ClientData clientData; /* Not used. */
int flags; /* Additional flags */
} CancelInfo;
static Tcl_HashTable cancelTable;
static int cancelTableInitialized = 0; /* 0 means not yet initialized. */
-TCL_DECLARE_MUTEX(cancelLock)
+TCL_DECLARE_MUTEX(cancelLock);
+
+/*
+ * Table used to map command implementation functions to a human-readable type
+ * name, for [info type]. The keys in the table are function addresses, and
+ * the values in the table are static char* containing strings in Tcl's
+ * internal encoding (almost UTF-8).
+ */
+
+static Tcl_HashTable commandTypeTable;
+static int commandTypeInit = 0;
+TCL_DECLARE_MUTEX(commandTypeLock);
/*
* Declarations for managing contexts for non-recursive coroutines. Contexts
@@ -94,6 +145,7 @@ TCL_DECLARE_MUTEX(cancelLock)
* Static functions in this file:
*/
+static Tcl_ObjCmdProc BadEnsembleSubcommand;
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
const char *oldName, const char *newName,
int flags);
@@ -114,24 +166,34 @@ static Tcl_ObjCmdProc ExprBinaryFunc;
static Tcl_ObjCmdProc ExprBoolFunc;
static Tcl_ObjCmdProc ExprCeilFunc;
static Tcl_ObjCmdProc ExprDoubleFunc;
-static Tcl_ObjCmdProc ExprEntierFunc;
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;
static Tcl_ObjCmdProc ExprRoundFunc;
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;
static Tcl_NRPostProc NRCoroutineExitCallback;
static Tcl_NRPostProc NRCommand;
+#if !defined(TCL_NO_DEPRECATED)
static Tcl_ObjCmdProc OldMathFuncProc;
static void OldMathFuncDeleteProc(ClientData clientData);
+#endif /* !defined(TCL_NO_DEPRECATED) */
static void ProcessUnexpectedResult(Tcl_Interp *interp,
int returnCode);
static int RewindCoroutine(CoroutineData *corPtr, int result);
@@ -156,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;
@@ -193,6 +259,24 @@ typedef struct {
* it for it. Defined in tclInt.h. */
/*
+ * The following struct states that the command it talks about (a subcommand
+ * of one of Tcl's built-in ensembles) is unsafe and must be hidden when an
+ * interpreter is made safe. (TclHideUnsafeCommands accesses an array of these
+ * structs.) Alas, we can't sensibly just store the information directly in
+ * the commands.
+ */
+
+typedef struct {
+ const char *ensembleNsName; /* The ensemble's name within ::tcl. NULL for
+ * the end of the list of commands to hide. */
+ const char *commandName; /* The name of the command within the
+ * ensemble. If this is NULL, we want to also
+ * make the overall command be hidden, an ugly
+ * hack because it is expected by security
+ * policies in the wild. */
+} UnsafeEnsembleInfo;
+
+/*
* The built-in commands, and the functions that implement them:
*/
@@ -204,12 +288,14 @@ static const CmdInfo builtInCmds[] = {
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
{"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE},
{"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE},
-#ifndef EXCLUDE_OBSOLETE_COMMANDS
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE},
#endif
{"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},
@@ -217,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},
@@ -228,7 +315,9 @@ static const CmdInfo builtInCmds[] = {
{"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE},
{"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE},
+ {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE},
+ {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE},
{"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE},
@@ -286,9 +375,7 @@ static const CmdInfo builtInCmds[] = {
{"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0},
{"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE},
{"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE},
-#ifdef TCL_TIMERATE
{"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE},
-#endif
{"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
{"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE},
{"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE},
@@ -296,6 +383,69 @@ static const CmdInfo builtInCmds[] = {
};
/*
+ * Information about which pieces of ensembles to hide when making an
+ * interpreter safe:
+ */
+
+static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = {
+ /* [encoding] has two unsafe commands. Assumed by older security policies
+ * to be overall unsafe; it isn't but... */
+ {"encoding", NULL},
+ {"encoding", "dirs"},
+ {"encoding", "system"},
+ /* [file] has MANY unsafe commands! Assumed by older security policies to
+ * be overall unsafe; it isn't but... */
+ {"file", NULL},
+ {"file", "atime"},
+ {"file", "attributes"},
+ {"file", "copy"},
+ {"file", "delete"},
+ {"file", "dirname"},
+ {"file", "executable"},
+ {"file", "exists"},
+ {"file", "extension"},
+ {"file", "isdirectory"},
+ {"file", "isfile"},
+ {"file", "link"},
+ {"file", "lstat"},
+ {"file", "mtime"},
+ {"file", "mkdir"},
+ {"file", "nativename"},
+ {"file", "normalize"},
+ {"file", "owned"},
+ {"file", "readable"},
+ {"file", "readlink"},
+ {"file", "rename"},
+ {"file", "rootname"},
+ {"file", "size"},
+ {"file", "stat"},
+ {"file", "tail"},
+ {"file", "tempdir"},
+ {"file", "tempfile"},
+ {"file", "type"},
+ {"file", "volumes"},
+ {"file", "writable"},
+ /* [info] has two unsafe commands */
+ {"info", "cmdtype"},
+ {"info", "nameofexecutable"},
+ /* [tcl::process] has ONLY unsafe commands! */
+ {"process", "list"},
+ {"process", "status"},
+ {"process", "purge"},
+ {"process", "autopurge"},
+ /* [zipfs] has MANY unsafe commands! */
+ {"zipfs", "lmkimg"},
+ {"zipfs", "lmkzip"},
+ {"zipfs", "mkimg"},
+ {"zipfs", "mkkey"},
+ {"zipfs", "mkzip"},
+ {"zipfs", "mount"},
+ {"zipfs", "mount_data"},
+ {"zipfs", "unmount"},
+ {NULL, NULL}
+};
+
+/*
* Math functions. All are safe.
*/
@@ -303,37 +453,45 @@ typedef struct {
const char *name; /* Name of the function. The full name is
* "::tcl::mathfunc::<name>". */
Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */
- ClientData clientData; /* Client data for the function */
+ double (*fn)(double x); /* Real function pointer */
} BuiltinFuncDef;
static const BuiltinFuncDef BuiltinFuncTable[] = {
{ "abs", ExprAbsFunc, NULL },
- { "acos", ExprUnaryFunc, (ClientData) acos },
- { "asin", ExprUnaryFunc, (ClientData) asin },
- { "atan", ExprUnaryFunc, (ClientData) atan },
- { "atan2", ExprBinaryFunc, (ClientData) atan2 },
+ { "acos", ExprUnaryFunc, acos },
+ { "asin", ExprUnaryFunc, asin },
+ { "atan", ExprUnaryFunc, atan },
+ { "atan2", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) atan2},
{ "bool", ExprBoolFunc, NULL },
{ "ceil", ExprCeilFunc, NULL },
- { "cos", ExprUnaryFunc, (ClientData) cos },
- { "cosh", ExprUnaryFunc, (ClientData) cosh },
+ { "cos", ExprUnaryFunc, cos },
+ { "cosh", ExprUnaryFunc, cosh },
{ "double", ExprDoubleFunc, NULL },
- { "entier", ExprEntierFunc, NULL },
- { "exp", ExprUnaryFunc, (ClientData) exp },
+ { "entier", ExprIntFunc, NULL },
+ { "exp", ExprUnaryFunc, exp },
{ "floor", ExprFloorFunc, NULL },
- { "fmod", ExprBinaryFunc, (ClientData) fmod },
- { "hypot", ExprBinaryFunc, (ClientData) hypot },
+ { "fmod", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) fmod},
+ { "hypot", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) hypot},
{ "int", ExprIntFunc, NULL },
+ { "isfinite", ExprIsFiniteFunc, NULL },
+ { "isinf", ExprIsInfinityFunc, NULL },
+ { "isnan", ExprIsNaNFunc, NULL },
+ { "isnormal", ExprIsNormalFunc, NULL },
{ "isqrt", ExprIsqrtFunc, NULL },
- { "log", ExprUnaryFunc, (ClientData) log },
- { "log10", ExprUnaryFunc, (ClientData) log10 },
- { "pow", ExprBinaryFunc, (ClientData) pow },
+ { "issubnormal", ExprIsSubnormalFunc, NULL, },
+ { "isunordered", ExprIsUnorderedFunc, NULL, },
+ { "log", ExprUnaryFunc, log },
+ { "log10", ExprUnaryFunc, log10 },
+ { "max", ExprMaxFunc, NULL },
+ { "min", ExprMinFunc, NULL },
+ { "pow", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) pow},
{ "rand", ExprRandFunc, NULL },
{ "round", ExprRoundFunc, NULL },
- { "sin", ExprUnaryFunc, (ClientData) sin },
- { "sinh", ExprUnaryFunc, (ClientData) sinh },
+ { "sin", ExprUnaryFunc, sin },
+ { "sinh", ExprUnaryFunc, sinh },
{ "sqrt", ExprSqrtFunc, NULL },
{ "srand", ExprSrandFunc, NULL },
- { "tan", ExprUnaryFunc, (ClientData) tan },
- { "tanh", ExprUnaryFunc, (ClientData) tanh },
+ { "tan", ExprUnaryFunc, tan },
+ { "tanh", ExprUnaryFunc, tanh },
{ "wide", ExprWideFunc, NULL },
{ NULL, NULL, NULL }
};
@@ -400,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}
};
@@ -429,11 +595,120 @@ TclFinalizeEvaluation(void)
cancelTableInitialized = 0;
}
Tcl_MutexUnlock(&cancelLock);
+
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit) {
+ Tcl_DeleteHashTable(&commandTypeTable);
+ commandTypeInit = 0;
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
}
/*
*----------------------------------------------------------------------
*
+ * buildInfoObjCmd --
+ *
+ * Implements tcl::build-info command.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+buildInfoObjCmd(
+ void *clientData,
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?option?");
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ int len;
+ const char *arg = TclGetStringFromObj(objv[1], &len);
+ if (len == 7 && !strcmp(arg, "version")) {
+ char buf[80];
+ const char *p = strchr((char *)clientData, '.');
+ if (p) {
+ const char *q = strchr(p+1, '.');
+ const char *r = strchr(p+1, '+');
+ p = (q < r) ? q : r;
+ }
+ if (p) {
+ memcpy(buf, (char *)clientData, p - (char *)clientData);
+ buf[p - (char *)clientData] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ }
+ return TCL_OK;
+ } else if (len == 10 && !strcmp(arg, "patchlevel")) {
+ char buf[80];
+ const char *p = strchr((char *)clientData, '+');
+ if (p) {
+ memcpy(buf, (char *)clientData, p - (char *)clientData);
+ buf[p - (char *)clientData] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ }
+ return TCL_OK;
+ } else if (len == 6 && !strcmp(arg, "commit")) {
+ const char *q, *p = strchr((char *)clientData, '+');
+ if (p) {
+ if ((q = strchr(p, '.'))) {
+ char buf[80];
+ memcpy(buf, p+1, q - p - 1);
+ buf[q - p - 1] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ } else {
+ Tcl_AppendResult(interp, p+1, NULL);
+ }
+ }
+ return TCL_OK;
+ } else if (len == 8 && !strcmp(arg, "compiler")) {
+ const char *p = strchr((char *)clientData, '.');
+ while (p) {
+ if (!strncmp(p+1, "clang-", 6) || !strncmp(p+1, "gcc-", 4)
+ || !strncmp(p+1, "icc-", 4) || !strncmp(p+1, "msvc-", 5)) {
+ const char *q = strchr(p+1, '.');
+ if (q) {
+ char buf[16];
+ memcpy(buf, p+1, q - p - 1);
+ buf[q - p - 1] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ } else {
+ Tcl_AppendResult(interp, p+1, NULL);
+ }
+ return TCL_OK;
+ }
+ p = strchr(p+1, '.');
+ }
+ Tcl_AppendResult(interp, "0", NULL);
+ return TCL_OK;
+ }
+ const char *p = strchr((char *)clientData, '.');
+ while (p) {
+ if (!strncmp(p+1, arg, len) && ((p[len+1] == '.') || (p[len+1] == '\0'))) {
+ Tcl_AppendResult(interp, "1", NULL);
+ return TCL_OK;
+ }
+ p = strchr(p+1, '.');
+ }
+ Tcl_AppendResult(interp, "0", NULL);
+ return TCL_OK;
+ }
+ Tcl_AppendResult(interp, (char *)clientData, NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_CreateInterp --
*
* Create a new TCL command interpreter.
@@ -471,7 +746,7 @@ Tcl_CreateInterp(void)
#endif /* TCL_COMPILE_STATS */
char mathFuncName[32];
CallFrame *framePtr;
- const char *version = TclInitSubsystems();
+ const char *version = Tcl_InitSubsystems();
/*
* Panic if someone updated the CallFrame structure without also updating
@@ -489,8 +764,8 @@ Tcl_CreateInterp(void)
* 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 ((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)) {
Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
}
#endif
@@ -505,6 +780,19 @@ Tcl_CreateInterp(void)
Tcl_MutexUnlock(&cancelLock);
}
+ if (commandTypeInit == 0) {
+ TclRegisterCommandTypeName(TclObjInterpProc, "proc");
+ TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
+ TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
+ TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
+ TclRegisterCommandTypeName(TclChildObjCmd, "interp");
+ TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
+ TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object");
+ TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject");
+ TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass");
+ TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine");
+ }
+
/*
* Initialize support for namespaces and create the global namespace
* (whose name is ""; an alias is "::"). This also initializes the Tcl
@@ -514,7 +802,11 @@ Tcl_CreateInterp(void)
iPtr = (Interp *)ckalloc(sizeof(Interp));
interp = (Tcl_Interp *) iPtr;
+#ifdef TCL_NO_DEPRECATED
+ iPtr->result = &tclEmptyString;
+#else
iPtr->result = iPtr->resultSpace;
+#endif
iPtr->freeProc = NULL;
iPtr->errorLine = 0;
TclNewObj(iPtr->objResultPtr);
@@ -574,9 +866,11 @@ Tcl_CreateInterp(void)
iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */
iPtr->lookupNsPtr = NULL;
+#ifndef TCL_NO_DEPRECATED
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
+#endif
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
@@ -586,15 +880,16 @@ Tcl_CreateInterp(void)
#endif
/* TIP #268 */
+#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE)
if (getenv("TCL_PKG_PREFER_LATEST") == NULL) {
iPtr->packagePrefer = PKG_PREFER_STABLE;
- } else {
+ } else
+#endif
iPtr->packagePrefer = PKG_PREFER_LATEST;
- }
iPtr->cmdCount = 0;
TclInitLiteralTable(&iPtr->literalTable);
- iPtr->compileEpoch = 0;
+ iPtr->compileEpoch = 1;
iPtr->compiledProcPtr = NULL;
iPtr->resolverPtr = NULL;
iPtr->evalFlags = 0;
@@ -606,10 +901,11 @@ Tcl_CreateInterp(void)
iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = NULL;
iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */
- TclNewObj(iPtr->emptyObjPtr);
- /* Another empty object. */
+ TclNewObj(iPtr->emptyObjPtr); /* Another empty object. */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
+#ifndef TCL_NO_DEPRECATED
iPtr->resultSpace[0] = 0;
+#endif
iPtr->threadId = Tcl_GetCurrentThread();
/* TIP #378 */
@@ -742,7 +1038,7 @@ Tcl_CreateInterp(void)
* cache was already initialised by the call to alloc the interp struct.
*/
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
iPtr->allocCache = (AllocCache *)TclpGetAllocCache();
#else
iPtr->allocCache = NULL;
@@ -812,6 +1108,7 @@ Tcl_CreateInterp(void)
TclInitNamespaceCmd(interp);
TclInitStringCmd(interp);
TclInitPrefixCmd(interp);
+ TclInitProcessCmd(interp);
/*
* Register "clock" subcommands. These *do* go through
@@ -852,14 +1149,10 @@ 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);
- /* Create an unsupported command for timerate */
- Tcl_CreateObjCommand(interp, "::tcl::unsupported::timerate",
- Tcl_TimeRateObjCmd, NULL, NULL);
-
/* Export unsupported commands */
nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
if (nsPtr) {
@@ -889,7 +1182,7 @@ Tcl_CreateInterp(void)
builtinFuncPtr++) {
strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
Tcl_CreateObjCommand(interp, mathFuncName,
- builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL);
+ builtinFuncPtr->objCmdProc, (void *)builtinFuncPtr->fn, NULL);
Tcl_Export(interp, nsPtr, builtinFuncPtr->name, 0);
}
@@ -951,24 +1244,26 @@ Tcl_CreateInterp(void)
TCL_GLOBAL_ONLY);
Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize",
- Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY);
+ Tcl_NewWideIntObj(sizeof(long)), TCL_GLOBAL_ONLY);
/* TIP #291 */
Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize",
- Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY);
+ Tcl_NewWideIntObj(sizeof(void *)), TCL_GLOBAL_ONLY);
/*
* Set up other variables such as tcl_version and tcl_library
*/
- Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
- Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY);
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Tcl_TraceVar2(interp, "tcl_precision", NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
TclPrecTraceProc, NULL);
+#endif /* !TCL_NO_DEPRECATED */
TclpSetVariables(interp);
-#ifdef TCL_THREADS
+#if TCL_THREADS && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* The existence of the "threaded" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with threads
@@ -982,16 +1277,21 @@ Tcl_CreateInterp(void)
/*
* Register Tcl's version number.
* TIP #268: Full patchlevel instead of just major.minor
+ * TIP #599: Extended build information "+<UUID>.<tag1>.<tag2>...."
*/
- Tcl_PkgProvideEx(interp, "Tcl", version, &tclStubs);
+ Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
+ Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs);
+ Tcl_CreateObjCommand(interp, "::tcl::build-info",
+ buildInfoObjCmd, (void *)version, NULL);
+
if (TclTommath_Init(interp) != TCL_OK) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
if (TclOOInit(interp) != TCL_OK) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
/*
@@ -1001,6 +1301,9 @@ Tcl_CreateInterp(void)
#ifdef HAVE_ZLIB
if (TclZlibInit(interp) != TCL_OK) {
+ Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
+ }
+ if (TclZipfs_Init(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
}
#endif
@@ -1019,6 +1322,71 @@ DeleteOpCmdClientData(
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * TclRegisterCommandTypeName, TclGetCommandTypeName --
+ *
+ * Command type registration and lookup mechanism. Everything is keyed by
+ * the Tcl_ObjCmdProc for the command, and that is used as the *key* into
+ * the hash table that maps to constant strings that are names. (It is
+ * recommended that those names be ASCII.)
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclRegisterCommandTypeName(
+ Tcl_ObjCmdProc *implementationProc,
+ const char *nameStr)
+{
+ Tcl_HashEntry *hPtr;
+
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit == 0) {
+ Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS);
+ commandTypeInit = 1;
+ }
+ if (nameStr != NULL) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(&commandTypeTable,
+ (void *) implementationProc, &isNew);
+ Tcl_SetHashValue(hPtr, (void *) nameStr);
+ } else {
+ hPtr = Tcl_FindHashEntry(&commandTypeTable,
+ (void *) implementationProc);
+ if (hPtr != NULL) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
+}
+
+const char *
+TclGetCommandTypeName(
+ Tcl_Command command)
+{
+ Command *cmdPtr = (Command *) command;
+ Tcl_ObjCmdProc *procPtr = cmdPtr->objProc;
+ const char *name = "native";
+
+ if (procPtr == NULL) {
+ procPtr = cmdPtr->nreProc;
+ }
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr);
+
+ if (hPtr && Tcl_GetHashValue(hPtr)) {
+ name = (const char *) Tcl_GetHashValue(hPtr);
+ }
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
+
+ return name;
+}
+
+/*
*----------------------------------------------------------------------
*
* TclHideUnsafeCommands --
@@ -1039,6 +1407,7 @@ TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
const CmdInfo *cmdInfoPtr;
+ const UnsafeEnsembleInfo *unsafePtr;
if (interp == NULL) {
return TCL_ERROR;
@@ -1048,12 +1417,83 @@ TclHideUnsafeCommands(
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
- TclMakeEncodingCommandSafe(interp); /* Ugh! */
- TclMakeFileCommandSafe(interp); /* Ugh! */
+
+ for (unsafePtr = unsafeEnsembleCommands;
+ unsafePtr->ensembleNsName; unsafePtr++) {
+ if (unsafePtr->commandName) {
+ /*
+ * Hide an ensemble subcommand.
+ */
+
+ Tcl_Obj *cmdName = Tcl_ObjPrintf("::tcl::%s::%s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName);
+ Tcl_Obj *hideName = Tcl_ObjPrintf("tcl:%s:%s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName);
+
+ if (TclRenameCommand(interp, TclGetString(cmdName),
+ "___tmp") != TCL_OK
+ || Tcl_HideCommand(interp, "___tmp",
+ TclGetString(hideName)) != TCL_OK) {
+ Tcl_Panic("problem making '%s %s' safe: %s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName,
+ Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+ Tcl_CreateObjCommand(interp, TclGetString(cmdName),
+ BadEnsembleSubcommand, (void *)unsafePtr, NULL);
+ TclDecrRefCount(cmdName);
+ TclDecrRefCount(hideName);
+ } else {
+ /*
+ * Hide an ensemble main command (for compatibility).
+ */
+
+ if (Tcl_HideCommand(interp, unsafePtr->ensembleNsName,
+ unsafePtr->ensembleNsName) != TCL_OK) {
+ Tcl_Panic("problem making '%s' safe: %s",
+ unsafePtr->ensembleNsName,
+ Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+ }
+ }
+
return TCL_OK;
}
/*
+ *----------------------------------------------------------------------
+ *
+ * BadEnsembleSubcommand --
+ *
+ * Command used to act as a backstop implementation when subcommands of
+ * ensembles are unsafe (the real implementations of the subcommands are
+ * hidden). The clientData is description of what was hidden.
+ *
+ * Results:
+ * A standard Tcl result (always a TCL_ERROR).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BadEnsembleSubcommand(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /* objv */)
+{
+ const UnsafeEnsembleInfo *infoPtr = (const UnsafeEnsembleInfo *)clientData;
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "not allowed to invoke subcommand %s of %s",
+ infoPtr->commandName, infoPtr->ensembleNsName));
+ Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
+ return TCL_ERROR;
+}
+
+/*
*--------------------------------------------------------------
*
* Tcl_CallWhenDeleted --
@@ -1491,28 +1931,28 @@ DeleteInterpProc(
ckfree(hTablePtr);
}
- /*
- * Invoke deletion callbacks; note that a callback can create new
- * callbacks, so we iterate.
- */
- while (iPtr->assocData != NULL) {
+ if (iPtr->assocData != NULL) {
AssocData *dPtr;
hTablePtr = iPtr->assocData;
- iPtr->assocData = NULL;
+ /*
+ * Invoke deletion callbacks; note that a callback can create new
+ * callbacks, so we iterate.
+ */
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
- Tcl_DeleteHashEntry(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
+ Tcl_DeleteHashEntry(hPtr);
ckfree(dPtr);
}
Tcl_DeleteHashTable(hTablePtr);
ckfree(hTablePtr);
+ iPtr->assocData = NULL;
}
/*
@@ -1533,8 +1973,10 @@ DeleteInterpProc(
* could have transferred ownership of the result string to Tcl.
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_FreeResult(interp);
iPtr->result = NULL;
+#endif
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = NULL;
Tcl_DecrRefCount(iPtr->ecVar);
@@ -1556,10 +1998,12 @@ DeleteInterpProc(
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
}
+#ifndef TCL_NO_DEPRECATED
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
}
+#endif
TclFreePackageInfo(iPtr);
while (iPtr->tracePtr != NULL) {
Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr);
@@ -1657,7 +2101,7 @@ DeleteInterpProc(
}
Tcl_DeleteHashTable(iPtr->lineLAPtr);
- ckfree((char *) iPtr->lineLAPtr);
+ ckfree(iPtr->lineLAPtr);
iPtr->lineLAPtr = NULL;
if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
@@ -2448,7 +2892,10 @@ TclCreateObjCommandInNs(
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
+
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
+ cmdPtr->refCount++;
+ TclCleanupCommandMacro(dataPtr->realCmdPtr);
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
@@ -2499,7 +2946,7 @@ TclInvokeStringCommand(
TclStackAlloc(interp, (objc + 1) * sizeof(char *));
for (i = 0; i < objc; i++) {
- argv[i] = Tcl_GetString(objv[i]);
+ argv[i] = TclGetString(objv[i]);
}
argv[objc] = 0;
@@ -2753,7 +3200,7 @@ TclRenameCommand(
}
Tcl_DStringAppend(&newFullName, newTail, -1);
cmdPtr->refCount++;
- CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName),
+ CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName),
Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
Tcl_DStringFree(&newFullName);
@@ -2979,7 +3426,7 @@ Tcl_GetCommandInfoFromToken(
const char *
Tcl_GetCommandName(
- Tcl_Interp *interp, /* Interpreter containing the command. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Command command) /* Token for command returned by a previous
* call to Tcl_CreateCommand. The command must
* not have been deleted. */
@@ -3038,7 +3485,7 @@ Tcl_GetCommandFullName(
* separator, and the command name.
*/
- if (cmdPtr != NULL) {
+ if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) {
if (cmdPtr->nsPtr != NULL) {
Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
@@ -3120,13 +3567,6 @@ Tcl_DeleteCommandFromToken(
Tcl_Command importCmd;
/*
- * Bump the command epoch counter. This will invalidate all cached
- * references that point to this command.
- */
-
- cmdPtr->cmdEpoch++;
-
- /*
* The code here is tricky. We can't delete the hash table entry before
* invoking the deletion callback because there are cases where the
* deletion callback needs to invoke the command (e.g. object systems such
@@ -3135,7 +3575,7 @@ Tcl_DeleteCommandFromToken(
* and skip nested deletes.
*/
- if (cmdPtr->flags & CMD_IS_DELETED) {
+ if (cmdPtr->flags & CMD_DYING) {
/*
* Another deletion is already in progress. Remove the hash table
* entry now, but don't invoke a callback or free the command
@@ -3148,6 +3588,14 @@ Tcl_DeleteCommandFromToken(
Tcl_DeleteHashEntry(cmdPtr->hPtr);
cmdPtr->hPtr = NULL;
}
+
+ /*
+ * Bump the command epoch counter. This will invalidate all cached
+ * references that point to this command.
+ */
+
+ cmdPtr->cmdEpoch++;
+
return 0;
}
@@ -3159,17 +3607,18 @@ Tcl_DeleteCommandFromToken(
* be ignored.
*/
- cmdPtr->flags |= CMD_IS_DELETED;
+ cmdPtr->flags |= CMD_DYING;
/*
- * Call trace functions for the command being deleted. Then delete its
- * traces.
+ * Call each functions and then delete the trace.
*/
cmdPtr->nsPtr->refCount++;
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
+ /* CallCommandTraces() does not cmdPtr, that's
+ * done just before Tcl_DeleteCommandFromToken() returns */
CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
/*
@@ -3324,7 +3773,7 @@ CallCommandTraces(
* While a rename trace is active, we will not process any more rename
* traces; while a delete trace is active we will never reach here -
* because Tcl_DeleteCommandFromToken checks for the condition
- * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a
+ * (cmdPtr->flags & CMD_DYING) and returns immediately when a
* command deletion is in progress. For all other traces, delete
* traces will not be invoked but a call to TraceCommandProc will
* ensure that tracePtr->clientData is freed whenever the command
@@ -3424,7 +3873,7 @@ CallCommandTraces(
static int
CancelEvalProc(
ClientData clientData, /* Interp to cancel the script in progress. */
- Tcl_Interp *interp, /* Ignored */
+ TCL_UNUSED(Tcl_Interp *),
int code) /* Current return code from command. */
{
CancelInfo *cancelInfo = (CancelInfo *)clientData;
@@ -3531,6 +3980,7 @@ TclCleanupCommand(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
void
Tcl_CreateMathFunc(
Tcl_Interp *interp, /* Interpreter in which function is to be
@@ -3615,9 +4065,14 @@ OldMathFuncProc(
valuePtr = objv[j];
result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
#ifdef ACCEPT_NAN
- if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) {
- d = valuePtr->internalRep.doubleValue;
- result = TCL_OK;
+ if (result != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr
+ = TclFetchInternalRep(valuePtr, &tclDoubleType);
+
+ if (irPtr) {
+ d = irPtr->doubleValue;
+ result = TCL_OK;
+ }
}
#endif
if (result != TCL_OK) {
@@ -3628,7 +4083,7 @@ OldMathFuncProc(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument to math function didn't have numeric value",
-1));
- TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
+ TclCheckBadOctal(interp, TclGetString(valuePtr));
ckfree(args);
return TCL_ERROR;
}
@@ -3696,9 +4151,9 @@ OldMathFuncProc(
*/
if (funcResult.type == TCL_INT) {
- TclNewLongObj(valuePtr, funcResult.intValue);
+ TclNewIntObj(valuePtr, funcResult.intValue);
} else if (funcResult.type == TCL_WIDE_INT) {
- valuePtr = Tcl_NewWideIntObj(funcResult.wideValue);
+ TclNewIntObj(valuePtr, funcResult.wideValue);
} else {
return CheckDoubleResult(interp, funcResult.doubleValue);
}
@@ -3864,6 +4319,7 @@ Tcl_ListMathFuncs(
return result;
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
*----------------------------------------------------------------------
@@ -4048,7 +4504,7 @@ Tcl_Canceled(
*/
if (iPtr->asyncCancelMsg != NULL) {
- message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
+ message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length);
} else {
length = 0;
}
@@ -4147,7 +4603,7 @@ Tcl_CancelEval(
*/
if (resultObjPtr != NULL) {
- result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length);
+ result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length);
cancelInfo->result = (char *)ckrealloc(cancelInfo->result,cancelInfo->length);
memcpy(cancelInfo->result, result, cancelInfo->length);
TclDecrRefCount(resultObjPtr); /* Discard their result object. */
@@ -4266,7 +4722,7 @@ static int
EvalObjvCore(
ClientData data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0];
int flags = PTR2INT(data[1]);
@@ -4426,7 +4882,7 @@ static int
Dispatch(
ClientData data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0];
ClientData clientData = data[1];
@@ -4475,7 +4931,9 @@ TclNRRunCallbacks(
/* All callbacks down to rootPtr not inclusive
* are to be run. */
{
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Interp *iPtr = (Interp *) interp;
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
* If the interpreter has a non-empty string result, the result object is
@@ -4487,9 +4945,11 @@ TclNRRunCallbacks(
* are for NR function calls, and those are Tcl_Obj based.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
* This is the trampoline.
@@ -4513,6 +4973,7 @@ NRCommand(
int result)
{
Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *listPtr;
iPtr->numLevels--;
@@ -4521,7 +4982,10 @@ NRCommand(
*/
if (data[1] && (data[1] != INT2PTR(1))) {
- TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
+ listPtr = (Tcl_Obj *)data[1];
+ data[1] = NULL;
+
+ TclNRAddCallback(interp, TclNRTailcallEval, listPtr, NULL, NULL, NULL);
}
/* OPT ??
@@ -4666,7 +5130,7 @@ TEOV_Error(
*/
listPtr = Tcl_NewListObj(objc, objv);
- cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
+ cmdString = TclGetStringFromObj(listPtr, &cmdLen);
Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
Tcl_DecrRefCount(listPtr);
}
@@ -4810,9 +5274,9 @@ TEOV_RunEnterTraces(
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
- int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
+ unsigned int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
int length, traceCode = TCL_OK;
- const char *command = Tcl_GetStringFromObj(commandPtr, &length);
+ const char *command = TclGetStringFromObj(commandPtr, &length);
/*
* Call trace functions.
@@ -4864,9 +5328,9 @@ TEOV_RunLeaveTraces(
Command *cmdPtr = (Command *)data[2];
Tcl_Obj **objv = (Tcl_Obj **)data[3];
int length;
- const char *command = Tcl_GetStringFromObj(commandPtr, &length);
+ const char *command = TclGetStringFromObj(commandPtr, &length);
- if (!(cmdPtr->flags & CMD_IS_DELETED)) {
+ if (!(cmdPtr->flags & CMD_DYING)) {
if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
@@ -4953,6 +5417,7 @@ Tcl_EvalTokensStandard(
NULL, NULL);
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -5000,6 +5465,7 @@ Tcl_EvalTokens(
Tcl_ResetResult(interp);
return resPtr;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -5897,7 +6363,7 @@ TclArgumentGet(
* up by the caller. It knows better than us.
*/
- if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) {
+ if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) {
return;
}
@@ -5955,6 +6421,7 @@ TclArgumentGet(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_Eval
int
Tcl_Eval(
@@ -6007,6 +6474,7 @@ Tcl_GlobalEvalObj(
{
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6160,7 +6628,7 @@ TclNREvalObjEx(
TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
objPtr, NULL);
- ListObjGetElements(listPtr, objc, objv);
+ TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
@@ -6228,7 +6696,7 @@ TclNREvalObjEx(
Tcl_IncrRefCount(objPtr);
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ script = TclGetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
TclDecrRefCount(objPtr);
@@ -6259,7 +6727,7 @@ TEOEx_ByteCodeCallback(
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ script = TclGetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
@@ -6516,8 +6984,7 @@ Tcl_ExprLongObj(
resultPtr = Tcl_NewBignumObj(&big);
}
/* FALLTHRU */
- case TCL_NUMBER_LONG:
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
case TCL_NUMBER_BIG:
result = TclGetLongFromObj(interp, resultPtr, ptr);
break;
@@ -6678,7 +7145,7 @@ TclObjInvoke(
int
TclNRInvoke(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6721,7 +7188,7 @@ TclNRInvoke(
static int
NRPostInvoke(
- ClientData clientData[],
+ TCL_UNUSED(ClientData *),
Tcl_Interp *interp,
int result)
{
@@ -6764,7 +7231,7 @@ Tcl_ExprString(
* An empty string. Just set the interpreter's result to 0.
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
} else {
Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1);
@@ -6811,11 +7278,10 @@ Tcl_AppendObjToErrorInfo(
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
- int length;
- const char *message = TclGetStringFromObj(objPtr, &length);
+ const char *message = TclGetString(objPtr);
Tcl_IncrRefCount(objPtr);
- Tcl_AddObjErrorInfo(interp, message, length);
+ Tcl_AddObjErrorInfo(interp, message, objPtr->length);
Tcl_DecrRefCount(objPtr);
}
@@ -6838,6 +7304,7 @@ Tcl_AppendObjToErrorInfo(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_AddErrorInfo
void
Tcl_AddErrorInfo(
@@ -6847,6 +7314,7 @@ Tcl_AddErrorInfo(
{
Tcl_AddObjErrorInfo(interp, message, -1);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6887,7 +7355,8 @@ Tcl_AddObjErrorInfo(
iPtr->flags |= ERR_LEGACY_COPY;
if (iPtr->errorInfo == NULL) {
- if (iPtr->result[0] != 0) {
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+ if (*(iPtr->result) != 0) {
/*
* The interp's string result is set, apparently by some extension
* making a deprecated direct write to it. That extension may
@@ -6897,9 +7366,9 @@ Tcl_AddObjErrorInfo(
*/
iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1);
- } else {
+ } else
+#endif /* !defined(TCL_NO_DEPRECATED) */
iPtr->errorInfo = iPtr->objResultPtr;
- }
Tcl_IncrRefCount(iPtr->errorInfo);
if (!iPtr->errorCode) {
Tcl_SetErrorCode(interp, "NONE", NULL);
@@ -6962,7 +7431,7 @@ Tcl_VarEvalVA(
Tcl_DStringAppend(&buf, string, -1);
}
- result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
+ result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
Tcl_DStringFree(&buf);
return result;
}
@@ -7018,6 +7487,7 @@ Tcl_VarEval(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GlobalEval
int
Tcl_GlobalEval(
@@ -7031,10 +7501,11 @@ Tcl_GlobalEval(
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = iPtr->rootFramePtr;
- result = Tcl_Eval(interp, command);
+ result = Tcl_EvalEx(interp, command, -1, 0);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -7156,7 +7627,7 @@ Tcl_GetVersion(
static int
ExprCeilFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7172,9 +7643,13 @@ ExprCeilFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7192,7 +7667,7 @@ ExprCeilFunc(
static int
ExprFloorFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7208,9 +7683,13 @@ ExprFloorFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7228,7 +7707,7 @@ ExprFloorFunc(
static int
ExprIsqrtFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter list. */
@@ -7282,7 +7761,7 @@ ExprIsqrtFunc(
if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
return TCL_ERROR;
}
- if (big.sign) {
+ if (mp_isneg(&big)) {
mp_clear(&big);
goto negarg;
}
@@ -7310,10 +7789,16 @@ ExprIsqrtFunc(
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d)));
} else {
mp_int root;
+ mp_err err;
- mp_init(&root);
- mp_sqrt(&big, &root);
+ err = mp_init(&root);
+ if (err == MP_OKAY) {
+ err = mp_sqrt(&big, &root);
+ }
mp_clear(&big);
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
}
return TCL_OK;
@@ -7328,7 +7813,7 @@ ExprIsqrtFunc(
static int
ExprSqrtFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7344,9 +7829,13 @@ ExprSqrtFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7355,10 +7844,17 @@ ExprSqrtFunc(
if ((d >= 0.0) && TclIsInfinite(d)
&& (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) {
mp_int root;
+ mp_err err;
- mp_init(&root);
- mp_sqrt(&big, &root);
+ err = mp_init(&root);
+ if (err == MP_OKAY) {
+ err = mp_sqrt(&big, &root);
+ }
mp_clear(&big);
+ if (err != MP_OKAY) {
+ mp_clear(&root);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root)));
mp_clear(&root);
} else {
@@ -7387,10 +7883,14 @@ ExprUnaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- d = objv[1]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7447,10 +7947,14 @@ ExprBinaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- d1 = objv[1]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d1 = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7458,10 +7962,14 @@ ExprBinaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) {
- d2 = objv[2]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d2 = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7473,7 +7981,7 @@ ExprBinaryFunc(
static int
ExprAbsFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7492,28 +8000,41 @@ ExprAbsFunc(
return TCL_ERROR;
}
- if (type == TCL_NUMBER_LONG) {
- long l = *((const long *) ptr);
+ if (type == TCL_NUMBER_INT) {
+ Tcl_WideInt l = *((const Tcl_WideInt *) ptr);
- if (l > (long)0) {
+ if (l > 0) {
goto unChanged;
- } else if (l == (long)0) {
- const char *string = objv[1]->bytes;
- if (string) {
- while (*string != '0') {
- if (*string == '-') {
- Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
+ } else if (l == 0) {
+ if (TclHasStringRep(objv[1])) {
+ int numBytes;
+ const char *bytes = TclGetStringFromObj(objv[1], &numBytes);
+
+ while (numBytes) {
+ if (*bytes == '-') {
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
}
- string++;
+ bytes++; numBytes--;
}
}
goto unChanged;
- } else if (l == LONG_MIN) {
- TclBNInitBignumFromLong(&big, l);
+ } else if (l == WIDE_MIN) {
+ if (sizeof(Tcl_WideInt) > sizeof(int64_t)) {
+ Tcl_WideUInt ul = -(Tcl_WideUInt)WIDE_MIN;
+ if (mp_init(&big) != MP_OKAY || mp_unpack(&big, 1, 1,
+ sizeof(Tcl_WideInt), 0, 0, &ul) != MP_OKAY) {
+ return TCL_ERROR;
+ }
+ if (mp_neg(&big, &big) != MP_OKAY) {
+ return TCL_ERROR;
+ }
+ } else if (mp_init_i64(&big, l) != MP_OKAY) {
+ return TCL_ERROR;
+ }
goto tooLarge;
}
- Tcl_SetObjResult(interp, Tcl_NewLongObj(-l));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l));
return TCL_OK;
}
@@ -7537,27 +8058,13 @@ ExprAbsFunc(
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (type == TCL_NUMBER_WIDE) {
- Tcl_WideInt w = *((const Tcl_WideInt *) ptr);
-
- if (w >= (Tcl_WideInt)0) {
- goto unChanged;
- }
- if (w == LLONG_MIN) {
- TclBNInitBignumFromWideInt(&big, w);
- goto tooLarge;
- }
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w));
- return TCL_OK;
- }
-#endif
-
if (type == TCL_NUMBER_BIG) {
- if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) {
+ if (mp_isneg((const mp_int *) ptr)) {
Tcl_GetBignumFromObj(NULL, objv[1], &big);
tooLarge:
- (void)mp_neg(&big, &big);
+ if (mp_neg(&big, &big) != MP_OKAY) {
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
} else {
unChanged:
@@ -7582,7 +8089,7 @@ ExprAbsFunc(
static int
ExprBoolFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7603,7 +8110,7 @@ ExprBoolFunc(
static int
ExprDoubleFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7617,7 +8124,7 @@ ExprDoubleFunc(
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (objv[1]->typePtr == &tclDoubleType) {
+ if (TclHasInternalRep(objv[1], &tclDoubleType)) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
@@ -7629,8 +8136,8 @@ ExprDoubleFunc(
}
static int
-ExprEntierFunc(
- ClientData clientData, /* Ignored. */
+ExprIntFunc(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7650,19 +8157,7 @@ ExprEntierFunc(
if (type == TCL_NUMBER_DOUBLE) {
d = *((const double *) ptr);
- if ((d < (double)LONG_MAX) && (d > (double)LONG_MIN)) {
- long result = (long) d;
-
- Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
- return TCL_OK;
-#ifndef TCL_WIDE_INT_IS_LONG
- } else if ((d < (double)LLONG_MAX) && (d > (double)LLONG_MIN)) {
- Tcl_WideInt result = (Tcl_WideInt) d;
-
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
- return TCL_OK;
-#endif
- } else {
+ if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) {
mp_int big;
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
@@ -7671,6 +8166,11 @@ ExprEntierFunc(
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
return TCL_OK;
+ } else {
+ Tcl_WideInt result = (Tcl_WideInt) d;
+
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
+ return TCL_OK;
}
}
@@ -7692,73 +8192,91 @@ ExprEntierFunc(
}
static int
-ExprIntFunc(
- ClientData clientData, /* Ignored. */
+ExprWideFunc(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
- long iResult;
- Tcl_Obj *objPtr;
- if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
- return TCL_ERROR;
- }
- objPtr = Tcl_GetObjResult(interp);
- if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
- /*
- * Truncate the bignum; keep only bits in long range.
- */
-
- mp_int big;
+ Tcl_WideInt wResult;
- Tcl_GetBignumFromObj(NULL, objPtr, &big);
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &iResult);
- Tcl_DecrRefCount(objPtr);
+ if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) {
+ return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult));
+ TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
return TCL_OK;
}
+/*
+ * Common implmentation of max() and min().
+ */
static int
-ExprWideFunc(
- ClientData clientData, /* Ignored. */
+ExprMaxMinFunc(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
- Tcl_Obj *const *objv) /* Actual parameter vector. */
+ Tcl_Obj *const *objv, /* Actual parameter vector. */
+ int op) /* Comparison direction */
{
- Tcl_WideInt wResult;
- Tcl_Obj *objPtr;
+ Tcl_Obj *res;
+ double d;
+ int type, i;
+ ClientData ptr;
- if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
+ if (objc < 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
- objPtr = Tcl_GetObjResult(interp);
- if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
- /*
- * Truncate the bignum; keep only bits in wide int range.
- */
-
- mp_int big;
+ 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_GetBignumFromObj(NULL, objPtr, &big);
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetWideIntFromObj(NULL, objPtr, &wResult);
- Tcl_DecrRefCount(objPtr);
+ Tcl_GetDoubleFromObj(interp, objv[i], &d);
+ return TCL_ERROR;
+ }
+ if (TclCompareTwoNumbers(objv[i], res) == op) {
+ res = objv[i];
+ }
}
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
+
+ Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
+ExprMaxFunc(
+ TCL_UNUSED(void *),
+ 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(NULL, interp, objc, objv, MP_GT);
+}
+
+static int
+ExprMinFunc(
+ TCL_UNUSED(void *),
+ 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(NULL, interp, objc, objv, MP_LT);
+}
+
+static int
ExprRandFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7851,7 +8369,7 @@ ExprRandFunc(
static int
ExprRoundFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7872,7 +8390,7 @@ ExprRoundFunc(
if (type == TCL_NUMBER_DOUBLE) {
double fractPart, intPart;
- long max = LONG_MAX, min = LONG_MIN;
+ Tcl_WideInt max = WIDE_MAX, min = WIDE_MIN;
fractPart = modf(*((const double *) ptr), &intPart);
if (fractPart <= -0.5) {
@@ -7882,27 +8400,31 @@ ExprRoundFunc(
}
if ((intPart >= (double)max) || (intPart <= (double)min)) {
mp_int big;
+ mp_err err = MP_OKAY;
if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) {
/* Infinity */
return TCL_ERROR;
}
if (fractPart <= -0.5) {
- mp_sub_d(&big, 1, &big);
+ err = mp_sub_d(&big, 1, &big);
} else if (fractPart >= 0.5) {
- mp_add_d(&big, 1, &big);
+ err = mp_add_d(&big, 1, &big);
+ }
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
return TCL_OK;
} else {
- long result = (long)intPart;
+ Tcl_WideInt result = (Tcl_WideInt)intPart;
if (fractPart <= -0.5) {
result--;
} else if (fractPart >= 0.5) {
result++;
}
- Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
}
@@ -7926,14 +8448,14 @@ ExprRoundFunc(
static int
ExprSrandFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
Interp *iPtr = (Interp *) interp;
- long i = 0; /* Initialized to avoid compiler warning. */
+ Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */
/*
* Convert argument and use it to reset the seed.
@@ -7944,20 +8466,8 @@ ExprSrandFunc(
return TCL_ERROR;
}
- if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) {
- Tcl_Obj *objPtr;
- mp_int big;
-
- if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
- /* TODO: more ::errorInfo here? or in caller? */
- return TCL_ERROR;
- }
-
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &i);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) {
+ return TCL_ERROR;
}
/*
@@ -7966,8 +8476,7 @@ ExprSrandFunc(
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
- iPtr->randSeed = i;
- iPtr->randSeed &= (unsigned long) 0x7FFFFFFF;
+ iPtr->randSeed = (long) w & 0x7FFFFFFF;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) {
iPtr->randSeed ^= 123459876;
}
@@ -7978,7 +8487,396 @@ ExprSrandFunc(
* will always succeed.
*/
- return ExprRandFunc(clientData, interp, 1, objv);
+ return ExprRandFunc(NULL, interp, 1, objv);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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(
+ TCL_UNUSED(void *),
+ 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(
+ TCL_UNUSED(void *),
+ 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(
+ TCL_UNUSED(void *),
+ 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(
+ TCL_UNUSED(void *),
+ 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(
+ TCL_UNUSED(void *),
+ 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(
+ TCL_UNUSED(void *),
+ 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(
+ TCL_UNUSED(void *),
+ 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;
}
/*
@@ -8005,7 +8903,7 @@ MathFuncWrongNumArgs(
int found, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
- const char *name = Tcl_GetString(objv[0]);
+ const char *name = TclGetString(objv[0]);
const char *tail = name + strlen(name);
while (tail > name+1) {
@@ -8040,8 +8938,8 @@ MathFuncWrongNumArgs(
static int
DTraceObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
@@ -8247,7 +9145,8 @@ Tcl_NRCreateCommand(
* this command is deleted. */
{
Command *cmdPtr = (Command *)
- Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc);
+ Tcl_CreateObjCommand(interp, cmdName, proc, clientData,
+ deleteProc);
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
@@ -8264,7 +9163,8 @@ TclNRCreateCommandInNs(
Tcl_CmdDeleteProc *deleteProc)
{
Command *cmdPtr = (Command *)
- TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc);
+ TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData,
+ deleteProc);
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
@@ -8422,7 +9322,7 @@ TclSetTailcall(
int
TclNRTailcallObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8527,7 +9427,7 @@ TclNRTailcallEval(
int
TclNRReleaseValues(
ClientData data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
int i = 0;
@@ -8615,7 +9515,7 @@ TclNRYieldObjCmd(
int
TclNRYieldToObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8660,6 +9560,7 @@ TclNRYieldToObjCmd(
iPtr->execEnvPtr = corPtr->callerEEPtr;
TclSetTailcall(interp, listPtr);
+ corPtr->yieldPtr = listPtr;
iPtr->execEnvPtr = corPtr->eePtr;
return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
@@ -8669,9 +9570,9 @@ static int
RewindCoroutineCallback(
ClientData data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
- return Tcl_RestoreInterpState(interp, data[0]);
+ return Tcl_RestoreInterpState(interp, (Tcl_InterpState)data[0]);
}
static int
@@ -8738,7 +9639,7 @@ NRCoroutineCallerCallback(
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
- if (cmdPtr->flags & CMD_IS_DELETED) {
+ if (cmdPtr->flags & CMD_DYING) {
/*
* The command was deleted while it was running: wind down the
* execEnv, this will do the complete cleanup. RewindCoroutine will
@@ -8820,7 +9721,7 @@ int
TclNRCoroutineActivateCallback(
ClientData data[],
Tcl_Interp *interp,
- int result /*result*/)
+ TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
int type = PTR2INT(data[1]);
@@ -8857,6 +9758,22 @@ TclNRCoroutineActivateCallback(
*/
if (corPtr->stackLevel != stackLevel) {
+ NRE_callback *runPtr;
+
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ if (corPtr->yieldPtr) {
+ for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
+ if (runPtr->data[1] == corPtr->yieldPtr) {
+ runPtr->data[1] = NULL;
+ Tcl_DecrRefCount(corPtr->yieldPtr);
+ corPtr->yieldPtr = NULL;
+ break;
+ }
+ }
+ }
+ iPtr->execEnvPtr = corPtr->eePtr;
+
+
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot yield: C stack busy", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
@@ -8872,6 +9789,7 @@ TclNRCoroutineActivateCallback(
Tcl_Panic("Yield received an option which is not implemented");
}
+ corPtr->yieldPtr = NULL;
corPtr->stackLevel = NULL;
numLevels = iPtr->numLevels;
@@ -8899,7 +9817,7 @@ static int
TclNREvalList(
ClientData data[],
Tcl_Interp *interp,
- int result /*result*/)
+ TCL_UNUSED(int) /*result*/)
{
int objc;
Tcl_Obj **objv;
@@ -8925,7 +9843,7 @@ TclNREvalList(
static int
CoroTypeObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8985,27 +9903,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 (CoroutineData *)cmdPtr->objClientData;
+}
+
static int
-NRCoroInjectObjCmd(
- ClientData clientData,
+TclNRCoroInjectObjCmd(
+ TCL_UNUSED(void *),
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) {
@@ -9013,16 +9951,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(
+ TCL_UNUSED(void *),
+ 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,
+ TCL_UNUSED(int) /*result*/)
+{
+ CoroutineData *corPtr = (CoroutineData *)data[0];
+ Tcl_Obj *listPtr = (Tcl_Obj *)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_NewWideIntObj(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 = (CoroutineData *)data[0];
+ Tcl_Obj *listPtr = (Tcl_Obj *)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(
+ TCL_UNUSED(void *),
+ 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));
@@ -9055,7 +10226,7 @@ TclNRInterpCoroutine(
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"coroutine \"%s\" is already running",
- Tcl_GetString(objv[0])));
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
return TCL_ERROR;
}
@@ -9109,7 +10280,7 @@ TclNRInterpCoroutine(
int
TclNRCoroutineObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -9242,7 +10413,7 @@ TclNRCoroutineObjCmd(
int
TclInfoCoroutineCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -9254,7 +10425,7 @@ TclInfoCoroutineCmd(
return TCL_ERROR;
}
- if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
+ if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
Tcl_Obj *namePtr;
TclNewObj(namePtr);