diff options
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r-- | generic/tclBasic.c | 1757 |
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); |