diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 2598 |
1 files changed, 1341 insertions, 1257 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 254760d..2a334c4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -15,17 +15,13 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclBasic.c,v 1.438 2010/01/03 20:29:11 msofer Exp $ */ #include "tclInt.h" #include "tclOOInt.h" #include "tclCompile.h" -#include <float.h> -#include <limits.h> -#include <math.h> #include "tommath.h" +#include <math.h> #if NRE_ENABLE_ASSERTS #include <assert.h> @@ -85,8 +81,6 @@ TCL_DECLARE_MUTEX(cancelLock) * are used to save the evaluation state between NR calls to each coro. */ -static const CorContext NULL_CONTEXT = {NULL, NULL, NULL, NULL}; - #define SAVE_CONTEXT(context) \ (context).framePtr = iPtr->framePtr; \ (context).varFramePtr = iPtr->varFramePtr; \ @@ -133,14 +127,12 @@ static Tcl_ObjCmdProc ExprSqrtFunc; static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; -static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, - Tcl_Obj *const objv[], int lookup); 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 NRRunObjProc; -static Tcl_NRPostProc NRTailcallEval; +static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); + static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -154,8 +146,8 @@ static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, - Command **cmdPtrPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); + Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, + Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -165,9 +157,24 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; -static Tcl_NRPostProc YieldToCallback; +static Tcl_NRPostProc EvalObjvCore; +static Tcl_NRPostProc Dispatch; + +static Tcl_ObjCmdProc NRCoroInjectObjCmd; +static Tcl_NRPostProc NRPostInvoke; + +MODULE_SCOPE const TclStubs tclStubs; + +/* + * Magical counts for the number of arguments accepted by a coroutine command + * after particular kinds of [yield]. + */ + +#define CORO_ACTIVATE_YIELD PTR2INT(NULL) +#define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1 -MODULE_SCOPE const TclStubs *const tclConstStubsPtr; +#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) +#define COROUTINE_ARGUMENTS_ARBITRARY (-2) /* * The following structure define the commands in the Tcl core. @@ -178,11 +185,16 @@ typedef struct { Tcl_ObjCmdProc *objProc; /* Object-based function for command. */ CompileProc *compileProc; /* Function called to compile command. */ Tcl_ObjCmdProc *nreProc; /* NR-based function for command */ - int isSafe; /* If non-zero, command will be present in - * safe interpreter. Otherwise it will be - * hidden. */ + int flags; /* Various flag bits, as defined below. */ } CmdInfo; +#define CMD_IS_SAFE 1 /* Whether this command is part of the set of + * commands present by default in a safe + * interpreter. */ +/* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle + * expansion for itself rather than needing the generic layer to take care of + * it for it. Defined in tclInt.h. */ + /* * The built-in commands, and the functions that implement them: */ @@ -192,96 +204,95 @@ static const CmdInfo builtInCmds[] = { * Commands in the generic core. */ - {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, 1}, - {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, 1}, - {"array", Tcl_ArrayObjCmd, NULL, NULL, 1}, - {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, 1}, + {"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 - {"case", Tcl_CaseObjCmd, NULL, NULL, 1}, + {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, #endif - {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, 1}, - {"concat", Tcl_ConcatObjCmd, NULL, NULL, 1}, - {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1}, - {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1}, - {"error", Tcl_ErrorObjCmd, NULL, NULL, 1}, - {"eval", Tcl_EvalObjCmd, NULL, NULL, 1}, - {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1}, - {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, - {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, - {"format", Tcl_FormatObjCmd, NULL, NULL, 1}, - {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, - {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, - {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1}, - {"join", Tcl_JoinObjCmd, NULL, NULL, 1}, - {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, 1}, - {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, 1}, - {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, 1}, - {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1}, - {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1}, - {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, - {"lrange", Tcl_LrangeObjCmd, NULL, NULL, 1}, - {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, - {"lreplace", Tcl_LreplaceObjCmd, NULL, NULL, 1}, - {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1}, - {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, - {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, - {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1}, - {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, TclNRNamespaceObjCmd, 1}, - {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, - {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, - {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, - {"regsub", Tcl_RegsubObjCmd, NULL, NULL, 1}, - {"rename", Tcl_RenameObjCmd, NULL, NULL, 1}, - {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1}, - {"scan", Tcl_ScanObjCmd, NULL, NULL, 1}, - {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1}, - {"split", Tcl_SplitObjCmd, NULL, NULL, 1}, - {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1}, - {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1}, - {"tailcall", NULL, NULL, TclNRTailcallObjCmd, 1}, - {"throw", Tcl_ThrowObjCmd, NULL, NULL, 1}, - {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, - {"try", Tcl_TryObjCmd, NULL, TclNRTryObjCmd, 1}, - {"unset", Tcl_UnsetObjCmd, NULL, NULL, 1}, - {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1}, - {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1}, - {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, - {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1}, - {"yield", NULL, NULL, TclNRYieldObjCmd, 1}, + {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, + {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, + {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 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}, + {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, CMD_IS_SAFE}, + {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE}, + {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE}, + {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, 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}, + {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, + {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, + {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, + {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, + {"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}, + {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, 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}, + {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, + {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"package", Tcl_PackageObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, + {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, + {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, CMD_IS_SAFE}, + {"scan", Tcl_ScanObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, CMD_IS_SAFE}, + {"split", Tcl_SplitObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, CMD_IS_SAFE}, + {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, CMD_IS_SAFE}, + {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, CMD_IS_SAFE}, + {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, CMD_IS_SAFE}, + {"trace", Tcl_TraceObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, CMD_IS_SAFE}, + {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, CMD_IS_SAFE}, + {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, CMD_IS_SAFE}, + {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, CMD_IS_SAFE}, + {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, + {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, + {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, + {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE}, /* * Commands in the OS-interface. Note that many of these are unsafe. */ - {"after", Tcl_AfterObjCmd, NULL, NULL, 1}, + {"after", Tcl_AfterObjCmd, NULL, NULL, CMD_IS_SAFE}, {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, - {"close", Tcl_CloseObjCmd, NULL, NULL, 1}, - {"eof", Tcl_EofObjCmd, NULL, NULL, 1}, + {"close", Tcl_CloseObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"eof", Tcl_EofObjCmd, NULL, NULL, CMD_IS_SAFE}, {"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0}, {"exec", Tcl_ExecObjCmd, NULL, NULL, 0}, {"exit", Tcl_ExitObjCmd, NULL, NULL, 0}, - {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1}, + {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, CMD_IS_SAFE}, {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, - {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1}, - {"file", Tcl_FileObjCmd, NULL, NULL, 0}, - {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1}, - {"flush", Tcl_FlushObjCmd, NULL, NULL, 1}, - {"gets", Tcl_GetsObjCmd, NULL, NULL, 1}, + {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"flush", Tcl_FlushObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"gets", Tcl_GetsObjCmd, NULL, NULL, CMD_IS_SAFE}, {"glob", Tcl_GlobObjCmd, NULL, NULL, 0}, {"load", Tcl_LoadObjCmd, NULL, NULL, 0}, {"open", Tcl_OpenObjCmd, NULL, NULL, 0}, - {"pid", Tcl_PidObjCmd, NULL, NULL, 1}, - {"puts", Tcl_PutsObjCmd, NULL, NULL, 1}, + {"pid", Tcl_PidObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"puts", Tcl_PutsObjCmd, NULL, NULL, CMD_IS_SAFE}, {"pwd", Tcl_PwdObjCmd, NULL, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, NULL, 1}, - {"seek", Tcl_SeekObjCmd, NULL, NULL, 1}, + {"read", Tcl_ReadObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"seek", Tcl_SeekObjCmd, NULL, NULL, CMD_IS_SAFE}, {"socket", Tcl_SocketObjCmd, NULL, NULL, 0}, {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, - {"tell", Tcl_TellObjCmd, NULL, NULL, 1}, - {"time", Tcl_TimeObjCmd, NULL, NULL, 1}, + {"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE}, {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, - {"update", Tcl_UpdateObjCmd, NULL, NULL, 1}, - {"vwait", Tcl_VwaitObjCmd, NULL, NULL, 1}, + {"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE}, {NULL, NULL, NULL, NULL, 0} }; @@ -470,10 +481,22 @@ Tcl_CreateInterp(void) * the Tcl_CallFrame structure (or vice versa). */ - if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) { + if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) { + /*NOTREACHED*/ + Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); + } + +#if defined(_WIN32) && !defined(_WIN64) + if (sizeof(time_t) != 4) { + /*NOTREACHED*/ + Tcl_Panic("<time.h> is not compatible with MSVC"); + } + if ((TclOffset(Tcl_StatBuf,st_atime) != 32) + || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) { /*NOTREACHED*/ - Tcl_Panic("Tcl_CallFrame and CallFrame are not the same size"); + Tcl_Panic("<sys/stat.h> is not compatible with MSVC"); } +#endif if (cancelTableInitialized == 0) { Tcl_MutexLock(&cancelLock); @@ -490,7 +513,7 @@ Tcl_CreateInterp(void) * object type table and other object management code. */ - iPtr = (Interp *) ckalloc(sizeof(Interp)); + iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; iPtr->result = iPtr->resultSpace; @@ -503,6 +526,9 @@ Tcl_CreateInterp(void) iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; + TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable)); + iPtr->extra.optimizer = TclOptimizeBytecode; + iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; /* Initialise as soon as :: is available */ @@ -514,10 +540,10 @@ Tcl_CreateInterp(void) */ iPtr->cmdFramePtr = NULL; - iPtr->linePBodyPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineLAPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineLABCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + iPtr->linePBodyPtr = ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineBCPtr = ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineLAPtr = ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS); @@ -530,6 +556,17 @@ Tcl_CreateInterp(void) iPtr->errorInfo = NULL; TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo"); Tcl_IncrRefCount(iPtr->eiVar); + iPtr->errorStack = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(iPtr->errorStack); + iPtr->resetErrorStack = 1; + TclNewLiteralStringObj(iPtr->upLiteral,"UP"); + Tcl_IncrRefCount(iPtr->upLiteral); + TclNewLiteralStringObj(iPtr->callLiteral,"CALL"); + Tcl_IncrRefCount(iPtr->callLiteral); + TclNewLiteralStringObj(iPtr->innerLiteral,"INNER"); + Tcl_IncrRefCount(iPtr->innerLiteral); + iPtr->innerContext = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(iPtr->innerContext); iPtr->errorCode = NULL; TclNewLiteralStringObj(iPtr->ecVar, "::errorCode"); Tcl_IncrRefCount(iPtr->ecVar); @@ -573,6 +610,15 @@ Tcl_CreateInterp(void) iPtr->resultSpace[0] = 0; iPtr->threadId = Tcl_GetCurrentThread(); + /* TIP #378 */ +#ifdef TCL_INTERP_DEBUG_FRAME + iPtr->flags |= INTERP_DEBUG_FRAME; +#else + if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) { + iPtr->flags |= INTERP_DEBUG_FRAME; + } +#endif + /* * Initialise the tables for variable traces and searches *before* * creating the global ns - so that the trace on errorInfo can be @@ -595,7 +641,7 @@ Tcl_CreateInterp(void) */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtr = (CallFrame *) ckalloc(sizeof(CallFrame)); + framePtr = ckalloc(sizeof(CallFrame)); result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { @@ -628,7 +674,7 @@ Tcl_CreateInterp(void) iPtr->asyncCancelMsg = Tcl_NewObj(); - cancelInfo = (CancelInfo *) ckalloc(sizeof(CancelInfo)); + cancelInfo = ckalloc(sizeof(CancelInfo)); cancelInfo->interp = interp; iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo); @@ -637,7 +683,7 @@ Tcl_CreateInterp(void) cancelInfo->length = 0; Tcl_MutexLock(&cancelLock); - hPtr = Tcl_CreateHashEntry(&cancelTable, (char *) iPtr, &isNew); + hPtr = Tcl_CreateHashEntry(&cancelTable, iPtr, &isNew); Tcl_SetHashValue(hPtr, cancelInfo); Tcl_MutexUnlock(&cancelLock); @@ -678,7 +724,7 @@ Tcl_CreateInterp(void) * Initialise the stub table pointer. */ - iPtr->stubTable = tclConstStubsPtr; + iPtr->stubTable = &tclStubs; /* * Initialize the ensemble error message rewriting support. @@ -729,7 +775,7 @@ Tcl_CreateInterp(void) hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdInfoPtr->name, &isNew); if (isNew) { - cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr = ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; cmdPtr->refCount = 1; @@ -742,6 +788,9 @@ Tcl_CreateInterp(void) cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; cmdPtr->flags = 0; + if (cmdInfoPtr->flags & CMD_COMPILES_EXPANDED) { + cmdPtr->flags |= CMD_COMPILES_EXPANDED; + } cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; cmdPtr->nreProc = cmdInfoPtr->nreProc; @@ -750,15 +799,19 @@ Tcl_CreateInterp(void) } /* - * Create the "binary", "chan", "dict", "info" and "string" ensembles. - * Note that all these commands (and their subcommands that are not - * present in the global namespace) are wholly safe. + * Create the "array", "binary", "chan", "dict", "file", "info", + * "namespace" and "string" ensembles. Note that all these commands (and + * their subcommands that are not present in the global namespace) are + * wholly safe *except* for "file". */ + TclInitArrayCmd(interp); TclInitBinaryCmd(interp); TclInitChanCmd(interp); TclInitDictCmd(interp); + TclInitFileCmd(interp); TclInitInfoCmd(interp); + TclInitNamespaceCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); @@ -791,8 +844,14 @@ Tcl_CreateInterp(void) Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); - Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL, - TclNRYieldToObjCmd, NULL, NULL); + /* Adding the bytecode assembler command */ + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, + "::tcl::unsupported::assemble", Tcl_AssembleObjCmd, + TclNRAssembleObjCmd, NULL, NULL); + cmdPtr->compileProc = &TclCompileAssembleCmd; + + Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, + NRCoroInjectObjCmd, NULL, NULL); #ifdef USE_DTRACE /* @@ -810,8 +869,8 @@ Tcl_CreateInterp(void) if (mathfuncNSPtr == NULL) { Tcl_Panic("Can't create math function namespace"); } - strcpy(mathFuncName, "::tcl::mathfunc::"); #define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */ + memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN); for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL; builtinFuncPtr++) { strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name); @@ -825,15 +884,14 @@ Tcl_CreateInterp(void) */ mathopNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL); -#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ if (mathopNSPtr == NULL) { Tcl_Panic("can't create math operator namespace"); } Tcl_Export(interp, mathopNSPtr, "*", 1); - strcpy(mathFuncName, "::tcl::mathop::"); +#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ + memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN); for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){ - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *) - ckalloc(sizeof(TclOpCmdClientData)); + TclOpCmdClientData *occdPtr = ckalloc(sizeof(TclOpCmdClientData)); occdPtr->op = opcmdInfoPtr->name; occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs; @@ -905,15 +963,14 @@ Tcl_CreateInterp(void) * TIP #268: Full patchlevel instead of just major.minor */ - Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, - (ClientData) tclConstStubsPtr); + Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } /* @@ -923,7 +980,7 @@ Tcl_CreateInterp(void) #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } #endif @@ -937,7 +994,7 @@ DeleteOpCmdClientData( { TclOpCmdClientData *occdPtr = clientData; - ckfree((char *) occdPtr); + ckfree(occdPtr); } /* @@ -966,10 +1023,11 @@ TclHideUnsafeCommands( return TCL_ERROR; } for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { - if (!cmdInfoPtr->isSafe) { + if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) { Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } + TclMakeFileCommandSafe(interp); /* Ugh! */ return TCL_OK; } @@ -1007,14 +1065,14 @@ Tcl_CallWhenDeleted( Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; - AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + AssocData *dPtr = ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr); (*assocDataCounterPtr)++; if (iPtr->assocData == NULL) { - iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + iPtr->assocData = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew); @@ -1063,7 +1121,7 @@ Tcl_DontCallWhenDeleted( hPtr = Tcl_NextHashEntry(&hSearch)) { dPtr = Tcl_GetHashValue(hPtr); if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { - ckfree((char *) dPtr); + ckfree(dPtr); Tcl_DeleteHashEntry(hPtr); return; } @@ -1103,14 +1161,14 @@ Tcl_SetAssocData( int isNew; if (iPtr->assocData == NULL) { - iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + iPtr->assocData = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew); if (isNew == 0) { dPtr = Tcl_GetHashValue(hPtr); } else { - dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + dPtr = ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; @@ -1155,7 +1213,7 @@ Tcl_DeleteAssocData( if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - ckfree((char *) dPtr); + ckfree(dPtr); Tcl_DeleteHashEntry(hPtr); } @@ -1310,12 +1368,14 @@ DeleteInterpProc( Tcl_HashSearch search; Tcl_HashTable *hTablePtr; ResolverScheme *resPtr, *nextResPtr; + int i; /* - * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. + * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup, + * unless we are exiting. */ - if (iPtr->numLevels > 0) { + if ((iPtr->numLevels > 0) && !TclInExit()) { Tcl_Panic("DeleteInterpProc called with active evals"); } @@ -1349,9 +1409,9 @@ DeleteInterpProc( if (cancelInfo != NULL) { if (cancelInfo->result != NULL) { - ckfree((char *) cancelInfo->result); + ckfree(cancelInfo->result); } - ckfree((char *) cancelInfo); + ckfree(cancelInfo); } Tcl_DeleteHashEntry(hPtr); @@ -1385,7 +1445,6 @@ DeleteInterpProc( * table, as it will be freed later in this function without further use. */ - TclCleanupLiteralTable(interp, &iPtr->literalTable); TclHandleFree(iPtr->handle); TclTeardownNamespace(iPtr->globalNsPtr); @@ -1407,7 +1466,7 @@ DeleteInterpProc( Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); - ckfree((char *) hTablePtr); + ckfree(hTablePtr); } /* @@ -1428,10 +1487,10 @@ DeleteInterpProc( if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - ckfree((char *) dPtr); + ckfree(dPtr); } Tcl_DeleteHashTable(hTablePtr); - ckfree((char *) hTablePtr); + ckfree(hTablePtr); } /* @@ -1439,11 +1498,11 @@ DeleteInterpProc( * namespace. The order is important [Bug 1658572]. */ - if (iPtr->framePtr != iPtr->rootFramePtr) { + if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) { Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); } Tcl_PopCallFrame(interp); - ckfree((char *) iPtr->rootFramePtr); + ckfree(iPtr->rootFramePtr); iPtr->rootFramePtr = NULL; Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); @@ -1466,6 +1525,12 @@ DeleteInterpProc( Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } + Tcl_DecrRefCount(iPtr->errorStack); + iPtr->errorStack = NULL; + Tcl_DecrRefCount(iPtr->upLiteral); + Tcl_DecrRefCount(iPtr->callLiteral); + Tcl_DecrRefCount(iPtr->innerLiteral); + Tcl_DecrRefCount(iPtr->innerContext); if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } @@ -1480,6 +1545,10 @@ DeleteInterpProc( if (iPtr->execEnvPtr != NULL) { TclDeleteExecEnv(iPtr->execEnvPtr); } + if (iPtr->scriptFile) { + Tcl_DecrRefCount(iPtr->scriptFile); + iPtr->scriptFile = NULL; + } Tcl_DecrRefCount(iPtr->emptyObjPtr); iPtr->emptyObjPtr = NULL; @@ -1487,7 +1556,7 @@ DeleteInterpProc( while (resPtr) { nextResPtr = resPtr->nextPtr; ckfree(resPtr->name); - ckfree((char *) resPtr); + ckfree(resPtr); resPtr = nextResPtr; } @@ -1503,94 +1572,94 @@ DeleteInterpProc( * contents. */ - { - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - int i; - - for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - CmdFrame *cfPtr = Tcl_GetHashValue(hPtr); + for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + CmdFrame *cfPtr = Tcl_GetHashValue(hPtr); + Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr); + procPtr->iPtr = NULL; + if (cfPtr) { if (cfPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfPtr->data.eval.path); } - ckfree((char *) cfPtr->line); - ckfree((char *) cfPtr); - Tcl_DeleteHashEntry(hPtr); + ckfree(cfPtr->line); + ckfree(cfPtr); } - Tcl_DeleteHashTable(iPtr->linePBodyPtr); - ckfree((char *) iPtr->linePBodyPtr); - iPtr->linePBodyPtr = NULL; + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(iPtr->linePBodyPtr); + ckfree(iPtr->linePBodyPtr); + iPtr->linePBodyPtr = NULL; - /* - * See also tclCompile.c, TclCleanupByteCode - */ + /* + * See also tclCompile.c, TclCleanupByteCode + */ - for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - ExtCmdLoc *eclPtr = Tcl_GetHashValue(hPtr); + for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &search); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + ExtCmdLoc *eclPtr = Tcl_GetHashValue(hPtr); - if (eclPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(eclPtr->path); - } - for (i=0; i< eclPtr->nuloc; i++) { - ckfree((char *) eclPtr->loc[i].line); - } + if (eclPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(eclPtr->path); + } + for (i=0; i< eclPtr->nuloc; i++) { + ckfree(eclPtr->loc[i].line); + } - if (eclPtr->loc != NULL) { - ckfree((char *) eclPtr->loc); - } + if (eclPtr->loc != NULL) { + ckfree(eclPtr->loc); + } - Tcl_DeleteHashTable(&eclPtr->litInfo); + ckfree(eclPtr); + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(iPtr->lineBCPtr); + ckfree(iPtr->lineBCPtr); + iPtr->lineBCPtr = NULL; - ckfree((char *) eclPtr); - Tcl_DeleteHashEntry(hPtr); - } - Tcl_DeleteHashTable(iPtr->lineBCPtr); - ckfree((char *) iPtr->lineBCPtr); - iPtr->lineBCPtr = NULL; + /* + * Location stack for uplevel/eval/... scripts which were passed through + * proc arguments. Actually we track all arguments as we do not and cannot + * know which arguments will be used as scripts and which will not. + */ + if (iPtr->lineLAPtr->numEntries && !TclInExit()) { /* - * Location stack for uplevel/eval/... scripts which were passed - * through proc arguments. Actually we track all arguments as we do - * not and cannot know which arguments will be used as scripts and - * which will not. + * When the interp goes away we have nothing on the stack, so there + * are no arguments, so this table has to be empty. */ - if (iPtr->lineLAPtr->numEntries) { - /* - * When the interp goes away we have nothing on the stack, so - * there are no arguments, so this table has to be empty. - */ + Tcl_Panic("Argument location tracking table not empty"); + } - Tcl_Panic("Argument location tracking table not empty"); - } + Tcl_DeleteHashTable(iPtr->lineLAPtr); + ckfree((char *) iPtr->lineLAPtr); + iPtr->lineLAPtr = NULL; - Tcl_DeleteHashTable(iPtr->lineLAPtr); - ckfree((char *) iPtr->lineLAPtr); - iPtr->lineLAPtr = NULL; + if (iPtr->lineLABCPtr->numEntries && !TclInExit()) { + /* + * When the interp goes away we have nothing on the stack, so there + * are no arguments, so this table has to be empty. + */ - if (iPtr->lineLABCPtr->numEntries) { - /* - * When the interp goes away we have nothing on the stack, so - * there are no arguments, so this table has to be empty. - */ + Tcl_Panic("Argument location tracking table not empty"); + } - Tcl_Panic("Argument location tracking table not empty"); - } + Tcl_DeleteHashTable(iPtr->lineLABCPtr); + ckfree(iPtr->lineLABCPtr); + iPtr->lineLABCPtr = NULL; - Tcl_DeleteHashTable(iPtr->lineLABCPtr); - ckfree((char *) iPtr->lineLABCPtr); - iPtr->lineLABCPtr = NULL; - } + /* + * Squelch the tables of traces on variables and searches over arrays in + * the in the interpreter. + */ Tcl_DeleteHashTable(&iPtr->varTraces); Tcl_DeleteHashTable(&iPtr->varSearches); - ckfree((char *) iPtr); + ckfree(iPtr); } /* @@ -1656,9 +1725,10 @@ Tcl_HideCommand( */ if (strstr(hiddenCmdToken, "::") != NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use namespace qualifiers in hidden command" - " token (rename)", NULL); + " token (rename)", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL); return TCL_ERROR; } @@ -1680,8 +1750,10 @@ Tcl_HideCommand( */ if (cmdPtr->nsPtr != iPtr->globalNsPtr) { - Tcl_AppendResult(interp, "can only hide global namespace commands" - " (use rename then hide)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only hide global namespace commands (use rename then hide)", + -1)); + Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL); return TCL_ERROR; } @@ -1691,8 +1763,7 @@ Tcl_HideCommand( hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr == NULL) { - hiddenCmdTablePtr = (Tcl_HashTable *) - ckalloc((unsigned) sizeof(Tcl_HashTable)); + hiddenCmdTablePtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } @@ -1705,8 +1776,10 @@ Tcl_HideCommand( hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew); if (!isNew) { - Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken, - "\" already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "hidden command named \"%s\" already exists", + hiddenCmdToken)); + Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL); return TCL_ERROR; } @@ -1807,8 +1880,10 @@ Tcl_ExposeCommand( */ if (strstr(cmdName, "::") != NULL) { - Tcl_AppendResult(interp, "cannot expose to a namespace " - "(use expose to toplevel, then rename)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot expose to a namespace (use expose to toplevel, then rename)", + -1)); + Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL); return TCL_ERROR; } @@ -1822,8 +1897,10 @@ Tcl_ExposeCommand( hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); } if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown hidden command \"%s\"", hiddenCmdToken)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", + hiddenCmdToken, NULL); return TCL_ERROR; } cmdPtr = Tcl_GetHashValue(hPtr); @@ -1840,9 +1917,9 @@ Tcl_ExposeCommand( * than 'nicely' erroring out ? */ - Tcl_AppendResult(interp, - "trying to expose a non global command name space command", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "trying to expose a non-global command namespace command", + -1)); return TCL_ERROR; } @@ -1859,12 +1936,24 @@ Tcl_ExposeCommand( hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); if (!isNew) { - Tcl_AppendResult(interp, "exposed command \"", cmdName, - "\" already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "exposed command \"%s\" already exists", cmdName)); + Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL); return TCL_ERROR; } /* + * Command resolvers (per-interp, per-namespace) might have resolved to a + * command for the given namespace scope with this command not being + * registered with the namespace's command table. During BC compilation, + * the so-resolved command turns into a CmdName literal. Without + * invalidating a possible CmdName literal here explicitly, such literals + * keep being reused while pointing to overhauled commands. + */ + + TclInvalidateCmdLiteral(interp, cmdName, nsPtr); + + /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. @@ -1996,10 +2085,19 @@ Tcl_CreateCommand( */ cmdPtr = Tcl_GetHashValue(hPtr); - oldRefPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = NULL; + cmdPtr->refCount++; + if (cmdPtr->importRefPtr) { + cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; + } Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + } + TclCleanupCommandMacro(cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); if (!isNew) { /* @@ -2012,6 +2110,18 @@ Tcl_CreateCommand( } } else { /* + * Command resolvers (per-interp, per-namespace) might have resolved + * to a command for the given namespace scope with this command not + * being registered with the namespace's command table. During BC + * compilation, the so-resolved command turns into a CmdName literal. + * Without invalidating a possible CmdName literal here explicitly, + * such literals keep being reused while pointing to overhauled + * commands. + */ + + TclInvalidateCmdLiteral(interp, tail, nsPtr); + + /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. @@ -2020,7 +2130,7 @@ Tcl_CreateCommand( TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr = ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -2076,12 +2186,9 @@ Tcl_CreateCommand( * future calls to Tcl_GetCommandName. * * Side effects: - * If no command named "cmdName" already exists for interp, one is - * created. Otherwise, if a command does exist, then if the object-based - * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand - * was called previously for the same command and just set its - * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old - * command. + * If a command named "cmdName" already exists for interp, it is + * first deleted. Then the new command is created from the arguments. + * [***] (See below for exception). * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based @@ -2148,17 +2255,22 @@ Tcl_CreateObjCommand( if (!isNew) { cmdPtr = Tcl_GetHashValue(hPtr); + /* Command already exists. */ + /* - * Command already exists. If its object-based Tcl_ObjCmdProc is - * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the - * argument "proc". Otherwise, we delete the old command. + * [***] This is wrong. See Tcl Bug a16752c252. + * However, this buggy behavior is kept under particular + * circumstances to accommodate deployed binaries of the + * "tclcompiler" program. http://sourceforge.net/projects/tclpro/ + * that crash if the bug is fixed. */ - if (cmdPtr->objProc == TclInvokeStringCommand) { + if (cmdPtr->objProc == TclInvokeStringCommand + && cmdPtr->clientData == clientData + && cmdPtr->deleteData == clientData + && cmdPtr->deleteProc == deleteProc) { cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; - cmdPtr->deleteProc = deleteProc; - cmdPtr->deleteData = clientData; return (Tcl_Command) cmdPtr; } @@ -2169,10 +2281,19 @@ Tcl_CreateObjCommand( * intact. */ - oldRefPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = NULL; + cmdPtr->refCount++; + if (cmdPtr->importRefPtr) { + cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; + } Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + } + TclCleanupCommandMacro(cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); if (!isNew) { /* @@ -2185,6 +2306,18 @@ Tcl_CreateObjCommand( } } else { /* + * Command resolvers (per-interp, per-namespace) might have resolved + * to a command for the given namespace scope with this command not + * being registered with the namespace's command table. During BC + * compilation, the so-resolved command turns into a CmdName literal. + * Without invalidating a possible CmdName literal here explicitly, + * such literals keep being reused while pointing to overhauled + * commands. + */ + + TclInvalidateCmdLiteral(interp, tail, nsPtr); + + /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. @@ -2192,7 +2325,7 @@ Tcl_CreateObjCommand( TclInvalidateNsCmdLookup(nsPtr); } - cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr = ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -2280,7 +2413,7 @@ TclInvokeStringCommand( result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv); - TclStackFree(interp, (char **)argv); + TclStackFree(interp, (void *) argv); return result; } @@ -2299,8 +2432,8 @@ TclInvokeStringCommand( * A standard Tcl string result value. * * Side effects: - * Besides those side effects of the called Tcl_CmdProc, - * TclInvokeStringCommand allocates and frees storage. + * Besides those side effects of the called Tcl_ObjCmdProc, + * TclInvokeObjectCommand allocates and frees storage. * *---------------------------------------------------------------------- */ @@ -2404,9 +2537,11 @@ TclRenameCommand( cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "can't ", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't %s \"%s\": command doesn't exist", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", - " \"", oldName, "\": command doesn't exist", NULL); + oldName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); return TCL_ERROR; } cmdNsPtr = cmdPtr->nsPtr; @@ -2435,14 +2570,17 @@ TclRenameCommand( TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); if ((newNsPtr == NULL) || (newTail == NULL)) { - Tcl_AppendResult(interp, "can't rename to \"", newName, - "\": bad command name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't rename to \"%s\": bad command name", newName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); result = TCL_ERROR; goto done; } if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { - Tcl_AppendResult(interp, "can't rename to \"", newName, - "\": command already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't rename to \"%s\": command already exists", newName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME", + "TARGET_EXISTS", NULL); result = TCL_ERROR; goto done; } @@ -2490,6 +2628,17 @@ TclRenameCommand( TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* + * Command resolvers (per-interp, per-namespace) might have resolved to a + * command for the given namespace scope with this command not being + * registered with the namespace's command table. During BC compilation, + * the so-resolved command turns into a CmdName literal. Without + * invalidating a possible CmdName literal here explicitly, such literals + * keep being reused while pointing to overhauled commands. + */ + + TclInvalidateCmdLiteral(interp, newTail, cmdPtr->nsPtr); + + /* * Script for rename traces can delete the command "oldName". Therefore * increment the reference count for cmdPtr so that it's Command structure * is freed only towards the end of this function by calling @@ -2504,7 +2653,7 @@ TclRenameCommand( Tcl_DStringInit(&newFullName); Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1); if (newNsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&newFullName, "::", 2); + TclDStringAppendLiteral(&newFullName, "::"); } Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; @@ -2932,8 +3081,9 @@ Tcl_DeleteCommandFromToken( tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; + if ((--tracePtr->refCount) <= 0) { - ckfree((char *) tracePtr); + ckfree(tracePtr); } tracePtr = nextPtr; } @@ -2985,12 +3135,13 @@ Tcl_DeleteCommandFromToken( * commands were created that refer back to this command. Delete these * imported commands now. */ - - for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; - refPtr = nextRefPtr) { - nextRefPtr = refPtr->nextPtr; - importCmd = (Tcl_Command) refPtr->importedCmdPtr; - Tcl_DeleteCommandFromToken(interp, importCmd); + if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) { + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; + refPtr = nextRefPtr) { + nextRefPtr = refPtr->nextPtr; + importCmd = (Tcl_Command) refPtr->importedCmdPtr; + Tcl_DeleteCommandFromToken(interp, importCmd); + } } /* @@ -3019,8 +3170,8 @@ Tcl_DeleteCommandFromToken( * from a CmdName Tcl object in some ByteCode code sequence. In that case, * delay the cleanup until all references are either discarded (when a * ByteCode is freed) or replaced by a new reference (when a cached - * CmdName Command reference is found to be invalid and TclExecuteByteCode - * looks up the command in the command hashtable). + * CmdName Command reference is found to be invalid and + * TclNRExecuteByteCode looks up the command in the command hashtable). */ TclCleanupCommandMacro(cmdPtr); @@ -3118,7 +3269,7 @@ CallCommandTraces( oldName, newName, flags); cmdPtr->flags &= ~tracePtr->flags; if ((--tracePtr->refCount) <= 0) { - ckfree((char *) tracePtr); + ckfree(tracePtr); } } @@ -3181,28 +3332,29 @@ CancelEvalProc( if (iPtr != NULL) { /* - * Setting this flag will cause the script in progress to be - * canceled as soon as possible. The core honors this flag at all - * the necessary places to ensure script cancellation is + * Setting the CANCELED flag will cause the script in progress to + * be canceled as soon as possible. The core honors this flag at + * all the necessary places to ensure script cancellation is * responsive. Extensions can check for this flag by calling * Tcl_Canceled and checking if TCL_ERROR is returned or they can * choose to ignore the script cancellation flag and the - * associated functionality altogether. + * associated functionality altogether. Currently, the only other + * flag we care about here is the TCL_CANCEL_UNWIND flag (from + * Tcl_CancelEval). We do not want to simply combine all the flags + * from original Tcl_CancelEval call with the interp flags here + * just in case the caller passed flags that might cause behaviour + * unrelated to script cancellation. */ - iPtr->flags |= CANCELED; + TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* - * Currently, we only care about the TCL_CANCEL_UNWIND flag from - * Tcl_CancelEval. We do not want to simply combine all the flags - * from original Tcl_CancelEval call with the interp flags here - * just in case the caller passed flags that might cause behaviour - * unrelated to script cancellation. + * Now, we must set the script cancellation flags on all the slave + * interpreters belonging to this one. */ - if (cancelInfo->flags & TCL_CANCEL_UNWIND) { - iPtr->flags |= TCL_CANCEL_UNWIND; - } + TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, + cancelInfo->flags | CANCELED, 0); /* * Create the result object now so that Tcl_Canceled can avoid @@ -3225,66 +3377,6 @@ CancelEvalProc( /* *---------------------------------------------------------------------- * - * GetCommandSource -- - * - * This function returns a Tcl_Obj with the full source string for the - * command. This insures that traces get a correct NUL-terminated command - * string. The Tcl_Obj has refCount==1. - * - * *** MAINTAINER WARNING *** - * The returned Tcl_Obj is all wrong for any purpose but getting the - * source string for an objc/objv command line in the stringRep (no - * stringRep if no source is available) and the corresponding substituted - * version in the List intrep. - * This means that the intRep and stringRep DO NOT COINCIDE! Using these - * Tcl_Objs normally is likely to break things. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -GetCommandSource( - Interp *iPtr, - int objc, - Tcl_Obj *const objv[], - int lookup) -{ - Tcl_Obj *objPtr, *obj2Ptr; - CmdFrame *cfPtr = iPtr->cmdFramePtr; - const char *command = NULL; - int numChars; - - objPtr = Tcl_NewListObj(objc, objv); - if (lookup && cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) { - switch (cfPtr->type) { - case TCL_LOCATION_EVAL: - case TCL_LOCATION_SOURCE: - command = cfPtr->cmd.str.cmd; - numChars = cfPtr->cmd.str.len; - break; - case TCL_LOCATION_BC: - case TCL_LOCATION_PREBC: - command = TclGetSrcInfoForCmd(iPtr, &numChars); - break; - case TCL_LOCATION_EVAL_LIST: - /* Got it already */ - break; - } - if (command) { - obj2Ptr = Tcl_NewStringObj(command, numChars); - objPtr->bytes = obj2Ptr->bytes; - objPtr->length = numChars; - obj2Ptr->bytes = NULL; - Tcl_DecrRefCount(obj2Ptr); - } - } - Tcl_IncrRefCount(objPtr); - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * * TclCleanupCommand -- * * This function frees up a Command structure unless it is still @@ -3310,7 +3402,7 @@ TclCleanupCommand( { cmdPtr->refCount--; if (cmdPtr->refCount <= 0) { - ckfree((char *) cmdPtr); + ckfree(cmdPtr); } } @@ -3351,18 +3443,16 @@ Tcl_CreateMathFunc( * function. */ { Tcl_DString bigName; - OldMathFuncData *data = (OldMathFuncData *) - ckalloc(sizeof(OldMathFuncData)); + OldMathFuncData *data = ckalloc(sizeof(OldMathFuncData)); data->proc = proc; data->numArgs = numArgs; - data->argTypes = (Tcl_ValueType *) - ckalloc(numArgs * sizeof(Tcl_ValueType)); + data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType)); memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); data->clientData = clientData; Tcl_DStringInit(&bigName); - Tcl_DStringAppend(&bigName, "::tcl::mathfunc::", -1); + TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::"); Tcl_DStringAppend(&bigName, name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName), @@ -3414,7 +3504,7 @@ OldMathFuncProc( * Convert arguments from Tcl_Obj's to Tcl_Value's. */ - args = (Tcl_Value *) ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); + args = ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); for (j = 1, k = 0; j < objc; ++j, ++k) { /* TODO: Convert to TclGetNumberFromObj? */ valuePtr = objv[j]; @@ -3430,11 +3520,11 @@ OldMathFuncProc( * We have a non-numeric argument. */ - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", - TCL_STATIC); + -1)); TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); - ckfree((char *) args); + ckfree(args); return TCL_ERROR; } @@ -3466,7 +3556,7 @@ OldMathFuncProc( break; case TCL_INT: if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { - ckfree((char *) args); + ckfree(args); return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); @@ -3475,7 +3565,7 @@ OldMathFuncProc( break; case TCL_WIDE_INT: if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { - ckfree((char *) args); + ckfree(args); return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); @@ -3491,7 +3581,7 @@ OldMathFuncProc( errno = 0; result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult); - ckfree((char *) args); + ckfree(args); if (result != TCL_OK) { return result; } @@ -3534,8 +3624,8 @@ OldMathFuncDeleteProc( { OldMathFuncData *dataPtr = clientData; - ckfree((char *) dataPtr->argTypes); - ckfree((char *) dataPtr); + ckfree(dataPtr->argTypes); + ckfree(dataPtr); } /* @@ -3589,12 +3679,8 @@ Tcl_GetMathFuncInfo( */ if (cmdPtr == NULL) { - Tcl_Obj *message; - - TclNewLiteralStringObj(message, "unknown math function \""); - Tcl_AppendToObj(message, name, -1); - Tcl_AppendToObj(message, "\"", 1); - Tcl_SetObjResult(interp, message); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown math function \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL); *numArgsPtr = -1; *argTypesPtr = NULL; @@ -3649,41 +3735,28 @@ Tcl_ListMathFuncs( Tcl_Interp *interp, const char *pattern) { - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - Namespace *nsPtr; - Namespace *dummy1NsPtr; - Namespace *dummy2NsPtr; - const char *dummyNamePtr; - Tcl_Obj *result = Tcl_NewObj(); - - TclGetNamespaceForQualName(interp, "::tcl::mathfunc", - globalNsPtr, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY, - &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &dummyNamePtr); - if (nsPtr == NULL) { - return result; + Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1); + Tcl_Obj *result; + Tcl_InterpState state; + + if (pattern) { + Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); + Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj); + + Tcl_AppendObjToObj(script, arg); + Tcl_DecrRefCount(arg); /* Should tear down patternObj too */ } - if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - if (Tcl_FindHashEntry(&nsPtr->cmdTable, pattern) != NULL) { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(pattern, -1)); - } + state = Tcl_SaveInterpState(interp, TCL_OK); + Tcl_IncrRefCount(script); + if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { + result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); } else { - Tcl_HashSearch cmdHashSearch; - Tcl_HashEntry *cmdHashEntry = - Tcl_FirstHashEntry(&nsPtr->cmdTable,&cmdHashSearch); - - for (; cmdHashEntry != NULL; - cmdHashEntry = Tcl_NextHashEntry(&cmdHashSearch)) { - const char *cmdNamePtr = - Tcl_GetHashKey(&nsPtr->cmdTable, cmdHashEntry); - - if (pattern == NULL || Tcl_StringMatch(cmdNamePtr, pattern)) { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(cmdNamePtr, -1)); - } - } + result = Tcl_NewObj(); } + Tcl_DecrRefCount(script); + Tcl_RestoreInterpState(interp, state); + return result; } @@ -3723,15 +3796,22 @@ TclInterpReady( */ if (iPtr->flags & DELETED) { - /* JJM - Superfluous Tcl_ResetResult call removed. */ - Tcl_AppendResult(interp, - "attempt to call eval in deleted interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to call eval in deleted interpreter", -1)); Tcl_SetErrorCode(interp, "TCL", "IDELETE", "attempt to call eval in deleted interpreter", NULL); return TCL_ERROR; } - if (iPtr->execEnvPtr->rewind || + if (iPtr->execEnvPtr->rewind) { + return TCL_ERROR; + } + + /* + * Make sure the script being evaluated (if any) has not been canceled. + */ + + if (TclCanceled(iPtr) && (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } @@ -3745,8 +3825,9 @@ TclInterpReady( return TCL_OK; } - Tcl_AppendResult(interp, - "too many nested evaluations (infinite loop?)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "too many nested evaluations (infinite loop?)", -1)); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL); return TCL_ERROR; } @@ -3780,7 +3861,7 @@ TclResetCancellation( } if (force || (iPtr->numLevels == 0)) { - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); } return TCL_OK; } @@ -3818,105 +3899,78 @@ Tcl_Canceled( register Interp *iPtr = (Interp *) interp; /* - * Traverse up the to the top-level interp, checking for the CANCELED flag - * along the way. If any of the intervening interps have the CANCELED flag - * set, the current script in progress is considered to be canceled and we - * stop checking. Otherwise, if any interp has the DELETED flag set we - * stop checking. + * Has the current script in progress for this interpreter been canceled + * or is the stack being unwound due to the previous script cancellation? */ - for (; iPtr!=NULL; iPtr = (Interp *) Tcl_GetMaster((Tcl_Interp *) iPtr)) { - /* - * Has the current script in progress for this interpreter been - * canceled or is the stack being unwound due to the previous script - * cancellation? - */ - - if ((iPtr->flags & CANCELED) || (iPtr->flags & TCL_CANCEL_UNWIND)) { - /* - * The CANCELED flag is a one-shot flag that is reset immediately - * upon being detected; however, if the TCL_CANCEL_UNWIND flag is - * set we will continue to report that the script in progress has - * been canceled thereby allowing the evaluation stack for the - * interp to be fully unwound. - */ - - iPtr->flags &= ~CANCELED; + if (!TclCanceled(iPtr)) { + return TCL_OK; + } - /* - * The CANCELED flag was detected and reset; however, if the - * caller specified the TCL_CANCEL_UNWIND flag, we only return - * TCL_ERROR (indicating that the script in progress has been - * canceled) if the evaluation stack for the interp is being fully - * unwound. - */ + /* + * The CANCELED flag is a one-shot flag that is reset immediately upon + * being detected; however, if the TCL_CANCEL_UNWIND flag is set we will + * continue to report that the script in progress has been canceled + * thereby allowing the evaluation stack for the interp to be fully + * unwound. + */ - if (!(flags & TCL_CANCEL_UNWIND) - || (iPtr->flags & TCL_CANCEL_UNWIND)) { - /* - * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error - * in the interp's result; otherwise, we leave it alone. - */ + iPtr->flags &= ~CANCELED; - if (flags & TCL_LEAVE_ERR_MSG) { - const char *id, *message = NULL; - int length; + /* + * The CANCELED flag was detected and reset; however, if the caller + * specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR + * (indicating that the script in progress has been canceled) if the + * evaluation stack for the interp is being fully unwound. + */ - /* - * Setup errorCode variables so that we can differentiate - * between being canceled and unwound. - */ + if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) { + return TCL_OK; + } - if (iPtr->asyncCancelMsg != NULL) { - message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, - &length); - } else { - length = 0; - } + /* + * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the + * interp's result; otherwise, we leave it alone. + */ - if (iPtr->flags & TCL_CANCEL_UNWIND) { - id = "IUNWIND"; - if (length == 0) { - message = "eval unwound"; - } - } else { - id = "ICANCEL"; - if (length == 0) { - message = "eval canceled"; - } - } + if (flags & TCL_LEAVE_ERR_MSG) { + const char *id, *message = NULL; + int length; - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, message, NULL); - Tcl_SetErrorCode(interp, "TCL", id, message, NULL); - } + /* + * Setup errorCode variables so that we can differentiate between + * being canceled and unwound. + */ - /* - * Return TCL_ERROR to the caller (not necessarily just the - * Tcl core itself) that indicates further processing of the - * script or command in progress should halt gracefully and as - * soon as possible. - */ + if (iPtr->asyncCancelMsg != NULL) { + message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); + } else { + length = 0; + } - return TCL_ERROR; - } - } else { - /* - * FIXME: If this interpreter is being deleted we cannot continue - * to traverse up the interp chain due to an issue with - * Tcl_GetMaster (really the slave interp bookkeeping) that causes - * us to run off into a freed interp struct. Ideally, this check - * would not be necessary because Tcl_GetMaster would return NULL - * instead of a pointer to invalid (freed) memory. - */ + if (iPtr->flags & TCL_CANCEL_UNWIND) { + id = "IUNWIND"; + if (length == 0) { + message = "eval unwound"; + } + } else { + id = "ICANCEL"; + if (length == 0) { + message = "eval canceled"; + } + } - if (iPtr->flags & DELETED) { - break; - } - } + Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1)); + Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL); } - return TCL_OK; + /* + * Return TCL_ERROR to the caller (not necessarily just the Tcl core + * itself) that indicates further processing of the script or command in + * progress should halt gracefully and as soon as possible. + */ + + return TCL_ERROR; } /* @@ -4061,10 +4115,10 @@ Tcl_EvalObjv( * TCL_EVAL_NOERR are currently supported. */ { int result; - TEOV_callback *rootPtr = TOP_CB(interp); + NRE_callback *rootPtr = TOP_CB(interp); result = TclNREvalObjv(interp, objc, objv, flags, NULL); - return TclNRRunCallbacks(interp, result, rootPtr, 0); + return TclNRRunCallbacks(interp, result, rootPtr); } int @@ -4083,45 +4137,39 @@ TclNREvalObjv( * requested Command struct to be invoked. */ { Interp *iPtr = (Interp *) interp; - int result; - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Tcl_ObjCmdProc *objProc; - ClientData objClientData; - Command **cmdPtrPtr; - - iPtr->lookupNsPtr = NULL; /* - * Push a callback with cleanup tasks for commands; the cmdPtr at data[0] - * will be filled later when the command is found: save its address at - * objProcPtr. - * * data[1] stores a marker for use by tailcalls; it will be set to 1 by * command redirectors (imports, alias, ensembles) so that tailcalls * finishes the source command and not just the target. */ - if (iPtr->evalFlags & TCL_EVAL_REDIRECT) { - TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), NULL, NULL); - iPtr->evalFlags &= ~TCL_EVAL_REDIRECT; + if (iPtr->deferredCallbacks) { + iPtr->deferredCallbacks = NULL; } else { TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); } - cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]); - - TclNRSpliceDeferred(interp); iPtr->numLevels++; - result = TclInterpReady(interp); - - if ((result != TCL_OK) || (objc == 0)) { - return result; - } - - if (cmdPtr) { - goto commandFound; - } + TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), + INT2PTR(objc), objv); + return TCL_OK; +} +static int +EvalObjvCore( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = NULL, *preCmdPtr = data[0]; + int flags = PTR2INT(data[1]); + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = NULL; + int enterTracesDone = 0; + /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4131,61 +4179,152 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } + if (TCL_OK != TclInterpReady(interp)) { + return TCL_ERROR; + } + + if (objc == 0) { + return TCL_OK; + } + + if (TclLimitExceeded(iPtr->limit)) { + return TCL_ERROR; + } + /* * Configure evaluation context to match the requested flags. */ - if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { - if (!lookupNsPtr) { - lookupNsPtr = iPtr->globalNsPtr; - } + if (iPtr->lookupNsPtr) { + + /* + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + * + * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. + * TODO: Is that a bug? + */ + + lookupNsPtr = iPtr->lookupNsPtr; + iPtr->lookupNsPtr = NULL; + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; } else { - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } /* * TCL_EVAL_INVOKE was not set: clear rewrite rules */ iPtr->ensembleRewrite.sourceObjs = NULL; + + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } } /* - * Lookup the command + * Lookup the Command to dispatch. */ - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + reresolve: + assert(cmdPtr == NULL); + if (preCmdPtr) { + /* Caller gave it to us */ + if (!(preCmdPtr->flags & CMD_IS_DELETED)) { + /* So long as it exists, use it. */ + cmdPtr = preCmdPtr; + } else if (flags & TCL_EVAL_NORESOLVE) { + /* + * When it's been deleted, and we're told not to attempt + * resolving it ourselves, all we can do is raise an error. + */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to invoke a deleted command")); + Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); + return TCL_ERROR; + } } - - iPtr->cmdCount++; - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; + if (cmdPtr == NULL) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } } - /* - * Found a command! The real work begins now ... - */ + if (enterTracesDone || iPtr->tracePtr + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - commandFound: - if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - /* - * Call enter traces. They will schedule a call to the leave traces if - * necessary. - */ + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); + Tcl_IncrRefCount(commandPtr); - result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); - } - if (result != TCL_OK) { - return result; + if (!enterTracesDone) { + + int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, + objc, objv); + + /* + * Send any exception from enter traces back as an exception + * raised by the traced command. + * TODO: Is this a bug? Letting an execution trace BREAK or + * CONTINUE or RETURN in the place of the traced command? + * Would either converting all exceptions to TCL_ERROR, or + * just swallowing them be better? (Swallowing them has the + * problem of permanently hiding program errors.) + */ + + if (code != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return code; + } + + /* + * If the enter traces made the resolved cmdPtr unusable, go + * back and resolve again, but next time don't run enter + * traces again. + */ + + if (cmdPtr == NULL) { + enterTracesDone = 1; + Tcl_DecrRefCount(commandPtr); + goto reresolve; + } } + + /* + * Schedule leave traces. Raise the refCount on the resolved + * cmdPtr, so that when it passes to the leave traces we know + * it's still valid. + */ + + cmdPtr->refCount++; + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); } + TclNRAddCallback(interp, Dispatch, + cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, + cmdPtr->objClientData, INT2PTR(objc), objv); + return TCL_OK; +} + +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_ObjCmdProc *objProc = data[0]; + ClientData clientData = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; + +#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; @@ -4204,58 +4343,30 @@ TclNREvalObjv( TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } - if (TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) { + if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) + && objc) { TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); } - if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { + if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, (Tcl_Obj **)(objv + 1)); } +#endif /* USE_DTRACE */ - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - - /* - * Find the objProc to call: nreProc if available, objProc otherwise. Push - * a callback to do the actual running. - */ - - objProc = cmdPtr->nreProc; - if (!objProc) { - objProc = cmdPtr->objProc; - } - objClientData = cmdPtr->objClientData; - - TclNRAddCallback(interp, NRRunObjProc, objProc, objClientData, - INT2PTR(objc), (ClientData) objv); - return TCL_OK; -} - -void -TclPushTailcallPoint( - Tcl_Interp *interp) -{ - TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - ((Interp *) interp)->numLevels++; + iPtr->cmdCount++; + return objProc(clientData, interp, objc, objv); } int TclNRRunCallbacks( Tcl_Interp *interp, int result, - struct TEOV_callback *rootPtr, + struct NRE_callback *rootPtr) /* All callbacks down to rootPtr not inclusive * are to be run. */ - int tebcCall) /* Normal callers set this to 0; only TEBC - * sets it to 1. */ { Interp *iPtr = (Interp *) interp; - TEOV_callback *callbackPtr; + NRE_callback *callbackPtr; Tcl_NRPostProc *procPtr; /* @@ -4274,23 +4385,7 @@ TclNRRunCallbacks( while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); - procPtr = callbackPtr->procPtr; - - if (tebcCall && (procPtr == NRCallTEBC)) { - NRE_ASSERT(result==TCL_OK); - return TCL_OK; - } - - /* - * IMPLEMENTATION REMARKS (FIXME) - * - * Add here other direct handling possibilities for optimisation? One - * could handle the very frequent NRCommand and NRRunObjProc right - * here to save an indirect function call and improve icache - * management. Would it? Test it, time it ... - */ - TOP_CB(interp) = callbackPtr->nextPtr; result = procPtr(callbackPtr->data, interp, result); TCLNR_FREE(interp, callbackPtr); @@ -4298,20 +4393,23 @@ TclNRRunCallbacks( return result; } -int +static int NRCommand( ClientData data[], Tcl_Interp *interp, int result) { Interp *iPtr = (Interp *) interp; - Command *cmdPtr = data[0]; - /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */ - if (cmdPtr) { - TclCleanupCommandMacro(cmdPtr); + iPtr->numLevels--; + + /* + * If there is a tailcall, schedule it + */ + + if (data[1] && (data[1] != INT2PTR(1))) { + TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL); } - ((Interp *)interp)->numLevels--; /* OPT ?? * Do not interrupt a series of cleanups with async or limit checks: @@ -4321,7 +4419,7 @@ NRCommand( if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); } - if (result == TCL_OK) { + if ((result == TCL_OK) && TclCanceled(iPtr)) { result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG); } if (result == TCL_OK && TclLimitReady(iPtr->limit)) { @@ -4330,68 +4428,6 @@ NRCommand( return result; } - -static int -NRRunObjProc( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* OPT: do not call? */ - - Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0]; - ClientData objClientData = data[1]; - int objc = PTR2INT(data[2]); - Tcl_Obj **objv = data[3]; - - if (result == TCL_OK) { - return objProc(objClientData, interp, objc, objv); - } - return result; -} - -int -NRCallTEBC( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* - * This is not run normally, the callback is passed up to tebc. This - * function is only called when no tebc is above. - */ - - int type = PTR2INT(data[0]); - Interp *iPtr = ((Interp *) interp); - - NRE_ASSERT(result == TCL_OK); - - switch (type) { - case TCL_NR_BC_TYPE: - return TclExecuteByteCode(interp, data[1]); - case TCL_NR_TAILCALL_TYPE: - /* For tailcalls */ - Tcl_SetResult(interp, - "tailcall can only be called from a proc or lambda", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); - return TCL_ERROR; - case TCL_NR_YIELD_TYPE: - if (iPtr->execEnvPtr->corPtr) { - Tcl_SetResult(interp, "cannot yield: C stack busy", TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", NULL); - } else { - Tcl_SetResult(interp, "yield can only be called in a coroutine", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - NULL); - } - return TCL_ERROR; - default: - Tcl_Panic("unknown call type to TEBC"); - } - return result; /* not reached */ -} /* *---------------------------------------------------------------------- @@ -4492,7 +4528,7 @@ TEOV_Exception( * here directly. */ - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); return result; } @@ -4595,10 +4631,14 @@ TEOV_NotFound( cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr); if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[0]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(objv[0]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", + TclGetString(objv[0]), NULL); + /* - * Release any resources we locked and allocated during the handler call. + * Release any resources we locked and allocated during the handler + * call. */ for (i = 0; i < handlerObjc; ++i) { @@ -4612,9 +4652,9 @@ TEOV_NotFound( savedNsPtr = varFramePtr->nsPtr; varFramePtr->nsPtr = lookupNsPtr; } - TclNRDeferCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc), + TclSkipTailcall(interp); + TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc), newObjv, savedNsPtr, NULL); - iPtr->evalFlags |= TCL_EVAL_REDIRECT; return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL); } @@ -4651,27 +4691,21 @@ static int TEOV_RunEnterTraces( Tcl_Interp *interp, Command **cmdPtrPtr, + Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr) + Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length; - Tcl_Obj *commandPtr; - - commandPtr = GetCommandSource(iPtr, objc, objv, 1); - command = Tcl_GetStringFromObj(commandPtr, &length); + int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int length, traceCode = TCL_OK; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); /* * Call trace functions. * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. */ cmdPtr->refCount++; @@ -4686,29 +4720,22 @@ TEOV_RunEnterTraces( newEpoch = cmdPtr->cmdEpoch; TclCleanupCommandMacro(cmdPtr); - /* - * If the traces modified/deleted the command or any existing traces, they - * will update the command's epoch. We need to lookup again, but do not - * run enter traces on the newly found cmdPtr. - */ - - if (cmdEpoch != newEpoch) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - *cmdPtrPtr = cmdPtr; + if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (enter trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + return traceCode; } - - if (cmdPtr) { - /* - * Command was found: push a record to schedule the leave traces. - */ - - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode), - commandPtr, cmdPtr, NULL); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); + if (cmdEpoch != newEpoch) { + *cmdPtrPtr = NULL; } - return traceCode; + return TCL_OK; } static int @@ -4718,20 +4745,16 @@ TEOV_RunLeaveTraces( int result) { Interp *iPtr = (Interp *) interp; - const char *command; - int length, objc; - Tcl_Obj **objv; - int traceCode = PTR2INT(data[0]); + int traceCode = TCL_OK; + int objc = PTR2INT(data[0]); Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; - - command = Tcl_GetStringFromObj(commandPtr, &length); - if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) { - Tcl_Panic("Who messed with commandPtr?"); - } + Tcl_Obj **objv = data[3]; + int length; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } @@ -4740,7 +4763,6 @@ TEOV_RunLeaveTraces( cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } } - Tcl_DecrRefCount(commandPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. @@ -4751,8 +4773,18 @@ TEOV_RunLeaveTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { - return traceCode; + if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (leave trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + result = traceCode; } + Tcl_DecrRefCount(commandPtr); return result; } @@ -4768,7 +4800,6 @@ TEOV_LookupCmdFromObj( if (lookupNsPtr) { iPtr->varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); iPtr->varFramePtr->nsPtr = savedNsPtr; @@ -4907,7 +4938,7 @@ TclEvalEx( int line, /* The line the script starts on. */ int *clNextOuter, /* Information about an outer context for */ const char *outerScript) /* continuation line data. This is set only in - * EvalTokensStandard(), to properly handle + * TclSubstTokens(), to properly handle * [...]-nested commands. The 'outerScript' * refers to the most-outer script containing * the embedded command, which is refered to @@ -4987,31 +5018,22 @@ TclEvalEx( /* * TIP #280 Initialize tracking. Do not push on the frame stack yet. * - * We may continue counting based on a specific context (CTX), or open a - * new context, either for a sourced script, or 'eval'. For sourced files - * we always have a path object, even if nothing was specified in the - * interp itself. That makes code using it simpler as NULL checks can be - * left out. Sourced file without path in the 'scriptFile' is possible - * during Tcl initialization. + * We open a new context, either for a sourced script, or 'eval'. + * For sourced files we always have a path object, even if nothing was + * specified in the interp itself. That makes code using it simpler as + * NULL checks can be left out. Sourced file without path in the + * 'scriptFile' is possible during Tcl initialization. */ eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; - eeFramePtr->numLevels = iPtr->numLevels; eeFramePtr->framePtr = iPtr->framePtr; eeFramePtr->nextPtr = iPtr->cmdFramePtr; eeFramePtr->nline = 0; eeFramePtr->line = NULL; + eeFramePtr->cmdObj = NULL; iPtr->cmdFramePtr = eeFramePtr; - if (iPtr->evalFlags & TCL_EVAL_CTX) { - /* - * Path information comes out of the context. - */ - - eeFramePtr->type = TCL_LOCATION_SOURCE; - eeFramePtr->data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; - Tcl_IncrRefCount(eeFramePtr->data.eval.path); - } else if (iPtr->evalFlags & TCL_EVAL_FILE) { + if (iPtr->evalFlags & TCL_EVAL_FILE) { /* * Set up for a sourced file. */ @@ -5054,7 +5076,9 @@ TclEvalEx( do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { code = TCL_ERROR; - goto error; + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + parsePtr->term + 1 - parsePtr->commandStart); + goto posterror; } /* @@ -5087,10 +5111,9 @@ TclEvalEx( */ if (numWords > minObjs) { - expand = (int *) ckalloc(numWords * sizeof(int)); - objvSpace = (Tcl_Obj **) - ckalloc(numWords * sizeof(Tcl_Obj *)); - lineSpace = (int *) ckalloc(numWords * sizeof(int)); + expand = ckalloc(numWords * sizeof(int)); + objvSpace = ckalloc(numWords * sizeof(Tcl_Obj *)); + lineSpace = ckalloc(numWords * sizeof(int)); } expandRequested = 0; objv = objvSpace; @@ -5175,10 +5198,9 @@ TclEvalEx( int objIdx = objectsNeeded - 1; if ((numWords > minObjs) || (objectsNeeded > minObjs)) { - objv = objvSpace = (Tcl_Obj **) + objv = objvSpace = ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = (int *) - ckalloc(objectsNeeded * sizeof(int)); + lines = lineSpace = ckalloc(objectsNeeded * sizeof(int)); } objectsUsed = 0; @@ -5205,10 +5227,10 @@ TclEvalEx( objv += objIdx+1; if (copy != stackObjArray) { - ckfree((char *) copy); + ckfree(copy); } if (lcopy != linesStack) { - ckfree((char *) lcopy); + ckfree(lcopy); } } @@ -5222,23 +5244,28 @@ TclEvalEx( * have been executed. */ - eeFramePtr->cmd.str.cmd = parsePtr->commandStart; - eeFramePtr->cmd.str.len = parsePtr->commandSize; + eeFramePtr->cmd = parsePtr->commandStart; + eeFramePtr->len = parsePtr->commandSize; if (parsePtr->term == parsePtr->commandStart + parsePtr->commandSize - 1) { - eeFramePtr->cmd.str.len--; + eeFramePtr->len--; } eeFramePtr->nline = objectsUsed; eeFramePtr->line = lines; TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); - code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR); + code = Tcl_EvalObjv(interp, objectsUsed, objv, + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME); TclArgumentRelease(interp, objv, objectsUsed); eeFramePtr->line = NULL; eeFramePtr->nline = 0; + if (eeFramePtr->cmdObj) { + Tcl_DecrRefCount(eeFramePtr->cmdObj); + eeFramePtr->cmdObj = NULL; + } if (code != TCL_OK) { goto error; @@ -5248,9 +5275,9 @@ TclEvalEx( } objectsUsed = 0; if (objvSpace != stackObjArray) { - ckfree((char *) objvSpace); + ckfree(objvSpace); objvSpace = stackObjArray; - ckfree((char *) lineSpace); + ckfree(lineSpace); lineSpace = linesStack; } @@ -5260,7 +5287,7 @@ TclEvalEx( */ if (expand != expandStack) { - ckfree((char *) expand); + ckfree(expand); expand = expandStack; } } @@ -5312,6 +5339,7 @@ TclEvalEx( Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, commandLength); } + posterror: iPtr->flags &= ~ERR_ALREADY_LOGGED; /* @@ -5325,11 +5353,11 @@ TclEvalEx( Tcl_FreeParse(parsePtr); } if (objvSpace != stackObjArray) { - ckfree((char *) objvSpace); - ckfree((char *) lineSpace); + ckfree(objvSpace); + ckfree(lineSpace); } if (expand != expandStack) { - ckfree((char *) expand); + ckfree(expand); } iPtr->varFramePtr = savedVarFramePtr; @@ -5413,7 +5441,7 @@ TclAdvanceContinuations( /* * Track the invisible continuation lines embedded in a script, if any. * Here they are just spaces (already). They were removed by - * EvalTokensStandard via Tcl_UtfBackslash. + * TclSubstTokens via TclParseBackslash. * * *clNextPtrPtr <=> We have continuation lines to track. * **clNextPtrPtr >= 0 <=> We are not beyond the last possible location. @@ -5486,14 +5514,14 @@ TclArgumentEnter( if (cfPtr->line[i] < 0) { continue; } - hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, (char *) objv[i], &new); + hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &new); if (new) { /* * The word is not on the stack yet, remember the current location * and initialize references. */ - cfwPtr = (CFWord *) ckalloc(sizeof(CFWord)); + cfwPtr = ckalloc(sizeof(CFWord)); cfwPtr->framePtr = cfPtr; cfwPtr->word = i; cfwPtr->refCount = 1; @@ -5554,7 +5582,7 @@ TclArgumentRelease( continue; } - ckfree((char *) cfwPtr); + ckfree(cfwPtr); Tcl_DeleteHashEntry(hPtr); } } @@ -5586,73 +5614,88 @@ TclArgumentBCEnter( int objc, void *codePtr, CmdFrame *cfPtr, + int cmd, int pc) { + ExtCmdLoc *eclPtr; + int word; + ECL *ePtr; + CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); - ExtCmdLoc *eclPtr; if (!hePtr) { return; } eclPtr = Tcl_GetHashValue(hePtr); - hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); - if (hePtr) { - int word; - int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); - ECL *ePtr = &eclPtr->loc[cmd]; - CFWordBC *lastPtr = NULL; + ePtr = &eclPtr->loc[cmd]; - /* - * A few truths ... - * (1) ePtr->nline == objc - * (2) (ePtr->line[word] < 0) => !literal, for all words - * (3) (word == 0) => !literal - * - * Item (2) is why we can use objv to get the literals, and do not - * have to save them at compile time. - */ + /* + * ePtr->nline is the number of words originally parsed. + * + * objc is the number of elements getting invoked. + * + * If they are not the same, we arrived here by compiling an + * ensemble dispatch. Ensemble subcommands that lead to script + * evaluation are not supposed to get compiled, because a command + * such as [info level] in the script can expose some of the dispatch + * shenanigans. This means that we don't have to tend to the + * housekeeping, and can escape now. + */ + + if (ePtr->nline != objc) { + return; + } - for (word = 1; word < objc; word++) { - if (ePtr->line[word] >= 0) { - int isnew; - Tcl_HashEntry *hPtr = - Tcl_CreateHashEntry(iPtr->lineLABCPtr, - (char *) objv[word], &isnew); - CFWordBC *cfwPtr = (CFWordBC *) ckalloc(sizeof(CFWordBC)); - - cfwPtr->framePtr = cfPtr; - cfwPtr->obj = objv[word]; - cfwPtr->pc = pc; - cfwPtr->word = word; - cfwPtr->nextPtr = lastPtr; - lastPtr = cfwPtr; - - if (isnew) { - /* - * The word is not on the stack yet, remember the current - * location and initialize references. - */ - - cfwPtr->prevPtr = NULL; - } else { - /* - * The object is already on the stack, however it may have - * a different location now (literal sharing may map - * multiple location to a single Tcl_Obj*. Save the old - * information in the new structure. - */ - - cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); - } + /* + * Having disposed of the ensemble cases, we can state... + * A few truths ... + * (1) ePtr->nline == objc + * (2) (ePtr->line[word] < 0) => !literal, for all words + * (3) (word == 0) => !literal + * + * Item (2) is why we can use objv to get the literals, and do not + * have to save them at compile time. + */ + + for (word = 1; word < objc; word++) { + if (ePtr->line[word] >= 0) { + int isnew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, + objv[word], &isnew); + CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); + + cfwPtr->framePtr = cfPtr; + cfwPtr->obj = objv[word]; + cfwPtr->pc = pc; + cfwPtr->word = word; + cfwPtr->nextPtr = lastPtr; + lastPtr = cfwPtr; + + if (isnew) { + /* + * The word is not on the stack yet, remember the current + * location and initialize references. + */ + + cfwPtr->prevPtr = NULL; + } else { + /* + * The object is already on the stack, however it may have + * a different location now (literal sharing may map + * multiple location to a single Tcl_Obj*. Save the old + * information in the new structure. + */ - Tcl_SetHashValue(hPtr, cfwPtr); + cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); } - } /* for */ - cfPtr->litarg = lastPtr; - } /* if */ + Tcl_SetHashValue(hPtr, cfwPtr); + } + } /* for */ + + cfPtr->litarg = lastPtr; } /* @@ -5699,7 +5742,7 @@ TclArgumentBCRelease( Tcl_DeleteHashEntry(hPtr); } - ckfree((char *) cfwPtr); + ckfree(cfwPtr); cfwPtr = nextPtr; } @@ -5742,8 +5785,7 @@ TclArgumentGet( * up by the caller. It knows better than us. */ - if ((!obj->bytes) || ((obj->typePtr == &tclListType) && - ((List *) obj->internalRep.twoPtrValue.ptr1)->canonicalFlag)) { + if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { return; } @@ -5801,6 +5843,7 @@ TclArgumentGet( *---------------------------------------------------------------------- */ +#undef Tcl_Eval int Tcl_Eval( Tcl_Interp *interp, /* Token for command interpreter (returned by @@ -5862,6 +5905,11 @@ Tcl_GlobalEvalObj( * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is * specified. * + * If the flag TCL_EVAL_DIRECT is passed in, the value of invoker + * must be NULL. Support for non-NULL invokers in that mode has + * been removed since it was unused and untested. Failure to + * follow this limitation will lead to an assertion panic. + * * Results: * The return value is one of the return codes defined in tcl.h (such as * TCL_OK), and the interpreter's result contains a value to supplement @@ -5902,10 +5950,10 @@ TclEvalObjEx( int word) /* Index of the word which is in objPtr. */ { int result = TCL_OK; - TEOV_callback *rootPtr = TOP_CB(interp); + NRE_callback *rootPtr = TOP_CB(interp); result = TclNREvalObjEx(interp, objPtr, flags, invoker, word); - return TclNRRunCallbacks(interp, result, rootPtr, 0); + return TclNRRunCallbacks(interp, result, rootPtr); } int @@ -5922,24 +5970,20 @@ TclNREvalObjEx( { Interp *iPtr = (Interp *) interp; int result; - List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; /* * This function consists of three independent blocks for: direct - * evaluation of canonical lists, compileation and bytecode execution and + * evaluation of canonical lists, compilation and bytecode execution and * finally direct evaluation. Precisely one of these blocks will be run. */ - if ((objPtr->typePtr == &tclListType) && /* is a list */ - ((objPtr->bytes == NULL || /* no string rep */ - listRepPtr->canonicalFlag))) { /* or is canonical */ - Tcl_Obj *listPtr = objPtr; + if (TclListObjIsCanonical(objPtr)) { CmdFrame *eoFramePtr = NULL; int objc; - Tcl_Obj **objv; + Tcl_Obj *listPtr, **objv; /* - * Pure List Optimization (no string representation). In this case, we + * Canonical List Optimization: In this case, we * can safely use Tcl_EvalObjv instead and get an appreciable * improvement in execution speed. This is because it allows us to * avoid a setFromAny step that would just pack everything into a @@ -5947,11 +5991,6 @@ TclNREvalObjEx( * * This also preserves any associations between list elements and * location information for such elements. - * - * This restriction has been relaxed a bit by storing in lists whether - * they are "canonical" or not (a canonical list being one that is - * either pure or that has its string rep derived by - * UpdateStringOfList from the internal rep). */ /* @@ -5960,13 +5999,13 @@ TclNREvalObjEx( * we always make a copy. The callback takes care od the refCounts for * both listPtr and objPtr. * + * TODO: Create a test to demo this need, or eliminate it. * FIXME OPT: preserve just the internal rep? */ Tcl_IncrRefCount(objPtr); listPtr = TclListObjCopy(interp, objPtr); Tcl_IncrRefCount(listPtr); - TclDecrRefCount(objPtr); if (word != INT_MIN) { /* @@ -5989,21 +6028,25 @@ TclNREvalObjEx( eoFramePtr->nline = 0; eoFramePtr->line = NULL; - eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->type = TCL_LOCATION_EVAL; eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 : iPtr->cmdFramePtr->level + 1); - eoFramePtr->numLevels = iPtr->numLevels; eoFramePtr->framePtr = iPtr->framePtr; eoFramePtr->nextPtr = iPtr->cmdFramePtr; - eoFramePtr->cmd.listPtr = listPtr; + eoFramePtr->cmdObj = objPtr; + eoFramePtr->cmd = NULL; + eoFramePtr->len = 0; eoFramePtr->data.eval.path = NULL; iPtr->cmdFramePtr = eoFramePtr; + + flags |= TCL_EVAL_SOURCE_IN_FRAME; } - TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, - NULL, NULL); + TclMarkTailcall(interp); + TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, + objPtr, NULL); ListObjGetElements(listPtr, objc, objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); @@ -6023,6 +6066,9 @@ TclNREvalObjEx( * iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ + if (TclInterpReady(interp) != TCL_OK) { + return TCL_ERROR; + } if (flags & TCL_EVAL_GLOBAL) { savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = iPtr->rootFramePtr; @@ -6032,9 +6078,7 @@ TclNREvalObjEx( TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr, objPtr, INT2PTR(allowExceptions), NULL); - TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, - NULL, NULL); - return TCL_OK; + return TclNRExecuteByteCode(interp, codePtr); } { @@ -6042,14 +6086,6 @@ TclNREvalObjEx( * We're not supposed to use the compiler or byte-code * interpreter. Let Tcl_EvalEx evaluate the command directly (and * probably more slowly). - * - * TIP #280. Propagate context as much as we can. Especially if the - * script to evaluate is a single literal it makes sense to look if - * our context is one with absolute line numbers we can then track - * into the literal itself too. - * - * See also tclCompile.c, TclInitCompileEnv, for the equivalent code - * in the bytecode compiler. */ const char *script; @@ -6073,92 +6109,19 @@ TclNREvalObjEx( */ ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; - ContLineLoc *clLocPtr = TclContinuationsGet(objPtr); - - if (clLocPtr) { - iPtr->scriptCLLocPtr = clLocPtr; - Tcl_Preserve(iPtr->scriptCLLocPtr); - } else { - iPtr->scriptCLLocPtr = NULL; - } - - Tcl_IncrRefCount(objPtr); - if (invoker == NULL) { - /* - * No context, force opening of our own. - */ - - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } else { - /* - * We have an invoker, describing the command asking for the - * evaluation of a subordinate script. This script may originate - * in a literal word, or from a variable, etc. Using the line - * array we now check if we have good line information for the - * relevant word. The type of context is relevant as well. In a - * non-'source' context we don't have to try tracking lines. - * - * First see if the word exists and is a literal. If not we go - * through the easy dynamic branch. No need to perform more - * complex invokations. - */ - - int pc = 0; - CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); - - *ctxPtr = *invoker; - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctxPtr->data.eval.path is not used. - * ctxPtr->data.tebc.codePtr is used instead. - */ - - TclGetSrcInfoForPc(ctxPtr); - pc = 1; - } - - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - - if ((invoker->nline <= word) || - (invoker->line[word] < 0) || - (ctxPtr->type != TCL_LOCATION_SOURCE)) { - /* - * Dynamic script, or dynamic context, force our own context. - */ - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } else { - /* - * Absolute context to reuse. - */ + assert(invoker == NULL); - iPtr->invokeCmdFramePtr = ctxPtr; - iPtr->evalFlags |= TCL_EVAL_CTX; + iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); - result = TclEvalEx(interp, script, numSrcBytes, flags, - ctxPtr->line[word], NULL, script); - } - if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { - /* - * Death of SrcInfo reference. - */ + Tcl_IncrRefCount(objPtr); - Tcl_DecrRefCount(ctxPtr->data.eval.path); - } - TclStackFree(interp, ctxPtr); - } + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - /* - * Now release the lock on the continuation line information, if any, - * and restore the caller's settings. - */ + TclDecrRefCount(objPtr); - if (iPtr->scriptCLLocPtr) { - Tcl_Release(iPtr->scriptCLLocPtr); - } iPtr->scriptCLLocPtr = saveCLLocPtr; - TclDecrRefCount(objPtr); return result; } } @@ -6193,7 +6156,7 @@ TEOEx_ByteCodeCallback( * Let us just unset the flags inline. */ - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); } iPtr->evalFlags = 0; @@ -6218,6 +6181,7 @@ TEOEx_ListCallback( Interp *iPtr = (Interp *) interp; Tcl_Obj *listPtr = data[0]; CmdFrame *eoFramePtr = data[1]; + Tcl_Obj *objPtr = data[2]; /* * Remove the cmdFrame @@ -6227,6 +6191,7 @@ TEOEx_ListCallback( iPtr->cmdFramePtr = eoFramePtr->nextPtr; TclStackFree(interp, eoFramePtr); } + TclDecrRefCount(objPtr); TclDecrRefCount(listPtr); return result; @@ -6262,11 +6227,11 @@ ProcessUnexpectedResult( Tcl_ResetResult(interp); if (returnCode == TCL_BREAK) { - Tcl_AppendResult(interp, - "invoked \"break\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invoked \"break\" outside of a loop", -1)); } else if (returnCode == TCL_CONTINUE) { - Tcl_AppendResult(interp, - "invoked \"continue\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invoked \"continue\" outside of a loop", -1)); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "command returned bad code: %d", returnCode)); @@ -6589,29 +6554,32 @@ TclObjInvoke( * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { - register Interp *iPtr = (Interp *) interp; - Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ - const char *cmdName; /* Name of the command from objv[0]. */ - Tcl_HashEntry *hPtr = NULL; - Command *cmdPtr; - int result; - if (interp == NULL) { return TCL_ERROR; } - if ((objc < 1) || (objv == NULL)) { - Tcl_AppendResult(interp, "illegal argument vector", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal argument vector", -1)); return TCL_ERROR; } - if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } + return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); +} - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } +int +TclNRInvoke( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + const char *cmdName; /* Name of the command from objv[0]. */ + Tcl_HashEntry *hPtr = NULL; + Command *cmdPtr; cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -6619,42 +6587,35 @@ TclObjInvoke( hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); } if (hPtr == NULL) { - Tcl_AppendResult(interp, "invalid hidden command name \"", - cmdName, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid hidden command name \"%s\"", cmdName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName, + NULL); return TCL_ERROR; } cmdPtr = Tcl_GetHashValue(hPtr); - /* - * Invoke the command function. - */ - - iPtr->cmdCount++; - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, objc, objv); - } + /* Avoid the exception-handling brain damage when numLevels == 0 . */ + iPtr->numLevels++; + Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); /* - * If an error occurred, record information about what was being executed - * when the error occurred. + * Normal command resolution of objv[0] isn't going to find cmdPtr. + * That's the whole point of **hidden** commands. So tell the + * Eval core machinery not to even try (and risk finding something wrong). */ - if ((result == TCL_ERROR) - && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) - && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { - int length; - Tcl_Obj *command = Tcl_NewListObj(objc, objv); - const char *cmdString; + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); +} - Tcl_IncrRefCount(command); - cmdString = Tcl_GetStringFromObj(command, &length); - Tcl_LogCommandInfo(interp, cmdString, cmdString, length); - Tcl_DecrRefCount(command); - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } +static int +NRPostInvoke( + ClientData clientData[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *)interp; + iPtr->numLevels--; return result; } @@ -6731,6 +6692,7 @@ Tcl_ExprString( *---------------------------------------------------------------------- */ +#undef Tcl_AddObjErrorInfo void Tcl_AppendObjToErrorInfo( Tcl_Interp *interp, /* Interpreter to which error information @@ -6764,6 +6726,7 @@ Tcl_AppendObjToErrorInfo( *---------------------------------------------------------------------- */ +#undef Tcl_AddErrorInfo void Tcl_AddErrorInfo( Tcl_Interp *interp, /* Interpreter to which error information @@ -6944,6 +6907,7 @@ Tcl_VarEval( *---------------------------------------------------------------------- */ +#undef Tcl_GlobalEval int Tcl_GlobalEval( Tcl_Interp *interp, /* Interpreter in which to evaluate @@ -7244,7 +7208,8 @@ ExprIsqrtFunc( return TCL_OK; negarg: - Tcl_SetResult(interp, "square root of negative argument", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "square root of negative argument", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); return TCL_ERROR; @@ -7419,54 +7384,72 @@ ExprAbsFunc( if (type == TCL_NUMBER_LONG) { long l = *((const long *) ptr); - if (l <= (long)0) { - if (l == LONG_MIN) { - TclBNInitBignumFromLong(&big, l); - goto tooLarge; + if (l > (long)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)); + return TCL_OK; + } + string++; + } } - Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); - } else { - Tcl_SetObjResult(interp, objv[1]); + goto unChanged; + } else if (l == LONG_MIN) { + TclBNInitBignumFromLong(&big, l); + goto tooLarge; } + Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); return TCL_OK; } if (type == TCL_NUMBER_DOUBLE) { double d = *((const double *) ptr); + static const double poszero = 0.0; - if (d <= 0.0) { - Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); - } else { - Tcl_SetObjResult(interp, objv[1]); + /* + * We need to distinguish here between positive 0.0 and negative -0.0. + * [Bug 2954959] + */ + + if (d == -0.0) { + if (!memcmp(&d, &poszero, sizeof(double))) { + goto unChanged; + } + } else if (d > -0.0) { + goto unChanged; } + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { Tcl_WideInt w = *((const Tcl_WideInt *) ptr); - if (w < (Tcl_WideInt)0) { - if (w == LLONG_MIN) { - TclBNInitBignumFromWideInt(&big, w); - goto tooLarge; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); - } else { - Tcl_SetObjResult(interp, objv[1]); + 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) { - /* TODO: const correctness ? */ - if (mp_cmp_d((mp_int *) ptr, 0) == MP_LT) { + if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: mp_neg(&big, &big); Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { + unChanged: Tcl_SetObjResult(interp, objv[1]); } return TCL_OK; @@ -7682,7 +7665,7 @@ ExprRandFunc( * to insure different seeds in different threads (bug #416643) */ - iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12); + iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. @@ -7908,7 +7891,7 @@ MathFuncWrongNumArgs( const char *tail = name + strlen(name); while (tail > name+1) { - --tail; + tail--; if (*tail == ':' && tail[-1] == ':') { name = tail+1; break; @@ -8083,37 +8066,11 @@ Tcl_NRCallObjProc( int objc, Tcl_Obj *const objv[]) { - int result = TCL_OK; - TEOV_callback *rootPtr = TOP_CB(interp); - - if (TCL_DTRACE_CMD_ARGS_ENABLED()) { - const char *a[10]; - int i = 0; - - while (i < 10) { - a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; - } - TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], - a[8], a[9]); - } - if (TCL_DTRACE_CMD_INFO_ENABLED() && ((Interp *) interp)->cmdFramePtr) { - Tcl_Obj *info = TclInfoFrame(interp, ((Interp *) interp)->cmdFramePtr); - const char *a[6]; int i[2]; + NRE_callback *rootPtr = TOP_CB(interp); - TclDTraceInfo(info, a, i); - TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); - TclDecrRefCount(info); - } - if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) - && objc) { - TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); - } - if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } - result = objProc(clientData, interp, objc, objv); - return TclNRRunCallbacks(interp, result, rootPtr, 0); + TclNRAddCallback(interp, Dispatch, objProc, clientData, + INT2PTR(objc), objv); + return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } /* @@ -8206,7 +8163,8 @@ Tcl_NRCmdSwap( Tcl_Obj *const objv[], int flags) { - return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd); + return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, + (Command *) cmd); } /***************************************************************************** @@ -8234,56 +8192,58 @@ Tcl_NRCmdSwap( */ void -TclSpliceTailcall( +TclMarkTailcall( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + if (iPtr->deferredCallbacks == NULL) { + TclNRAddCallback(interp, NRCommand, NULL, NULL, + NULL, NULL); + iPtr->deferredCallbacks = TOP_CB(interp); + } +} + +void +TclSkipTailcall( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + TclMarkTailcall(interp); + iPtr->deferredCallbacks->data[1] = INT2PTR(1); +} + +void +TclPushTailcallPoint( + Tcl_Interp *interp) +{ + TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); + ((Interp *) interp)->numLevels++; +} + +void +TclSetTailcall( Tcl_Interp *interp, - TEOV_callback *tailcallPtr) + Tcl_Obj *listPtr) { /* * Find the splicing spot: right before the NRCommand of the thing - * being tailcalled. Note that we skip NRCommands marked in data[1] - * (used by command redirectors), and we skip the first command that we - * find: it corresponds to [tailcall] itself. + * being tailcalled. Note that we skip NRCommands marked by a 1 in data[1] + * (used by command redirectors). */ - Interp *iPtr = (Interp *) interp; - TEOV_callback *runPtr; - ExecEnv *eePtr = NULL; - int second = 0; + NRE_callback *runPtr; - restart: for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { - if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { - if (second) break; - second = 1; - } + if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { + break; + } } if (!runPtr) { - /* - * If we are tailcalling out of a coroutine, the splicing spot is in - * the caller's execEnv: go find it! - */ - - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - if (corPtr) { - eePtr = iPtr->execEnvPtr; - iPtr->execEnvPtr = corPtr->callerEEPtr; - goto restart; - } - Tcl_Panic("Tailcall cannot find the right splicing spot: should not happen!"); - } - - tailcallPtr->nextPtr = runPtr->nextPtr; - runPtr->nextPtr = tailcallPtr; - - if (eePtr) { - /* - * Restore the right execEnv if it was swapped for tailcalling out - * of a coroutine. - */ - - iPtr->execEnvPtr = eePtr; + Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); } + runPtr->data[1] = listPtr; } int @@ -8294,74 +8254,95 @@ TclNRTailcallObjCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; - TEOV_callback *tailcallPtr; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?"); return TCL_ERROR; } - if (!iPtr->varFramePtr->isProcCallFrame || /* is not a body */ - (iPtr->framePtr != iPtr->varFramePtr)) { /* or is upleveled */ - Tcl_SetResult(interp, - "tailcall can only be called from a proc or lambda", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { /* or is upleveled */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tailcall can only be called from a proc or lambda", -1)); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); return TCL_ERROR; } - listPtr = Tcl_NewListObj(objc-1, objv+1); - Tcl_IncrRefCount(listPtr); + /* + * Invocation without args just clears a scheduled tailcall; invocation + * with an argument replaces any previously scheduled tailcall. + */ - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("Tailcall failed to find the proper namespace"); + if (iPtr->varFramePtr->tailcallPtr) { + Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); + iPtr->varFramePtr->tailcallPtr = NULL; } - Tcl_IncrRefCount(nsObjPtr); /* * Create the callback to actually evaluate the tailcalled - * command, then pass it to tebc so that it is stashed at the proper - * place. Being lazy: exploit the TclNRAddCallBack macro to build the - * callback. + * command, then set it in the varFrame so that PopCallFrame can use it + * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to + * build the callback. */ - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL); - tailcallPtr = TOP_CB(interp); - TOP_CB(interp) = tailcallPtr->nextPtr; + if (objc > 1) { + Tcl_Obj *listPtr, *nsObjPtr; + Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + Tcl_Namespace *ns1Ptr; - TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_TAILCALL_TYPE), - tailcallPtr, NULL, NULL); - return TCL_OK; + /* The tailcall data is in a Tcl list: the first element is the + * namespace, the rest the command to be tailcalled. */ + + listPtr = Tcl_NewListObj(objc, objv); + + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); + if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) + || (nsPtr != ns1Ptr)) { + Tcl_Panic("Tailcall failed to find the proper namespace"); + } + TclListObjSetElement(interp, listPtr, 0, nsObjPtr); + + iPtr->varFramePtr->tailcallPtr = listPtr; + } + return TCL_RETURN; } int -NRTailcallEval( +TclNRTailcallEval( ClientData data[], Tcl_Interp *interp, int result) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr = data[0]; - Tcl_Obj *nsObjPtr = data[1]; + Tcl_Obj *listPtr = data[0], *nsObjPtr; Tcl_Namespace *nsPtr; int objc; Tcl_Obj **objv; - TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL); + Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); + nsObjPtr = objv[0]; + if (result == TCL_OK) { result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result == TCL_OK) { - iPtr->lookupNsPtr = (Namespace *) nsPtr; - ListObjGetElements(listPtr, objc, objv); - result = TclNREvalObjv(interp, objc, objv, 0, NULL); - } } - return result; + + if (result != TCL_OK) { + /* + * Tailcall execution was preempted, eg by an intervening catch or by + * a now-gone namespace: cleanup and return. + */ + + TailcallCleanup(data, interp, result); + return result; + } + + /* + * Perform the tailcall + */ + + TclMarkTailcall(interp); + TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL); + iPtr->lookupNsPtr = (Namespace *) nsPtr; + return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); } static int @@ -8371,19 +8352,9 @@ TailcallCleanup( int result) { Tcl_DecrRefCount((Tcl_Obj *) data[0]); - Tcl_DecrRefCount((Tcl_Obj *) data[1]); return result; } -void -TclClearTailcall( - Tcl_Interp *interp, - TEOV_callback *tailcallPtr) -{ - TailcallCleanup(tailcallPtr->data, interp, TCL_OK); - TCLNR_FREE(interp, tailcallPtr); -} - void Tcl_NRAddCallback( @@ -8432,7 +8403,6 @@ TclNRYieldObjCmd( Tcl_Obj *const objv[]) { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - int numLevels = iPtr->numLevels; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?"); @@ -8440,8 +8410,8 @@ TclNRYieldObjCmd( } if (!corPtr) { - Tcl_SetResult(interp, "yield can only be called in a coroutine", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yield can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; } @@ -8450,11 +8420,9 @@ TclNRYieldObjCmd( Tcl_SetObjResult(interp, objv[1]); } - iPtr->numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; - - TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE), - NULL, NULL, NULL); + NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, + clientData, NULL, NULL); return TCL_OK; } @@ -8466,11 +8434,8 @@ TclNRYieldToObjCmd( Tcl_Obj *const objv[]) { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - int numLevels = iPtr->numLevels; - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; + Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); @@ -8478,62 +8443,39 @@ TclNRYieldToObjCmd( } if (!corPtr) { - Tcl_SetResult(interp, "yieldTo can only be called in a coroutine", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; } - iPtr->numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; + if (((Namespace *) nsPtr)->flags & NS_DYING) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto called in deleted namespace", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", + NULL); + return TCL_ERROR; + } /* + * Add the tailcall in the caller env, then just yield. + * * This is essentially code from TclNRTailcallObjCmd */ - listPtr = Tcl_NewListObj(objc-1, objv+1); - Tcl_IncrRefCount(listPtr); - + listPtr = Tcl_NewListObj(objc, objv); nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("yieldTo failed to find the proper namespace"); - } - Tcl_IncrRefCount(nsObjPtr); + TclListObjSetElement(interp, listPtr, 0, nsObjPtr); /* - * Add the callback in the caller's env, then instruct TEBC to yield + * Add the callback in the caller's env, then instruct TEBC to yield. */ iPtr->execEnvPtr = corPtr->callerEEPtr; - TclNRAddCallback(interp, YieldToCallback, corPtr, listPtr, nsObjPtr, - NULL); + TclSetTailcall(interp, listPtr); iPtr->execEnvPtr = corPtr->eePtr; - TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE), - NULL, NULL, NULL); - return TCL_OK; -} - -static int -YieldToCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* CoroutineData *corPtr = data[0];*/ - Tcl_Obj *listPtr = data[1]; - ClientData nsPtr = data[2]; - - /* yieldTo: invoke the command using tailcall tech */ - TEOV_callback *cbPtr; - - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL); - cbPtr = TOP_CB(interp); - TOP_CB(interp) = cbPtr->nextPtr; - - TclSpliceTailcall(interp, cbPtr); - return TCL_OK; + return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); } static int @@ -8555,13 +8497,12 @@ RewindCoroutine( NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); NRE_ASSERT(corPtr->eePtr != NULL); - NRE_ASSERT(corPtr->eePtr->bottomPtr != NULL); NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr); corPtr->eePtr->rewind = 1; TclNRAddCallback(interp, RewindCoroutineCallback, state, NULL, NULL, NULL); - return NRInterpCoroutine(corPtr, interp, 0, NULL); + return TclNRInterpCoroutine(corPtr, interp, 0, NULL); } static void @@ -8570,10 +8511,10 @@ DeleteCoroutine( { CoroutineData *corPtr = clientData; Tcl_Interp *interp = corPtr->eePtr->interp; - TEOV_callback *rootPtr = TOP_CB(interp); + NRE_callback *rootPtr = TOP_CB(interp); if (COR_IS_SUSPENDED(corPtr)) { - TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr, 0); + TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr); } } @@ -8602,7 +8543,7 @@ NRCoroutineCallerCallback( NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr); NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); - ckfree((char *) corPtr); + ckfree(corPtr); return result; } @@ -8652,13 +8593,7 @@ NRCoroutineExitCallback( TclDeleteExecEnv(corPtr->eePtr); corPtr->eePtr = NULL; - RESTORE_CONTEXT(corPtr->caller); - - NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); - NRE_ASSERT(iPtr->varFramePtr = corPtr->caller.varFramePtr); - NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); - - iPtr->execEnvPtr = corPtr->callerEEPtr; + corPtr->stackLevel = NULL; /* * #280. @@ -8666,66 +8601,226 @@ NRCoroutineExitCallback( * command arguments in bytecode. */ - Tcl_DeleteHashTable(corPtr->base.lineLABCPtr); - ckfree((char *) corPtr->base.lineLABCPtr); - corPtr->base.lineLABCPtr = NULL; + Tcl_DeleteHashTable(corPtr->lineLABCPtr); + ckfree(corPtr->lineLABCPtr); + corPtr->lineLABCPtr = NULL; + + RESTORE_CONTEXT(corPtr->caller); + iPtr->execEnvPtr = corPtr->callerEEPtr; + iPtr->numLevels++; return result; } +/* + *---------------------------------------------------------------------- + * + * TclNRCoroutineActivateCallback -- + * + * This is the workhorse for coroutines: it implements both yield and + * resume. + * + * It is important that both be implemented in the same callback: the + * detection of the impossibility to suspend due to a busy C-stack relies + * on the precise position of a local variable in the stack. We do not + * want the compiler to play tricks on us, either by moving things around + * or inlining. + * + *---------------------------------------------------------------------- + */ + int -NRInterpCoroutine( +TclNRCoroutineActivateCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CoroutineData *corPtr = data[0]; + int type = PTR2INT(data[1]); + int numLevels, unused; + int *stackLevel = &unused; + + if (!corPtr->stackLevel) { + /* + * -- Coroutine is suspended -- + * Push the callback to restore the caller's context on yield or + * return. + */ + + 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; + + SAVE_CONTEXT(corPtr->caller); + corPtr->callerEEPtr = iPtr->execEnvPtr; + RESTORE_CONTEXT(corPtr->running); + iPtr->execEnvPtr = corPtr->eePtr; + iPtr->numLevels += numLevels; + } else { + /* + * Coroutine is active: yield + */ + + if (corPtr->stackLevel != stackLevel) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot yield: C stack busy", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", + NULL); + return TCL_ERROR; + } + + if (type == CORO_ACTIVATE_YIELD) { + corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; + } else if (type == CORO_ACTIVATE_YIELDM) { + corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; + } else { + Tcl_Panic("Yield received an option which is not implemented"); + } + + corPtr->stackLevel = NULL; + + numLevels = iPtr->numLevels; + iPtr->numLevels = corPtr->auxNumLevels; + corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; + + iPtr->execEnvPtr = corPtr->callerEEPtr; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NRCoroInjectObjCmd -- + * + * Implementation of [::tcl::unsupported::inject] command. + * + *---------------------------------------------------------------------- + */ + +static int +NRCoroInjectObjCmd( ClientData clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { - CoroutineData *corPtr = clientData; - int nestNumLevels = corPtr->auxNumLevels; + Command *cmdPtr; + CoroutineData *corPtr; + ExecEnv *savedEEPtr = iPtr->execEnvPtr; /* - * objc==0 indicates a call to rewind the coroutine + * Usage more or less like tailcall: + * inject coroName cmd ?arg1 arg2 ...? */ - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?arg?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); return TCL_ERROR; } + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); + if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objv[1]), NULL); + return TCL_ERROR; + } + + corPtr = cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]), - "\" is already running", NULL); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a suspended coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); + return TCL_ERROR; } /* - * Swap the interp's environment to make it suitable to run this - * coroutine. TEBC needs no info to resume executing after a suspension: - * the codePtr will be read from the execEnv's saved bottomPtr. + * Add the callback to the coro's execEnv, so that it is the first thing + * to happen when the coro is resumed. */ - if (objc == 2) { - Tcl_SetObjResult(interp, objv[1]); - } + iPtr->execEnvPtr = corPtr->eePtr; + TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN); + iPtr->execEnvPtr = savedEEPtr; - SAVE_CONTEXT(corPtr->caller); - RESTORE_CONTEXT(corPtr->running); - corPtr->auxNumLevels = iPtr->numLevels; - iPtr->numLevels += nestNumLevels; + return TCL_OK; +} + +int +TclNRInterpCoroutine( + ClientData clientData, + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + CoroutineData *corPtr = clientData; - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, - NULL); + if (!COR_IS_SUSPENDED(corPtr)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "coroutine \"%s\" is already running", + Tcl_GetString(objv[0]))); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); + return TCL_ERROR; + } - corPtr->callerEEPtr = iPtr->execEnvPtr; - iPtr->execEnvPtr = corPtr->eePtr; + /* + * Parse all the arguments to work out what to feed as the result of the + * [yield]. TRICKY POINT: objc==0 happens here! It occurs when a coroutine + * is deleted! + */ - TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), NULL, - NULL, NULL); + switch (corPtr->nargs) { + case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: + if (objc == 2) { + Tcl_SetObjResult(interp, objv[1]); + } else if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?arg?"); + return TCL_ERROR; + } + break; + default: + if (corPtr->nargs != objc-1) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("wrong coro nargs; how did we get here? " + "not implemented!", -1)); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + return TCL_ERROR; + } + /* fallthrough */ + case COROUTINE_ARGUMENTS_ARBITRARY: + if (objc > 1) { + Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, objv+1)); + } + break; + } + + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, + NULL, NULL, NULL); return TCL_OK; } +/* + *---------------------------------------------------------------------- + * + * TclNRCoroutineObjCmd -- + * + * Implementation of [coroutine] command; see documentation for + * description of what this does. + * + *---------------------------------------------------------------------- + */ + int TclNRCoroutineObjCmd( ClientData dummy, /* Not used. */ @@ -8735,11 +8830,10 @@ TclNRCoroutineObjCmd( { Command *cmdPtr; CoroutineData *corPtr; - Tcl_Obj *cmdObjPtr; - const char *fullName; - const char *procName; + const char *fullName, *procName; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_DString ds; + Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?"); @@ -8756,47 +8850,44 @@ TclNRCoroutineObjCmd( &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": unknown namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": unknown namespace", + fullName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); return TCL_ERROR; } if (procName == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": bad procedure name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": bad procedure name", + fullName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) && (procName != NULL) && (procName[0] == ':')) { - Tcl_AppendResult(interp, "can't create procedure \"", procName, - "\" in non-global namespace with name starting with \":\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\" in non-global namespace with" + " name starting with \":\"", procName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); return TCL_ERROR; } /* * We ARE creating the coroutine command: allocate the corresponding - * struct, add the callback in caller's env and record the caller's - * frames. + * struct and create the corresponding command. */ - corPtr = (CoroutineData *) ckalloc(sizeof(CoroutineData)); - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, - NULL); - SAVE_CONTEXT(corPtr->caller); - - /* - * Create the coroutine command. - */ + corPtr = ckalloc(sizeof(CoroutineData)); Tcl_DStringInit(&ds); if (nsPtr != iPtr->globalNsPtr) { Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - Tcl_DStringAppend(&ds, "::", 2); + TclDStringAppendLiteral(&ds, "::"); } Tcl_DStringAppend(&ds, procName, -1); cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - /*objProc*/ NULL, NRInterpCoroutine, corPtr, DeleteCoroutine); + /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); Tcl_DStringFree(&ds); corPtr->cmdPtr = cmdPtr; @@ -8815,73 +8906,64 @@ TclNRCoroutineObjCmd( Tcl_HashSearch hSearch; Tcl_HashEntry *hePtr; - corPtr->base.lineLABCPtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(corPtr->base.lineLABCPtr, TCL_ONE_WORD_KEYS); + corPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch); hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) { int isNew; Tcl_HashEntry *newPtr = - Tcl_CreateHashEntry(corPtr->base.lineLABCPtr, - (char *) Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr), + Tcl_CreateHashEntry(corPtr->lineLABCPtr, + Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr), &isNew); Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr)); } - - /* - * The new copy is immediately plugged interpreter for use by the - * first coroutine commands (see below). The interp's copy of the - * table is already saved, see the SAVE_CONTEXT found just above this - * whole code block. This also properly prepares us for the - * SAVE/RESTORE dances during yields which swizzle the pointers - * around. - */ - - iPtr->lineLABCPtr = corPtr->base.lineLABCPtr; } /* - * Save the base context. The base cmdFramePtr is unknown at this time: it - * will be allocated in the Tcl stack. So signal TEBC that it has to - * initialize the base cmdFramePtr by setting it to NULL. + * Create the base context. */ - corPtr->base.cmdFramePtr = NULL; - corPtr->running = NULL_CONTEXT; + corPtr->running.framePtr = iPtr->rootFramePtr; + corPtr->running.varFramePtr = iPtr->rootFramePtr; + corPtr->running.cmdFramePtr = NULL; + corPtr->running.lineLABCPtr = corPtr->lineLABCPtr; corPtr->stackLevel = NULL; - corPtr->auxNumLevels = iPtr->numLevels; + corPtr->auxNumLevels = 0; /* - * Create the command that will run at the bottom of the coroutine. - * Be sure not to pass a canonical list for the command so that we insure - * the body is bytecompiled: we need a TEBC instance to handle [yield] - */ - - cmdObjPtr = Tcl_NewListObj(objc-2, &objv[2]); - TclGetString(cmdObjPtr); - TclFreeIntRep(cmdObjPtr); - cmdObjPtr->typePtr = NULL; - - - /* - * Create the coro's execEnv and switch to it so that any CallFrames or - * callbacks refer to the new execEnv's stack. Add the exit callback, then - * the callback to eval the coro body. + * Create the coro's execEnv, switch to it to push the exit and coro + * command callbacks, then switch back. */ corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE); corPtr->callerEEPtr = iPtr->execEnvPtr; corPtr->eePtr->corPtr = corPtr; + + SAVE_CONTEXT(corPtr->caller); + corPtr->callerEEPtr = iPtr->execEnvPtr; + RESTORE_CONTEXT(corPtr->running); iPtr->execEnvPtr = corPtr->eePtr; TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); - iPtr->evalFlags |= TCL_EVAL_REDIRECT; - iPtr->lookupNsPtr = iPtr->varFramePtr->nsPtr; - TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0); + /* insure that the command is looked up in the correct namespace */ + iPtr->lookupNsPtr = lookupNsPtr; + Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); + iPtr->numLevels--; + + SAVE_CONTEXT(corPtr->running); + RESTORE_CONTEXT(corPtr->caller); + iPtr->execEnvPtr = corPtr->callerEEPtr; + + /* + * Now just resume the coroutine. + */ + + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, + NULL, NULL, NULL); return TCL_OK; } @@ -8920,5 +9002,7 @@ TclInfoCoroutineCmd( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ |