diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 4293 |
1 files changed, 3151 insertions, 1142 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cfb5c43..562cca6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -10,17 +10,25 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> + * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. + * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #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> +#endif + +#define INTERP_STACK_INITIAL_SIZE 2000 +#define CORO_STACK_INITIAL_SIZE 200 /* * Determine whether we're using IEEE floating point @@ -45,59 +53,132 @@ typedef struct OldMathFuncData { } OldMathFuncData; /* + * This is the script cancellation struct and hash table. The hash table is + * used to keep track of the information necessary to process script + * cancellation requests, including the original interp, asynchronous handler + * tokens (created by Tcl_AsyncCreate), and the clientData and flags arguments + * passed to Tcl_CancelEval on a per-interp basis. The cancelLock mutex is + * used for protecting calls to Tcl_CancelEval as well as protecting access to + * the hash table below. + */ + +typedef struct { + Tcl_Interp *interp; /* Interp this struct belongs to. */ + Tcl_AsyncHandler async; /* Async handler token for script + * cancellation. */ + char *result; /* The script cancellation result or NULL for + * a default result. */ + int length; /* Length of the above error message. */ + ClientData clientData; /* Ignored */ + int flags; /* Additional flags */ +} CancelInfo; +static Tcl_HashTable cancelTable; +static int cancelTableInitialized = 0; /* 0 means not yet initialized. */ +TCL_DECLARE_MUTEX(cancelLock) + +/* + * Declarations for managing contexts for non-recursive coroutines. Contexts + * are used to save the evaluation state between NR calls to each coro. + */ + +#define SAVE_CONTEXT(context) \ + (context).framePtr = iPtr->framePtr; \ + (context).varFramePtr = iPtr->varFramePtr; \ + (context).cmdFramePtr = iPtr->cmdFramePtr; \ + (context).lineLABCPtr = iPtr->lineLABCPtr + +#define RESTORE_CONTEXT(context) \ + iPtr->framePtr = (context).framePtr; \ + iPtr->varFramePtr = (context).varFramePtr; \ + iPtr->cmdFramePtr = (context).cmdFramePtr; \ + iPtr->lineLABCPtr = (context).lineLABCPtr + +/* * Static functions in this file: */ -static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, - const char *oldName, const char *newName, int flags); -static int CheckDoubleResult(Tcl_Interp *interp, double dResult); -static void DeleteInterpProc(Tcl_Interp *interp); -static void DeleteOpCmdClientData(ClientData clientData); -static Tcl_Obj *GetCommandSource(Interp *iPtr, const char *command, - int numChars, int objc, Tcl_Obj *const objv[]); -static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); -static int OldMathFuncProc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static void OldMathFuncDeleteProc(ClientData clientData); -static int ExprAbsFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprBinaryFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprBoolFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprCeilFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprDoubleFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprEntierFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprFloorFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprIntFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprIsqrtFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprRandFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprRoundFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprSqrtFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprSrandFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprUnaryFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static int ExprWideFunc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *const *objv); -static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, - int actual, Tcl_Obj *const *objv); +static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, + const char *oldName, const char *newName, + int flags); +static int CancelEvalProc(ClientData clientData, + Tcl_Interp *interp, int code); +static int CheckDoubleResult(Tcl_Interp *interp, double dResult); +static void DeleteCoroutine(ClientData clientData); +static void DeleteInterpProc(Tcl_Interp *interp); +static void DeleteOpCmdClientData(ClientData clientData); #ifdef USE_DTRACE -static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -#endif +static Tcl_ObjCmdProc DTraceObjCmd; +static Tcl_NRPostProc DTraceCmdReturn; +#else +# define DTraceCmdReturn NULL +#endif /* USE_DTRACE */ +static Tcl_ObjCmdProc ExprAbsFunc; +static Tcl_ObjCmdProc ExprBinaryFunc; +static Tcl_ObjCmdProc ExprBoolFunc; +static Tcl_ObjCmdProc ExprCeilFunc; +static Tcl_ObjCmdProc ExprDoubleFunc; +static Tcl_ObjCmdProc ExprEntierFunc; +static Tcl_ObjCmdProc ExprFloorFunc; +static Tcl_ObjCmdProc ExprIntFunc; +static Tcl_ObjCmdProc ExprIsqrtFunc; +static Tcl_ObjCmdProc ExprRandFunc; +static Tcl_ObjCmdProc ExprRoundFunc; +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 int NRCommand(ClientData data[], Tcl_Interp *interp, int result); + +static Tcl_NRPostProc NRRunObjProc; +static Tcl_ObjCmdProc OldMathFuncProc; +static void OldMathFuncDeleteProc(ClientData clientData); +static void ProcessUnexpectedResult(Tcl_Interp *interp, + int returnCode); +static int RewindCoroutine(CoroutineData *corPtr, int result); +static void TEOV_SwitchVarFrame(Tcl_Interp *interp); +static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[], int flags); +static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, + Tcl_Obj *namePtr, Namespace *lookupNsPtr); +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); +static Tcl_NRPostProc RewindCoroutineCallback; +static Tcl_NRPostProc TailcallCleanup; +static Tcl_NRPostProc TEOEx_ByteCodeCallback; +static Tcl_NRPostProc TEOEx_ListCallback; +static Tcl_NRPostProc TEOV_Error; +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 void ClearTailcall(Tcl_Interp *interp, + struct NRE_callback *tailcallPtr); +static Tcl_ObjCmdProc NRCoroInjectObjCmd; + +MODULE_SCOPE const TclStubs tclStubs; -extern 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 +#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) +#define COROUTINE_ARGUMENTS_ARBITRARY (-2) + /* * The following structure define the commands in the Tcl core. */ @@ -106,6 +187,7 @@ typedef struct { const char *name; /* Name of object-based command. */ 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. */ @@ -120,93 +202,96 @@ static const CmdInfo builtInCmds[] = { * Commands in the generic core. */ - {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1}, - {"apply", Tcl_ApplyObjCmd, NULL, 1}, - {"array", Tcl_ArrayObjCmd, NULL, 1}, - {"binary", Tcl_BinaryObjCmd, NULL, 1}, - {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, + {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, 1}, + {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, 1}, + {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, 1}, #ifndef EXCLUDE_OBSOLETE_COMMANDS - {"case", Tcl_CaseObjCmd, NULL, 1}, + {"case", Tcl_CaseObjCmd, NULL, NULL, 1}, #endif - {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, 1}, - {"concat", Tcl_ConcatObjCmd, NULL, 1}, - {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, 1}, - {"error", Tcl_ErrorObjCmd, NULL, 1}, - {"eval", Tcl_EvalObjCmd, NULL, 1}, - {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, 1}, - {"for", Tcl_ForObjCmd, TclCompileForCmd, 1}, - {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, 1}, - {"format", Tcl_FormatObjCmd, NULL, 1}, - {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, 1}, - {"if", Tcl_IfObjCmd, TclCompileIfCmd, 1}, - {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, 1}, - {"join", Tcl_JoinObjCmd, NULL, 1}, - {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, 1}, - {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, 1}, - {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, 1}, - {"linsert", Tcl_LinsertObjCmd, NULL, 1}, - {"list", Tcl_ListObjCmd, TclCompileListCmd, 1}, - {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, 1}, - {"lrange", Tcl_LrangeObjCmd, NULL, 1}, - {"lrepeat", Tcl_LrepeatObjCmd, NULL, 1}, - {"lreplace", Tcl_LreplaceObjCmd, NULL, 1}, - {"lreverse", Tcl_LreverseObjCmd, NULL, 1}, - {"lsearch", Tcl_LsearchObjCmd, NULL, 1}, - {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, 1}, - {"lsort", Tcl_LsortObjCmd, NULL, 1}, - {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, 1}, - {"package", Tcl_PackageObjCmd, NULL, 1}, - {"proc", Tcl_ProcObjCmd, NULL, 1}, - {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, 1}, - {"regsub", Tcl_RegsubObjCmd, NULL, 1}, - {"rename", Tcl_RenameObjCmd, NULL, 1}, - {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, 1}, - {"scan", Tcl_ScanObjCmd, NULL, 1}, - {"set", Tcl_SetObjCmd, TclCompileSetCmd, 1}, - {"split", Tcl_SplitObjCmd, NULL, 1}, - {"subst", Tcl_SubstObjCmd, NULL, 1}, - {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, 1}, - {"trace", Tcl_TraceObjCmd, NULL, 1}, - {"unset", Tcl_UnsetObjCmd, NULL, 1}, - {"uplevel", Tcl_UplevelObjCmd, NULL, 1}, - {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, 1}, - {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, 1}, - {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, 1}, + {"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, TclCompileErrorCmd, NULL, 1}, + {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, 1}, + {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1}, + {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, + {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, + {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, 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}, + {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1}, + {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1}, + {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, + {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, 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}, + {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, + {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, + {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, + {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, 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, TclCompileTailcallCmd, TclNRTailcallObjCmd, 1}, + {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1}, + {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, + {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1}, + {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, 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, TclCompileYieldCmd, TclNRYieldObjCmd, 1}, + {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1}, /* * Commands in the OS-interface. Note that many of these are unsafe. */ - {"after", Tcl_AfterObjCmd, NULL, 1}, - {"cd", Tcl_CdObjCmd, NULL, 0}, - {"close", Tcl_CloseObjCmd, NULL, 1}, - {"eof", Tcl_EofObjCmd, NULL, 1}, - {"encoding", Tcl_EncodingObjCmd, NULL, 0}, - {"exec", Tcl_ExecObjCmd, NULL, 0}, - {"exit", Tcl_ExitObjCmd, NULL, 0}, - {"fblocked", Tcl_FblockedObjCmd, NULL, 1}, - {"fconfigure", Tcl_FconfigureObjCmd, NULL, 0}, - {"fcopy", Tcl_FcopyObjCmd, NULL, 1}, - {"file", Tcl_FileObjCmd, NULL, 0}, - {"fileevent", Tcl_FileEventObjCmd, NULL, 1}, - {"flush", Tcl_FlushObjCmd, NULL, 1}, - {"gets", Tcl_GetsObjCmd, NULL, 1}, - {"glob", Tcl_GlobObjCmd, NULL, 0}, - {"load", Tcl_LoadObjCmd, NULL, 0}, - {"open", Tcl_OpenObjCmd, NULL, 0}, - {"pid", Tcl_PidObjCmd, NULL, 1}, - {"puts", Tcl_PutsObjCmd, NULL, 1}, - {"pwd", Tcl_PwdObjCmd, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, 1}, - {"seek", Tcl_SeekObjCmd, NULL, 1}, - {"socket", Tcl_SocketObjCmd, NULL, 0}, - {"source", Tcl_SourceObjCmd, NULL, 0}, - {"tell", Tcl_TellObjCmd, NULL, 1}, - {"time", Tcl_TimeObjCmd, NULL, 1}, - {"unload", Tcl_UnloadObjCmd, NULL, 0}, - {"update", Tcl_UpdateObjCmd, NULL, 1}, - {"vwait", Tcl_VwaitObjCmd, NULL, 1}, - {NULL, NULL, NULL, 0} + {"after", Tcl_AfterObjCmd, NULL, NULL, 1}, + {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, NULL, 1}, + {"eof", Tcl_EofObjCmd, NULL, NULL, 1}, + {"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0}, + {"exec", Tcl_ExecObjCmd, NULL, NULL, 0}, + {"exit", Tcl_ExitObjCmd, NULL, NULL, 0}, + {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1}, + {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, + {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1}, + {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1}, + {"flush", Tcl_FlushObjCmd, NULL, NULL, 1}, + {"gets", Tcl_GetsObjCmd, NULL, NULL, 1}, + {"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}, + {"pwd", Tcl_PwdObjCmd, NULL, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, NULL, 1}, + {"seek", Tcl_SeekObjCmd, NULL, NULL, 1}, + {"socket", Tcl_SocketObjCmd, NULL, NULL, 0}, + {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, + {"tell", Tcl_TellObjCmd, NULL, NULL, 1}, + {"time", Tcl_TimeObjCmd, NULL, NULL, 1}, + {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, + {"update", Tcl_UpdateObjCmd, NULL, NULL, 1}, + {"vwait", Tcl_VwaitObjCmd, NULL, NULL, 1}, + {NULL, NULL, NULL, NULL, 0} }; /* @@ -215,40 +300,40 @@ static const CmdInfo builtInCmds[] = { typedef struct { const char *name; /* Name of the function. The full name is - * "::tcl::mathfunc::<name>". */ + * "::tcl::mathfunc::<name>". */ Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */ ClientData clientData; /* Client data for the function */ } BuiltinFuncDef; static const BuiltinFuncDef BuiltinFuncTable[] = { - { "abs", ExprAbsFunc, NULL }, - { "acos", ExprUnaryFunc, (ClientData) acos }, - { "asin", ExprUnaryFunc, (ClientData) asin }, - { "atan", ExprUnaryFunc, (ClientData) atan }, - { "atan2", ExprBinaryFunc, (ClientData) atan2 }, + { "abs", ExprAbsFunc, NULL }, + { "acos", ExprUnaryFunc, (ClientData) acos }, + { "asin", ExprUnaryFunc, (ClientData) asin }, + { "atan", ExprUnaryFunc, (ClientData) atan }, + { "atan2", ExprBinaryFunc, (ClientData) atan2 }, { "bool", ExprBoolFunc, NULL }, - { "ceil", ExprCeilFunc, NULL }, - { "cos", ExprUnaryFunc, (ClientData) cos }, + { "ceil", ExprCeilFunc, NULL }, + { "cos", ExprUnaryFunc, (ClientData) cos }, { "cosh", ExprUnaryFunc, (ClientData) cosh }, { "double", ExprDoubleFunc, NULL }, { "entier", ExprEntierFunc, NULL }, { "exp", ExprUnaryFunc, (ClientData) exp }, - { "floor", ExprFloorFunc, NULL }, + { "floor", ExprFloorFunc, NULL }, { "fmod", ExprBinaryFunc, (ClientData) fmod }, - { "hypot", ExprBinaryFunc, (ClientData) hypot }, + { "hypot", ExprBinaryFunc, (ClientData) hypot }, { "int", ExprIntFunc, NULL }, { "isqrt", ExprIsqrtFunc, NULL }, - { "log", ExprUnaryFunc, (ClientData) log }, - { "log10", ExprUnaryFunc, (ClientData) log10 }, - { "pow", ExprBinaryFunc, (ClientData) pow }, + { "log", ExprUnaryFunc, (ClientData) log }, + { "log10", ExprUnaryFunc, (ClientData) log10 }, + { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, - { "sin", ExprUnaryFunc, (ClientData) sin }, - { "sinh", ExprUnaryFunc, (ClientData) sinh }, - { "sqrt", ExprSqrtFunc, NULL }, + { "sin", ExprUnaryFunc, (ClientData) sin }, + { "sinh", ExprUnaryFunc, (ClientData) sinh }, + { "sqrt", ExprSqrtFunc, NULL }, { "srand", ExprSrandFunc, NULL }, - { "tan", ExprUnaryFunc, (ClientData) tan }, - { "tanh", ExprUnaryFunc, (ClientData) tanh }, - { "wide", ExprWideFunc, NULL }, + { "tan", ExprUnaryFunc, (ClientData) tan }, + { "tanh", ExprUnaryFunc, (ClientData) tanh }, + { "wide", ExprWideFunc, NULL }, { NULL, NULL, NULL } }; @@ -317,47 +402,33 @@ static const OpCmdInfo mathOpCmds[] = { { NULL, NULL, NULL, {0}, NULL} }; - -/* - * Macros for stack checks. The goal of these macros is to allow the size of - * the stack to be checked (so preventing overflow) in a *cheap* way. Note - * that the check needs to be (amortized) cheap since it is on the critical - * path for recursion. - */ - -#if defined(TCL_NO_STACK_CHECK) -/* - * Stack check disabled: make them noops. - */ - -# define CheckCStack(interp, localIntPtr) 1 -# define GetCStackParams(iPtr) /* do nothing */ -#elif defined(TCL_CROSS_COMPILE) - + /* - * This variable is static and only set *once*, during library initialization. - * It therefore needs no thread guards. + *---------------------------------------------------------------------- + * + * TclFinalizeEvaluation -- + * + * Finalizes the script cancellation hash table. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- */ -static int stackGrowsDown = 1; -# define GetCStackParams(iPtr) \ - stackGrowsDown = TclpGetCStackParams(&((iPtr)->stackBound)) -# define CheckCStack(iPtr, localIntPtr) \ - (stackGrowsDown \ - ? ((localIntPtr) > (iPtr)->stackBound) \ - : ((localIntPtr) < (iPtr)->stackBound) \ - ) -#else /* !TCL_NO_STACK_CHECK && !TCL_CROSS_COMPILE */ -# define GetCStackParams(iPtr) \ - TclpGetCStackParams(&((iPtr)->stackBound)) -# ifdef TCL_STACK_GROWS_UP -# define CheckCStack(iPtr, localIntPtr) \ - (!(iPtr)->stackBound || (localIntPtr) < (iPtr)->stackBound) -# else /* TCL_STACK_GROWS_UP */ -# define CheckCStack(iPtr, localIntPtr) \ - ((localIntPtr) > (iPtr)->stackBound) -# endif /* TCL_STACK_GROWS_UP */ -#endif /* TCL_NO_STACK_CHECK/TCL_CROSS_COMPILE */ +void +TclFinalizeEvaluation(void) +{ + Tcl_MutexLock(&cancelLock); + if (cancelTableInitialized == 1) { + Tcl_DeleteHashTable(&cancelTable); + cancelTableInitialized = 0; + } + Tcl_MutexUnlock(&cancelLock); +} /* *---------------------------------------------------------------------- @@ -387,6 +458,9 @@ Tcl_CreateInterp(void) const OpCmdInfo *opcmdInfoPtr; const CmdInfo *cmdInfoPtr; Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr; + Tcl_HashEntry *hPtr; + int isNew; + CancelInfo *cancelInfo; union { char c[sizeof(short)]; short s; @@ -410,13 +484,22 @@ Tcl_CreateInterp(void) Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } + if (cancelTableInitialized == 0) { + Tcl_MutexLock(&cancelLock); + if (cancelTableInitialized == 0) { + Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS); + cancelTableInitialized = 1; + } + Tcl_MutexUnlock(&cancelLock); + } + /* * Initialize support for namespaces and create the global namespace * (whose name is ""; an alias is "::"). This also initializes the Tcl * 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; @@ -435,15 +518,15 @@ Tcl_CreateInterp(void) iPtr->varFramePtr = NULL; /* Initialise as soon as :: is available */ /* - * TIP #280 - Initialize the arrays used to extend the ByteCode and - * Proc structures. + * TIP #280 - Initialize the arrays used to extend the ByteCode and Proc + * structures. */ 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); @@ -456,6 +539,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); @@ -480,7 +574,7 @@ Tcl_CreateInterp(void) } iPtr->cmdCount = 0; - TclInitLiteralTable(&(iPtr->literalTable)); + TclInitLiteralTable(&iPtr->literalTable); iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; @@ -530,7 +624,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) { @@ -549,7 +643,7 @@ Tcl_CreateInterp(void) * variable). */ - iPtr->execEnvPtr = TclCreateExecEnv(interp); + iPtr->execEnvPtr = TclCreateExecEnv(interp, INTERP_STACK_INITIAL_SIZE); /* * TIP #219, Tcl Channel Reflection API support. @@ -558,25 +652,44 @@ Tcl_CreateInterp(void) iPtr->chanMsg = NULL; /* + * TIP #285, Script cancellation support. + */ + + iPtr->asyncCancelMsg = Tcl_NewObj(); + + cancelInfo = ckalloc(sizeof(CancelInfo)); + cancelInfo->interp = interp; + + iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo); + cancelInfo->async = iPtr->asyncCancel; + cancelInfo->result = NULL; + cancelInfo->length = 0; + + Tcl_MutexLock(&cancelLock); + hPtr = Tcl_CreateHashEntry(&cancelTable, iPtr, &isNew); + Tcl_SetHashValue(hPtr, cancelInfo); + Tcl_MutexUnlock(&cancelLock); + + /* * Initialize the compilation and execution statistics kept for this * interpreter. */ #ifdef TCL_COMPILE_STATS - statsPtr = &(iPtr->stats); + statsPtr = &iPtr->stats; statsPtr->numExecutions = 0; statsPtr->numCompilations = 0; statsPtr->numByteCodesFreed = 0; - (void) memset(statsPtr->instructionCount, 0, + memset(statsPtr->instructionCount, 0, sizeof(statsPtr->instructionCount)); statsPtr->totalSrcBytes = 0.0; statsPtr->totalByteCodeBytes = 0.0; statsPtr->currentSrcBytes = 0.0; statsPtr->currentByteCodeBytes = 0.0; - (void) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); - (void) memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount)); - (void) memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount)); + memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); + memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount)); + memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount)); statsPtr->currentInstBytes = 0.0; statsPtr->currentLitBytes = 0.0; @@ -587,7 +700,7 @@ Tcl_CreateInterp(void) statsPtr->numLiteralsCreated = 0; statsPtr->totalLitStringBytes = 0.0; statsPtr->currentLitStringBytes = 0.0; - (void) memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); + memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); #endif /* TCL_COMPILE_STATS */ /* @@ -611,7 +724,8 @@ Tcl_CreateInterp(void) TclInitLimitSupport(interp); /* - * Initialise the thread-specific data ekeko. + * Initialise the thread-specific data ekeko. Note that the thread's alloc + * cache was already initialised by the call to alloc the interp struct. */ #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) @@ -621,13 +735,7 @@ Tcl_CreateInterp(void) #endif iPtr->pendingObjDataPtr = NULL; iPtr->asyncReadyPtr = TclGetAsyncReadyPtr(); - - /* - * Insure that the stack checking mechanism for this interp is - * initialized. - */ - - GetCStackParams(iPtr); + iPtr->deferredCallbacks = NULL; /* * Create the core commands. Do it here, rather than calling @@ -640,19 +748,17 @@ Tcl_CreateInterp(void) * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. */ - for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { - int isNew; - Tcl_HashEntry *hPtr; - + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { if ((cmdInfoPtr->objProc == NULL) - && (cmdInfoPtr->compileProc == NULL)) { + && (cmdInfoPtr->compileProc == NULL) + && (cmdInfoPtr->nreProc == NULL)) { Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc"); } 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; @@ -667,20 +773,27 @@ Tcl_CreateInterp(void) cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; + cmdPtr->nreProc = cmdInfoPtr->nreProc; Tcl_SetHashValue(hPtr, cmdPtr); } } /* - * Create the "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); /* * Register "clock" subcommands. These *do* go through @@ -703,11 +816,22 @@ Tcl_CreateInterp(void) TclDefaultBgErrorHandlerObjCmd, NULL, NULL); /* - * Create an unsupported command for debugging bytecode. + * Create unsupported commands for debugging bytecode and objects. */ Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", Tcl_DisassembleObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", + Tcl_RepresentationCmd, 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 /* @@ -725,8 +849,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); @@ -740,15 +864,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"); } - (void) Tcl_Export(interp, mathopNSPtr, "*", 1); - strcpy(mathFuncName, "::tcl::mathop::"); + Tcl_Export(interp, mathopNSPtr, "*", 1); +#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; @@ -822,15 +945,26 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); -#ifdef Tcl_InitStubs -#undef Tcl_InitStubs -#endif - Tcl_InitStubs(interp, TCL_VERSION, 1); - if (TclTommath_Init(interp) != TCL_OK) { Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } + if (TclOOInit(interp) != TCL_OK) { + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + } + + /* + * Only build in zlib support if we've successfully detected a library to + * compile and link against. + */ + +#ifdef HAVE_ZLIB + if (TclZlibInit(interp) != TCL_OK) { + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + } +#endif + + TOP_CB(iPtr) = NULL; return interp; } @@ -840,7 +974,7 @@ DeleteOpCmdClientData( { TclOpCmdClientData *occdPtr = clientData; - ckfree((char *) occdPtr); + ckfree(occdPtr); } /* @@ -873,6 +1007,7 @@ TclHideUnsafeCommands( Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } + TclMakeFileCommandSafe(interp); /* Ugh! */ return TCL_OK; } @@ -910,14 +1045,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); @@ -964,9 +1099,9 @@ Tcl_DontCallWhenDeleted( } for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + dPtr = Tcl_GetHashValue(hPtr); if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { - ckfree((char *) dPtr); + ckfree(dPtr); Tcl_DeleteHashEntry(hPtr); return; } @@ -1006,14 +1141,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; @@ -1058,7 +1193,7 @@ Tcl_DeleteAssocData( if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - ckfree((char *) dPtr); + ckfree(dPtr); Tcl_DeleteHashEntry(hPtr); } @@ -1213,12 +1348,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"); } @@ -1241,6 +1378,37 @@ DeleteInterpProc( } /* + * TIP #285, Script cancellation support. Delete this interp from the + * global hash table of CancelInfo structs. + */ + + Tcl_MutexLock(&cancelLock); + hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr); + if (hPtr != NULL) { + CancelInfo *cancelInfo = Tcl_GetHashValue(hPtr); + + if (cancelInfo != NULL) { + if (cancelInfo->result != NULL) { + ckfree(cancelInfo->result); + } + ckfree(cancelInfo); + } + + Tcl_DeleteHashEntry(hPtr); + } + + if (iPtr->asyncCancel != NULL) { + Tcl_AsyncDelete(iPtr->asyncCancel); + iPtr->asyncCancel = NULL; + } + + if (iPtr->asyncCancelMsg != NULL) { + Tcl_DecrRefCount(iPtr->asyncCancelMsg); + iPtr->asyncCancelMsg = NULL; + } + Tcl_MutexUnlock(&cancelLock); + + /* * Shut down all limit handler callback scripts that call back into this * interpreter. Then eliminate all limit handlers for this interpreter. */ @@ -1269,17 +1437,16 @@ DeleteInterpProc( /* * Non-pernicious deletion. The deletion callbacks will not be allowed * to create any new hidden or non-hidden commands. - * Tcl_DeleteCommandFromToken() will remove the entry from the + * Tcl_DeleteCommandFromToken will remove the entry from the * hiddenCmdTablePtr. */ hPtr = Tcl_FirstHashEntry(hTablePtr, &search); for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_DeleteCommandFromToken(interp, - (Tcl_Command) Tcl_GetHashValue(hPtr)); + Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); - ckfree((char *) hTablePtr); + ckfree(hTablePtr); } /* @@ -1300,10 +1467,10 @@ DeleteInterpProc( if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - ckfree((char *) dPtr); + ckfree(dPtr); } Tcl_DeleteHashTable(hTablePtr); - ckfree((char *) hTablePtr); + ckfree(hTablePtr); } /* @@ -1311,11 +1478,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); @@ -1325,7 +1492,7 @@ DeleteInterpProc( */ Tcl_FreeResult(interp); - interp->result = NULL; + iPtr->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); @@ -1338,6 +1505,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); } @@ -1363,7 +1536,7 @@ DeleteInterpProc( while (resPtr) { nextResPtr = resPtr->nextPtr; ckfree(resPtr->name); - ckfree((char *) resPtr); + ckfree(resPtr); resPtr = nextResPtr; } @@ -1372,104 +1545,103 @@ DeleteInterpProc( * interpreter. */ - TclDeleteLiteralTable(interp, &(iPtr->literalTable)); + TclDeleteLiteralTable(interp, &iPtr->literalTable); /* * TIP #280 - Release the arrays for ByteCode/Proc extension, and * contents. */ - { - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - int i; + 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); - for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - 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); + procPtr->iPtr = NULL; + if (cfPtr) { + if (cfPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(cfPtr->data.eval.path); } - 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 = (ExtCmdLoc *) 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); + Tcl_DeleteHashTable(&eclPtr->litInfo); - ckfree((char *) eclPtr); - Tcl_DeleteHashEntry(hPtr); - } - Tcl_DeleteHashTable(iPtr->lineBCPtr); - ckfree((char *) iPtr->lineBCPtr); - iPtr->lineBCPtr = NULL; + ckfree(eclPtr); + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(iPtr->lineBCPtr); + ckfree(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 - * don't, cannot know which arguments will be used as scripts and - * which won't. + * 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); } /* @@ -1535,9 +1707,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; } @@ -1559,8 +1732,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; } @@ -1570,8 +1745,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; } @@ -1584,8 +1758,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; } @@ -1686,8 +1862,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; } @@ -1701,27 +1879,29 @@ 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); /* * Check that we have a true global namespace command (enforced by - * Tcl_HideCommand() but let's double check. (If it was not, we would not + * Tcl_HideCommand but let's double check. (If it was not, we would not * really know how to handle it). */ if (cmdPtr->nsPtr != iPtr->globalNsPtr) { /* - * This case is theoritically impossible, we might rather Tcl_Panic() + * This case is theoritically impossible, we might rather Tcl_Panic * 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; } @@ -1738,12 +1918,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. @@ -1887,10 +2079,22 @@ Tcl_CreateCommand( * stuck in an infinite loop). */ - ckfree((char *) Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); } } 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. @@ -1899,7 +2103,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; @@ -1915,6 +2119,7 @@ Tcl_CreateCommand( cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; + cmdPtr->nreProc = NULL; /* * Plug in any existing import references found above. Be sure to update @@ -1981,7 +2186,7 @@ Tcl_CreateObjCommand( Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ ClientData clientData, /* Arbitrary value to pass to object - * function. */ + * function. */ Tcl_CmdDeleteProc *deleteProc) /* If not NULL, gives a function to call when * this command is deleted. */ @@ -2059,10 +2264,22 @@ Tcl_CreateObjCommand( * stuck in an infinite loop). */ - ckfree(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); } } 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. @@ -2070,7 +2287,7 @@ Tcl_CreateObjCommand( TclInvalidateNsCmdLookup(nsPtr); } - cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr = ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -2086,6 +2303,7 @@ Tcl_CreateObjCommand( cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; + cmdPtr->nreProc = NULL; /* * Plug in any existing import references found above. Be sure to update @@ -2143,10 +2361,10 @@ TclInvokeStringCommand( { Command *cmdPtr = clientData; int i, result; - const char **argv = (const char **) + const char **argv = TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); - for (i = 0; i < objc; i++) { + for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; @@ -2155,7 +2373,7 @@ TclInvokeStringCommand( * Invoke the command's string-based Tcl_CmdProc. */ - result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); + result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv); TclStackFree(interp, (void *) argv); return result; @@ -2189,13 +2407,13 @@ TclInvokeObjectCommand( int argc, /* Number of arguments. */ register const char **argv) /* Argument strings. */ { - Command *cmdPtr = (Command *) clientData; + Command *cmdPtr = clientData; Tcl_Obj *objPtr; int i, length, result; - Tcl_Obj **objv = (Tcl_Obj **) + Tcl_Obj **objv = TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *))); - for (i = 0; i < argc; i++) { + for (i = 0; i < argc; i++) { length = strlen(argv[i]); TclNewStringObj(objPtr, argv[i], length); Tcl_IncrRefCount(objPtr); @@ -2206,7 +2424,12 @@ TclInvokeObjectCommand( * Invoke the command's object-based Tcl_ObjCmdProc. */ - result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); + if (cmdPtr->objProc != NULL) { + result = cmdPtr->objProc(cmdPtr->objClientData, interp, argc, objv); + } else { + result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, + cmdPtr->objClientData, argc, objv); + } /* * Move the interpreter's object result to the string result, then reset @@ -2220,7 +2443,7 @@ TclInvokeObjectCommand( * free the objv array if malloc'ed storage was used. */ - for (i = 0; i < argc; i++) { + for (i = 0; i < argc; i++) { objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } @@ -2276,9 +2499,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; @@ -2307,21 +2532,24 @@ 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; } /* * Warning: any changes done in the code here are likely to be needed in - * Tcl_HideCommand() code too (until the common parts are extracted out). + * Tcl_HideCommand code too (until the common parts are extracted out). * - dl */ @@ -2362,6 +2590,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 @@ -2376,7 +2615,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++; @@ -2480,7 +2719,7 @@ Tcl_SetCommandInfoFromToken( { Command *cmdPtr; /* Internal representation of the command */ - if (cmd == (Tcl_Command) NULL) { + if (cmd == NULL) { return 0; } @@ -2494,8 +2733,12 @@ Tcl_SetCommandInfoFromToken( if (infoPtr->objProc == NULL) { cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = cmdPtr; + cmdPtr->nreProc = NULL; } else { - cmdPtr->objProc = infoPtr->objProc; + if (infoPtr->objProc != cmdPtr->objProc) { + cmdPtr->nreProc = NULL; + cmdPtr->objProc = infoPtr->objProc; + } cmdPtr->objClientData = infoPtr->objClientData; } cmdPtr->deleteProc = infoPtr->deleteProc; @@ -2560,7 +2803,7 @@ Tcl_GetCommandInfoFromToken( { Command *cmdPtr; /* Internal representation of the command */ - if (cmd == (Tcl_Command) NULL) { + if (cmd == NULL) { return 0; } @@ -2705,7 +2948,7 @@ Tcl_DeleteCommand( */ cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); - if (cmd == (Tcl_Command) NULL) { + if (cmd == NULL) { return -1; } return Tcl_DeleteCommandFromToken(interp, cmd); @@ -2800,8 +3043,9 @@ Tcl_DeleteCommandFromToken( tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; + if ((--tracePtr->refCount) <= 0) { - ckfree((char *) tracePtr); + ckfree(tracePtr); } tracePtr = nextPtr; } @@ -2835,19 +3079,17 @@ Tcl_DeleteCommandFromToken( * created when a command was imported into a namespace, this client * data will be a pointer to a ImportedCmdData structure describing * the "real" command that this imported command refers to. - */ - - /* + * * If you are getting a crash during the call to deleteProc and * cmdPtr->deleteProc is a pointer to the function free(), the most * likely cause is that your extension allocated memory for the - * clientData argument to Tcl_CreateObjCommand() with the ckalloc() + * clientData argument to Tcl_CreateObjCommand with the ckalloc() * macro and you are now trying to deallocate this memory with free() * instead of ckfree(). You should pass a pointer to your own method * that calls ckfree(). */ - (*cmdPtr->deleteProc)(cmdPtr->deleteData); + cmdPtr->deleteProc(cmdPtr->deleteData); } /* @@ -2856,7 +3098,7 @@ Tcl_DeleteCommandFromToken( * imported commands now. */ - for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; refPtr = nextRefPtr) { nextRefPtr = refPtr->nextPtr; importCmd = (Tcl_Command) refPtr->importedCmdPtr; @@ -2876,11 +3118,10 @@ Tcl_DeleteCommandFromToken( } /* - * Mark the Command structure as no longer valid. This allows - * TclExecuteByteCode to recognize when a Command has logically been - * deleted and a pointer to this Command structure cached in a CmdName - * object is invalid. TclExecuteByteCode will look up the command again in - * the interpreter's command hashtable. + * A number of tests for particular kinds of commands are done by checking + * whether the objProc field holds a known value. Set the field to NULL so + * that such tests won't have false positives when applied to deleted + * commands. */ cmdPtr->objProc = NULL; @@ -2890,14 +3131,31 @@ 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); return 0; } +/* + *---------------------------------------------------------------------- + * + * CallCommandTraces -- + * + * Abstraction of the code to call traces on a command. + * + * Results: + * Currently always NULL. + * + * Side effects: + * Anything; this may recursively evaluate scripts and code exists to do + * just that. + * + *---------------------------------------------------------------------- + */ + static char * CallCommandTraces( Interp *iPtr, /* Interpreter containing command. */ @@ -2968,11 +3226,11 @@ CallCommandTraces( if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK); } - (*tracePtr->traceProc)(tracePtr->clientData, - (Tcl_Interp *) iPtr, oldName, newName, flags); + tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, + oldName, newName, flags); cmdPtr->flags &= ~tracePtr->flags; if ((--tracePtr->refCount) <= 0) { - ckfree((char *) tracePtr); + ckfree(tracePtr); } } @@ -2999,7 +3257,84 @@ CallCommandTraces( Tcl_Release(iPtr); return result; } + +/* + *---------------------------------------------------------------------- + * + * CancelEvalProc -- + * + * Marks this interpreter as being canceled. This causes current + * executions to be unwound as the interpreter enters a state where it + * refuses to execute more commands or handle [catch] or [try], yet the + * interpreter is still able to execute further commands after the + * cancelation is cleared (unlike if it is deleted). + * + * Results: + * The value given for the code argument. + * + * Side effects: + * Transfers a message from the cancelation message to the interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +CancelEvalProc( + ClientData clientData, /* Interp to cancel the script in progress. */ + Tcl_Interp *interp, /* Ignored */ + int code) /* Current return code from command. */ +{ + CancelInfo *cancelInfo = clientData; + Interp *iPtr; + + if (cancelInfo != NULL) { + Tcl_MutexLock(&cancelLock); + iPtr = (Interp *) cancelInfo->interp; + + if (iPtr != NULL) { + /* + * 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. 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. + */ + + TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); + + /* + * Now, we must set the script cancellation flags on all the slave + * interpreters belonging to this one. + */ + + TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, + cancelInfo->flags | CANCELED, 0); + + /* + * Create the result object now so that Tcl_Canceled can avoid + * locking the cancelLock mutex. + */ + if (cancelInfo->result != NULL) { + Tcl_SetStringObj(iPtr->asyncCancelMsg, cancelInfo->result, + cancelInfo->length); + } else { + Tcl_SetObjLength(iPtr->asyncCancelMsg, 0); + } + } + Tcl_MutexUnlock(&cancelLock); + } + + return code; +} + /* *---------------------------------------------------------------------- * @@ -3007,7 +3342,15 @@ CallCommandTraces( * * 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. + * 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. * *---------------------------------------------------------------------- */ @@ -3015,18 +3358,41 @@ CallCommandTraces( static Tcl_Obj * GetCommandSource( Interp *iPtr, - const char *command, - int numChars, int objc, - Tcl_Obj *const objv[]) + Tcl_Obj *const objv[], + int lookup) { - if (!command) { - return Tcl_NewListObj(objc, objv); - } - if (command == (char *) -1) { - command = TclGetSrcInfoForCmd(iPtr, &numChars); + 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); + } } - return Tcl_NewStringObj(command, numChars); + Tcl_IncrRefCount(objPtr); + return objPtr; } /* @@ -3057,7 +3423,7 @@ TclCleanupCommand( { cmdPtr->refCount--; if (cmdPtr->refCount <= 0) { - ckfree((char *) cmdPtr); + ckfree(cmdPtr); } } @@ -3098,18 +3464,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), @@ -3161,10 +3525,9 @@ 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() ? */ + /* TODO: Convert to TclGetNumberFromObj? */ valuePtr = objv[j]; result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); #ifdef ACCEPT_NAN @@ -3179,9 +3542,10 @@ OldMathFuncProc( */ Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument to math function didn't have numeric value",-1)); + "argument to math function didn't have numeric value", + -1)); TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); - ckfree((char *)args); + ckfree(args); return TCL_ERROR; } @@ -3195,12 +3559,12 @@ OldMathFuncProc( args[k].type = dataPtr->argTypes[k]; switch (args[k].type) { case TCL_EITHER: - if (Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue)) + if (Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue) == TCL_OK) { args[k].type = TCL_INT; break; } - if (Tcl_GetWideIntFromObj(interp, valuePtr, &(args[k].wideValue)) + if (Tcl_GetWideIntFromObj(interp, valuePtr, &args[k].wideValue) == TCL_OK) { args[k].type = TCL_WIDE_INT; break; @@ -3212,21 +3576,21 @@ OldMathFuncProc( args[k].doubleValue = d; break; case TCL_INT: - if (ExprIntFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) { - ckfree((char *)args); + if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { + ckfree(args); return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); - Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue)); + Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue); Tcl_ResetResult(interp); break; case TCL_WIDE_INT: - if (ExprWideFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) { - ckfree((char *)args); + if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { + ckfree(args); return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); - Tcl_GetWideIntFromObj(NULL, valuePtr, &(args[k].wideValue)); + Tcl_GetWideIntFromObj(NULL, valuePtr, &args[k].wideValue); Tcl_ResetResult(interp); break; } @@ -3237,8 +3601,8 @@ OldMathFuncProc( */ errno = 0; - result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult); - ckfree((char *)args); + result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult); + ckfree(args); if (result != TCL_OK) { return result; } @@ -3277,12 +3641,12 @@ OldMathFuncProc( static void OldMathFuncDeleteProc( - ClientData clientData) + ClientData clientData) { OldMathFuncData *dataPtr = clientData; - ckfree((void *) dataPtr->argTypes); - ckfree((void *) dataPtr); + ckfree(dataPtr->argTypes); + ckfree(dataPtr); } /* @@ -3336,12 +3700,9 @@ 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; *procPtr = NULL; @@ -3442,9 +3803,6 @@ int TclInterpReady( Tcl_Interp *interp) { -#if !defined(TCL_NO_STACK_CHECK) - int localInt; /* used for checking the stack */ -#endif register Interp *iPtr = (Interp *) interp; /* @@ -3459,145 +3817,407 @@ TclInterpReady( */ if (iPtr->flags & DELETED) { - Tcl_ResetResult(interp); - 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) { + 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; + } + /* * Check depth of nested calls to Tcl_Eval: if this gets too large, it's * probably because of an infinite loop somewhere. */ - if (((iPtr->numLevels) <= iPtr->maxNestingDepth) - && CheckCStack(iPtr, &localInt)) { + if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) { return TCL_OK; } - if (!CheckCStack(iPtr, &localInt)) { - Tcl_AppendResult(interp, - "out of stack space (infinite loop?)", NULL); - } else { - 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; +} + +/* + *---------------------------------------------------------------------- + * + * TclResetCancellation -- + * + * Reset the script cancellation flags if the nesting level + * (iPtr->numLevels) for the interp is zero or argument force is + * non-zero. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The script cancellation flags for the interp may be reset. + * + *---------------------------------------------------------------------- + */ + +int +TclResetCancellation( + Tcl_Interp *interp, + int force) +{ + register Interp *iPtr = (Interp *) interp; + + if (iPtr == NULL) { + return TCL_ERROR; + } + + if (force || (iPtr->numLevels == 0)) { + TclUnsetCancelFlags(iPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Canceled -- + * + * Check if the script in progress has been canceled, i.e., + * Tcl_CancelEval was called for this interpreter or any of its master + * interpreters. + * + * Results: + * The return value is TCL_OK if the script evaluation has not been + * canceled, TCL_ERROR otherwise. + * + * If "flags" contains TCL_LEAVE_ERR_MSG, an error message is returned in + * the interpreter's result object. Otherwise, the interpreter's result + * object is left unchanged. If "flags" contains TCL_CANCEL_UNWIND, + * TCL_ERROR will only be returned if the script evaluation is being + * completely unwound. + * + * Side effects: + * The CANCELED flag for the interp will be reset if it is set. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Canceled( + Tcl_Interp *interp, + int flags) +{ + register Interp *iPtr = (Interp *) interp; + + /* + * Has the current script in progress for this interpreter been canceled + * or is the stack being unwound due to the previous script cancellation? + */ + + if (!TclCanceled(iPtr)) { + return TCL_OK; + } + + /* + * 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; + + /* + * 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. + */ + + if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) { + return TCL_OK; } + + /* + * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the + * interp's result; otherwise, we leave it alone. + */ + + if (flags & TCL_LEAVE_ERR_MSG) { + const char *id, *message = NULL; + int length; + + /* + * Setup errorCode variables so that we can differentiate between + * being canceled and unwound. + */ + + if (iPtr->asyncCancelMsg != NULL) { + message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); + } else { + length = 0; + } + + if (iPtr->flags & TCL_CANCEL_UNWIND) { + id = "IUNWIND"; + if (length == 0) { + message = "eval unwound"; + } + } else { + id = "ICANCEL"; + if (length == 0) { + message = "eval canceled"; + } + } + + Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1)); + Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL); + } + + /* + * 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; } /* *---------------------------------------------------------------------- * - * TclEvalObjvInternal + * Tcl_CancelEval -- * - * This function evaluates a Tcl command that has already been parsed - * into words, with one Tcl_Obj holding each word. The caller is - * responsible for managing the iPtr->numLevels. + * This function schedules the cancellation of the current script in the + * given interpreter. + * + * Results: + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR. Since the interp may belong to a different thread, no error + * message can be left in the interp's result. * - * TclEvalObjvInternal is the backend for Tcl_EvalObjv, the bytecode - * engine also calls it directly. + * Side effects: + * The script in progress in the specified interpreter will be canceled + * with TCL_ERROR after asynchronous handlers are invoked at the next + * Tcl_Canceled check. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CancelEval( + Tcl_Interp *interp, /* Interpreter in which to cancel the + * script. */ + Tcl_Obj *resultObjPtr, /* The script cancellation error message or + * NULL for a default error message. */ + ClientData clientData, /* Passed to CancelEvalProc. */ + int flags) /* Collection of OR-ed bits that control + * the cancellation of the script. Only + * TCL_CANCEL_UNWIND is currently + * supported. */ +{ + Tcl_HashEntry *hPtr; + CancelInfo *cancelInfo; + int code = TCL_ERROR; + const char *result; + + if (interp == NULL) { + return TCL_ERROR; + } + + Tcl_MutexLock(&cancelLock); + if (cancelTableInitialized != 1) { + /* + * No CancelInfo hash table (Tcl_CreateInterp has never been called?) + */ + + goto done; + } + hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp); + if (hPtr == NULL) { + /* + * No CancelInfo record for this interpreter. + */ + + goto done; + } + cancelInfo = Tcl_GetHashValue(hPtr); + + /* + * Populate information needed by the interpreter thread to fulfill the + * cancellation request. Currently, clientData is ignored. If the + * TCL_CANCEL_UNWIND flags bit is set, the script in progress is not + * allowed to catch the script cancellation because the evaluation stack + * for the interp is completely unwound. + */ + + if (resultObjPtr != NULL) { + result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); + cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length); + memcpy(cancelInfo->result, result, (size_t) cancelInfo->length); + TclDecrRefCount(resultObjPtr); /* Discard their result object. */ + } else { + cancelInfo->result = NULL; + cancelInfo->length = 0; + } + cancelInfo->clientData = clientData; + cancelInfo->flags = flags; + Tcl_AsyncMark(cancelInfo->async); + code = TCL_OK; + + done: + Tcl_MutexUnlock(&cancelLock); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InterpActive -- + * + * Returns non-zero if the specified interpreter is in use, i.e. if there + * is an evaluation currently active in the interpreter. + * + * Results: + * See above. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InterpActive( + Tcl_Interp *interp) +{ + return ((Interp *) interp)->numLevels > 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObjv -- + * + * This function evaluates a Tcl command that has already been parsed + * into words, with one Tcl_Obj holding each word. * * Results: * The return value is a standard Tcl completion code such as TCL_OK or - * TCL_ERROR. A result or error message is left in interp's result. If an - * error occurs, this function does NOT add any information to the - * errorInfo variable. + * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: - * Depends on the command. + * Always pushes a callback. Other side effects depend on the command. * *---------------------------------------------------------------------- */ int -TclEvalObjvInternal( +Tcl_EvalObjv( Tcl_Interp *interp, /* Interpreter in which to evaluate the * command. Also used for error reporting. */ int objc, /* Number of words in command. */ Tcl_Obj *const objv[], /* An array of pointers to objects that are * the words that make up the command. */ - const char *command, /* Points to the beginning of the string - * representation of the command; this is used - * for traces. NULL if the string - * representation of the command is unknown is - * to be generated from (objc,objv), -1 if it - * is to be generated from bytecode - * source. This is only needed the traces. */ - int length, /* Number of bytes in command; if -1, all - * characters up to the first null byte are - * used. */ int flags) /* Collection of OR-ed bits that control the * evaluation of the script. Only - * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are - * currently supported. */ + * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and + * TCL_EVAL_NOERR are currently supported. */ +{ + int result; + NRE_callback *rootPtr = TOP_CB(interp); + + result = TclNREvalObjv(interp, objc, objv, flags, NULL); + return TclNRRunCallbacks(interp, result, rootPtr); +} + +int +TclNREvalObjv( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * command. Also used for error reporting. */ + int objc, /* Number of words in command. */ + Tcl_Obj *const objv[], /* An array of pointers to objects that are + * the words that make up the command. */ + int flags, /* Collection of OR-ed bits that control the + * evaluation of the script. Only + * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and + * TCL_EVAL_NOERR are currently supported. */ + Command *cmdPtr) /* NULL if the Command is to be looked up + * here, otherwise the pointer to the + * requested Command struct to be invoked. */ { - Command *cmdPtr; Interp *iPtr = (Interp *) interp; - Tcl_Obj **newObjv; - int i; - CallFrame *savedVarFramePtr = NULL; - CallFrame *varFramePtr = iPtr->varFramePtr; - int code = TCL_OK; - int traceCode = TCL_OK; - int checkTraces = 1, traced; - Namespace *savedNsPtr = NULL; + int result; Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Tcl_Obj *commandPtr = NULL; + Command **cmdPtrPtr; - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } - - if (objc == 0) { - return TCL_OK; - } + iPtr->lookupNsPtr = NULL; /* - * If any execution traces rename or delete the current command, we may - * need (at most) two passes here. + * 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. */ - reparseBecauseOfTraces: + if (iPtr->evalFlags & TCL_EVAL_REDIRECT) { + TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), INT2PTR(objc), objv); + iPtr->evalFlags &= ~TCL_EVAL_REDIRECT; + } else { + TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv); + } + 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; + } /* - * Configure evaluation context to match the requested flags. + * Push records for task to be done on return, in INVERSE order. First, if + * needed, the exception handlers (as they should happen last). */ - if (flags) { - if (flags & TCL_EVAL_INVOKE) { - savedNsPtr = varFramePtr->nsPtr; - if (lookupNsPtr) { - varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; - } else { - varFramePtr->nsPtr = iPtr->globalNsPtr; - } - } else if ((flags & TCL_EVAL_GLOBAL) - && (varFramePtr != iPtr->rootFramePtr) && !savedVarFramePtr) { - varFramePtr = iPtr->rootFramePtr; - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = varFramePtr; - } + if (!(flags & TCL_EVAL_NOERR)) { + TEOV_PushExceptionHandlers(interp, objc, objv, flags); } /* - * Find the function to execute this command. If there isn't one, then see - * if there is an unknown command handler registered for this namespace. - * If so, create a new word array with the handler as the first words and - * the original command words as arguments. Then call ourselves - * recursively to execute it. + * Configure evaluation context to match the requested flags. */ - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if (!cmdPtr) { - goto notFound; - } + if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { + if (!lookupNsPtr) { + lookupNsPtr = iPtr->globalNsPtr; + } + } else { + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } - if (savedNsPtr) { - varFramePtr->nsPtr = savedNsPtr; - } else if (iPtr->ensembleRewrite.sourceObjs) { /* * TCL_EVAL_INVOKE was not set: clear rewrite rules */ @@ -3606,60 +4226,43 @@ TclEvalObjvInternal( } /* - * Call trace functions if needed. + * Lookup the command */ - traced = (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)); - if (traced && checkTraces) { - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } - /* - * Insure that we have a correct nul-terminated command string for the - * trace code. - */ + iPtr->cmdCount++; + if (TclLimitExceeded(iPtr->limit)) { + return TCL_ERROR; + } - commandPtr = GetCommandSource(iPtr, command, length, objc, objv); - command = TclGetStringFromObj(commandPtr, &length); + /* + * Found a command! The real work begins now ... + */ + commandFound: + if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { /* - * 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. + * Call enter traces. They will schedule a call to the leave traces if + * necessary. */ - cmdPtr->refCount++; - if (iPtr->tracePtr && (traceCode == TCL_OK)) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - TclCleanupCommandMacro(cmdPtr); - - /* - * If the traces modified/deleted the command or any existing traces, - * they will update the command's epoch. When that happens, set - * checkTraces is set to 0 to prevent the re-calling of traces (and - * any possible infinite loop) and we go back to re-find the command - * implementation. - */ - - if (cmdEpoch != newEpoch) { - checkTraces = 0; - if (commandPtr) { - Tcl_DecrRefCount(commandPtr); - } - goto reparseBecauseOfTraces; + if (result != TCL_OK) { + return result; } } + #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { - char *a[10]; + const char *a[10]; int i = 0; while (i < 10) { @@ -3670,172 +4273,341 @@ TclEvalObjvInternal( } if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); - char *a[4]; int i[2]; + const char *a[6]; int i[2]; TclDTraceInfo(info, a, i); - TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); + 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()) { + TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); + } + if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { + TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, + (Tcl_Obj **)(objv + 1)); + } #endif /* USE_DTRACE */ - /* - * Finally, invoke the command's Tcl_ObjCmdProc. + * 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++; - iPtr->cmdCount++; - if (code == TCL_OK && traceCode == TCL_OK - && !TclLimitExceeded(iPtr->limit)) { - if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } - code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); - if (TCL_DTRACE_CMD_RETURN_ENABLED()) { - TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code); - } - } - - if (TclAsyncReady(iPtr)) { - code = Tcl_AsyncInvoke(interp, code); - } - if (code == TCL_OK && TclLimitReady(iPtr->limit)) { - code = Tcl_LimitCheck(interp); - } /* - * Call 'leave' command traces + * Find the objProc to call: nreProc if available, objProc otherwise. Push + * a callback to do the actual running. */ - if (traced) { - if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); - } - if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); - } - } - - /* - * If one of the trace invocation resulted in error, then change the - * result code accordingly. Note, that the interp->result should - * already be set correctly by the call to TraceExecutionProc. - */ - - if (traceCode != TCL_OK) { - code = traceCode; - } - if (commandPtr) { - Tcl_DecrRefCount(commandPtr); - } + if (cmdPtr->nreProc) { + TclNRAddCallback(interp, NRRunObjProc, cmdPtr, + INT2PTR(objc), (ClientData) objv, NULL); + return TCL_OK; + } else { + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); } +} - /* - * Decrement the reference count of cmdPtr and deallocate it if it has - * dropped to zero. - */ +void +TclPushTailcallPoint( + Tcl_Interp *interp) +{ + TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); + ((Interp *) interp)->numLevels++; +} - TclCleanupCommandMacro(cmdPtr); +int +TclNRRunCallbacks( + Tcl_Interp *interp, + int result, + struct NRE_callback *rootPtr) + /* All callbacks down to rootPtr not inclusive + * are to be run. */ +{ + Interp *iPtr = (Interp *) interp; + NRE_callback *callbackPtr; + Tcl_NRPostProc *procPtr; /* * If the interpreter has a non-empty string result, the result object is * either empty or stale because some function set interp->result * directly. If so, move the string result to the result object, then * reset the string result. + * + * This only needs to be done for the first item in the list: all other + * are for NR function calls, and those are Tcl_Obj based. */ if (*(iPtr->result) != 0) { (void) Tcl_GetObjResult(interp); } -#ifdef USE_DTRACE - if (TCL_DTRACE_CMD_RESULT_ENABLED()) { - Tcl_Obj *r; + while (TOP_CB(interp) != rootPtr) { + callbackPtr = TOP_CB(interp); + procPtr = callbackPtr->procPtr; + TOP_CB(interp) = callbackPtr->nextPtr; + result = procPtr(callbackPtr->data, interp, result); + TCLNR_FREE(interp, callbackPtr); + } + return result; +} - r = Tcl_GetObjResult(interp); - TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r),r); +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); } -#endif /* USE_DTRACE */ + ((Interp *)interp)->numLevels--; - done: - if (savedVarFramePtr) { - iPtr->varFramePtr = savedVarFramePtr; + /* OPT ?? + * Do not interrupt a series of cleanups with async or limit checks: + * just check at the end? + */ + + if (TclAsyncReady(iPtr)) { + result = Tcl_AsyncInvoke(interp, result); + } + if ((result == TCL_OK) && TclCanceled(iPtr)) { + result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG); + } + if (result == TCL_OK && TclLimitReady(iPtr->limit)) { + result = Tcl_LimitCheck(interp); } - return code; - notFound: - { - Namespace *currNsPtr = NULL; /* Used to check for and invoke any - * registered unknown command handler - * for the current namespace (TIP - * 181). */ - int newObjc, handlerObjc; - Tcl_Obj **handlerObjv; - - currNsPtr = varFramePtr->nsPtr; - if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) { - currNsPtr = iPtr->globalNsPtr; - if (currNsPtr == NULL) { - Tcl_Panic("TclEvalObjvInternal: NULL global namespace pointer"); - } - } + return result; +} - /* - * Check to see if the resolution namespace has lost its unknown - * handler. If so, reset it to "::unknown". - */ +static int +NRRunObjProc( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + /* OPT: do not call? */ - if (currNsPtr->unknownHandlerPtr == NULL) { - TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); - Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); - } + Command* cmdPtr = data[0]; + int objc = PTR2INT(data[1]); + Tcl_Obj **objv = data[2]; + + return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); +} + +/* + *---------------------------------------------------------------------- + * + * TEOV_Exception - + * TEOV_LookupCmdFromObj - + * TEOV_RunEnterTraces - + * TEOV_RunLeaveTraces - + * TEOV_NotFound - + * + * These are helper functions for Tcl_EvalObjv. + * + *---------------------------------------------------------------------- + */ + +static void +TEOV_PushExceptionHandlers( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[], + int flags) +{ + Interp *iPtr = (Interp *) interp; + + /* + * If any error processing is necessary, push the appropriate records. + * Note that we have to push them in the inverse order: first the one that + * has to run last. + */ + + if (!(flags & TCL_EVAL_INVOKE)) { /* - * Get the list of words for the unknown handler and allocate enough - * space to hold both the handler prefix and all words of the command - * invokation itself. + * Error messages */ - Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, - &handlerObjc, &handlerObjv); - newObjc = objc + handlerObjc; - newObjv = (Tcl_Obj **) TclStackAlloc(interp, - (int) sizeof(Tcl_Obj *) * newObjc); + TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc), + (ClientData) objv, NULL, NULL); + } + if (iPtr->numLevels == 1) { /* - * Copy command prefix from unknown handler and add on the real - * command's full argument list. Note that we only use memcpy() once - * because we have to increment the reference count of all the handler - * arguments anyway. + * No CONTINUE or BREAK at level 0, manage RETURN */ - for (i = 0; i < handlerObjc; ++i) { - newObjv[i] = handlerObjv[i]; - Tcl_IncrRefCount(newObjv[i]); + TclNRAddCallback(interp, TEOV_Exception, INT2PTR(iPtr->evalFlags), + NULL, NULL, NULL); + } +} + +static void +TEOV_SwitchVarFrame( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + /* + * Change the varFrame to be the rootVarFrame, and push a record to + * restore things at the end. + */ + + TclNRAddCallback(interp, TEOV_RestoreVarFrame, iPtr->varFramePtr, NULL, + NULL, NULL); + iPtr->varFramePtr = iPtr->rootFramePtr; +} + +static int +TEOV_RestoreVarFrame( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + ((Interp *) interp)->varFramePtr = data[0]; + return result; +} + +static int +TEOV_Exception( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + int allowExceptions = (PTR2INT(data[0]) & TCL_ALLOW_EXCEPTIONS); + + if (result != TCL_OK) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); } - memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); + if ((result != TCL_ERROR) && !allowExceptions) { + ProcessUnexpectedResult(interp, result); + result = TCL_ERROR; + } + } + + /* + * We are returning to level 0, so should process TclResetCancellation. As + * numLevels has not *yet* been decreased, do not call it: do the thing + * here directly. + */ + TclUnsetCancelFlags(iPtr); + return result; +} + +static int +TEOV_Error( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *listPtr; + const char *cmdString; + int cmdLen; + int objc = PTR2INT(data[0]); + Tcl_Obj **objv = data[1]; + + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){ /* - * Look up and invoke the handler (by recursive call to this - * function). If there is no handler at all, instead of doing the - * recursive call we just generate a generic error message; it would - * be an infinite-recursion nightmare otherwise. + * If there was an error, a command string will be needed for the + * error log: get it out of the itemPtr. The details depend on the + * type. */ - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); - if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[0]), "\"", NULL); - code = TCL_ERROR; - } else { - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, newObjc, newObjv, command, - length, 0); - iPtr->numLevels--; + listPtr = Tcl_NewListObj(objc, objv); + cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); + Tcl_DecrRefCount(listPtr); + } + iPtr->flags &= ~ERR_ALREADY_LOGGED; + return result; +} + +static int +TEOV_NotFound( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[], + Namespace *lookupNsPtr) +{ + Command * cmdPtr; + Interp *iPtr = (Interp *) interp; + int i, newObjc, handlerObjc; + Tcl_Obj **newObjv, **handlerObjv; + CallFrame *varFramePtr = iPtr->varFramePtr; + Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered + * unknown command handler for the current + * namespace (TIP 181). */ + Namespace *savedNsPtr = NULL; + + currNsPtr = varFramePtr->nsPtr; + if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) { + currNsPtr = iPtr->globalNsPtr; + if (currNsPtr == NULL) { + Tcl_Panic("Tcl_EvalObjv: NULL global namespace pointer"); } + } + + /* + * Check to see if the resolution namespace has lost its unknown handler. + * If so, reset it to "::unknown". + */ + + if (currNsPtr->unknownHandlerPtr == NULL) { + TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); + Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); + } + + /* + * Get the list of words for the unknown handler and allocate enough space + * to hold both the handler prefix and all words of the command invokation + * itself. + */ + + Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, + &handlerObjc, &handlerObjv); + newObjc = objc + handlerObjc; + newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc); + + /* + * Copy command prefix from unknown handler and add on the real command's + * full argument list. Note that we only use memcpy() once because we have + * to increment the reference count of all the handler arguments anyway. + */ + + for (i = 0; i < handlerObjc; ++i) { + newObjv[i] = handlerObjv[i]; + Tcl_IncrRefCount(newObjv[i]); + } + memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); + + /* + * Look up and invoke the handler (by recursive call to this function). If + * there is no handler at all, instead of doing the recursive call we just + * generate a generic error message; it would be an infinite-recursion + * nightmare otherwise. + * + * In this case we worry a bit less about recursion for now, and call the + * "blocking" interface. + */ + + cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr); + if (cmdPtr == 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 @@ -3846,89 +4618,174 @@ TclEvalObjvInternal( Tcl_DecrRefCount(newObjv[i]); } TclStackFree(interp, newObjv); - if (savedNsPtr) { - varFramePtr->nsPtr = savedNsPtr; - } - goto done; + return TCL_ERROR; } + + if (lookupNsPtr) { + savedNsPtr = varFramePtr->nsPtr; + varFramePtr->nsPtr = lookupNsPtr; + } + TclNRDeferCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc), + newObjv, savedNsPtr, NULL); + iPtr->evalFlags |= TCL_EVAL_REDIRECT; + return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL); } - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalObjv -- - * - * This function evaluates a Tcl command that has already been parsed - * into words, with one Tcl_Obj holding each word. - * - * Results: - * The return value is a standard Tcl completion code such as TCL_OK or - * TCL_ERROR. A result or error message is left in interp's result. - * - * Side effects: - * Depends on the command. - * - *---------------------------------------------------------------------- - */ -int -Tcl_EvalObjv( - Tcl_Interp *interp, /* Interpreter in which to evaluate the - * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ - Tcl_Obj *const objv[], /* An array of pointers to objects that are - * the words that make up the command. */ - int flags) /* Collection of OR-ed bits that control the - * evaluation of the script. Only - * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are - * currently supported. */ +static int +TEOV_NotFoundCallback( + ClientData data[], + Tcl_Interp *interp, + int result) { Interp *iPtr = (Interp *) interp; - int code = TCL_OK; - int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + int objc = PTR2INT(data[0]); + Tcl_Obj **objv = data[1]; + Namespace *savedNsPtr = data[2]; - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objc, objv, NULL, 0, flags); - iPtr->numLevels--; + int i; - if (code == TCL_OK) { - return code; - } else { + if (savedNsPtr) { + iPtr->varFramePtr->nsPtr = savedNsPtr; + } + + /* + * Release any resources we locked and allocated during the handler call. + */ + + for (i = 0; i < objc; ++i) { + Tcl_DecrRefCount(objv[i]); + } + TclStackFree(interp, objv); + + return result; +} + +static int +TEOV_RunEnterTraces( + Tcl_Interp *interp, + Command **cmdPtrPtr, + int objc, + Tcl_Obj *const objv[], + Namespace *lookupNsPtr) +{ + 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); + + /* + * 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. + */ + + cmdPtr->refCount++; + if (iPtr->tracePtr) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + 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 (cmdPtr) { /* - * If we are again at the top level, process any unusual return code - * returned by the evaluated code. + * Command was found: push a record to schedule the leave traces. */ - if (iPtr->numLevels == 0) { - if (code == TCL_RETURN) { - code = TclUpdateReturnInfo(iPtr); - } - if ((code != TCL_ERROR) && !allowExceptions) { - ProcessUnexpectedResult(interp, code); - code = TCL_ERROR; - } - } + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode), + commandPtr, cmdPtr, NULL); + cmdPtr->refCount++; + } else { + Tcl_DecrRefCount(commandPtr); + } + return traceCode; +} - if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { - /* - * If there was an error, a command string will be needed for the - * error log: generate it now. Do not worry too much about doing - * it expensively. - */ +static int +TEOV_RunLeaveTraces( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + const char *command; + int length, objc; + Tcl_Obj **objv; + int traceCode = PTR2INT(data[0]); + Tcl_Obj *commandPtr = data[1]; + Command *cmdPtr = data[2]; - Tcl_Obj *listPtr; - char *cmdString; - int cmdLen; + command = Tcl_GetStringFromObj(commandPtr, &length); + if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) { + Tcl_Panic("Who messed with commandPtr?"); + } - listPtr = Tcl_NewListObj(objc, objv); - cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); - Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); - Tcl_DecrRefCount(listPtr); + if (!(cmdPtr->flags & CMD_IS_DELETED)) { + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + } + Tcl_DecrRefCount(commandPtr); + + /* + * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. + * Prevent that by resetting the cmdPtr field and dealing right here with + * cmdPtr->refCount. + */ + + TclCleanupCommandMacro(cmdPtr); + + if (traceCode != TCL_OK) { + return traceCode; + } + return result; +} - return code; +static inline Command * +TEOV_LookupCmdFromObj( + Tcl_Interp *interp, + Tcl_Obj *namePtr, + Namespace *lookupNsPtr) +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr; + Namespace *savedNsPtr = iPtr->varFramePtr->nsPtr; + + if (lookupNsPtr) { + iPtr->varFramePtr->nsPtr = lookupNsPtr; + iPtr->lookupNsPtr = NULL; } + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); + iPtr->varFramePtr->nsPtr = savedNsPtr; + return cmdPtr; } /* @@ -3962,7 +4819,7 @@ Tcl_EvalTokensStandard( * Must be at least 1. */ { return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, - NULL, NULL); + NULL, NULL); } /* @@ -4046,7 +4903,7 @@ Tcl_EvalEx( * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ { - return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script); + return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script); } int @@ -4061,23 +4918,23 @@ TclEvalEx( * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ 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 - * TclSubstTokens(), to properly handle - * [...]-nested commands. The 'outerScript' - * refers to the most-outer script containing the - * embedded command, which is refered to by - * 'script'. The 'clNextOuter' refers to the - * current entry in the table of continuation - * lines in this "master script", and the - * character offsets are relative to the - * 'outerScript' as well. - * - * If outerScript == script, then this call is - * for the outer-most script/command. See - * Tcl_EvalEx() and TclEvalObjEx() for places - * generating arguments for which this is true. - */ + int *clNextOuter, /* Information about an outer context for */ + const char *outerScript) /* continuation line data. This is set only in + * TclSubstTokens(), to properly handle + * [...]-nested commands. The 'outerScript' + * refers to the most-outer script containing + * the embedded command, which is refered to + * by 'script'. The 'clNextOuter' refers to + * the current entry in the table of + * continuation lines in this "master script", + * and the character offsets are relative to + * the 'outerScript' as well. + * + * If outerScript == script, then this call is + * for the outer-most script/command. See + * Tcl_EvalEx() and TclEvalObjEx() for places + * generating arguments for which this is + * true. */ { Interp *iPtr = (Interp *) interp; const char *p, *next; @@ -4095,25 +4952,21 @@ TclEvalEx( * state has been allocated while evaluating * the script, so that it can be freed * properly if an error occurs. */ - Tcl_Parse *parsePtr = (Tcl_Parse *) - TclStackAlloc(interp, sizeof(Tcl_Parse)); - CmdFrame *eeFramePtr = (CmdFrame *) - TclStackAlloc(interp, sizeof(CmdFrame)); - Tcl_Obj **stackObjArray = (Tcl_Obj **) + Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + CmdFrame *eeFramePtr = TclStackAlloc(interp, sizeof(CmdFrame)); + Tcl_Obj **stackObjArray = TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *)); - int *expandStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int)); - int *linesStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int)); + int *expandStack = TclStackAlloc(interp, minObjs * sizeof(int)); + int *linesStack = TclStackAlloc(interp, minObjs * sizeof(int)); /* TIP #280 Structures for tracking of command * locations. */ - /* - * Pointer for the tracking of invisible continuation lines. Initialized - * only if the caller gave us a table of locations to track, via - * scriptCLLocPtr. It always refers to the table entry holding the - * location of the next invisible continuation line to look for, while - * parsing the script. - */ - - int* clNext = NULL; + int *clNext = NULL; /* Pointer for the tracking of invisible + * continuation lines. Initialized only if the + * caller gave us a table of locations to + * track, via scriptCLLocPtr. It always refers + * to the table entry holding the location of + * the next invisible continuation line to + * look for, while parsing the script. */ if (iPtr->scriptCLLocPtr) { if (clNextOuter) { @@ -4155,6 +5008,14 @@ TclEvalEx( * 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; + + iPtr->cmdFramePtr = eeFramePtr; if (iPtr->evalFlags & TCL_EVAL_CTX) { /* * Path information comes out of the context. @@ -4184,6 +5045,7 @@ TclEvalEx( /* * Error message in the interp result. */ + code = TCL_ERROR; goto error; } @@ -4201,12 +5063,6 @@ TclEvalEx( eeFramePtr->data.eval.path = NULL; } - eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; - eeFramePtr->framePtr = iPtr->framePtr; - eeFramePtr->nextPtr = iPtr->cmdFramePtr; - eeFramePtr->nline = 0; - eeFramePtr->line = NULL; - iPtr->evalFlags = 0; do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { @@ -4221,8 +5077,8 @@ TclEvalEx( */ TclAdvanceLines(&line, p, parsePtr->commandStart); - TclAdvanceContinuations (&line, &clNext, - parsePtr->commandStart - outerScript); + TclAdvanceContinuations(&line, &clNext, + parsePtr->commandStart - outerScript); gotParse = 1; if (parsePtr->numWords > 0) { @@ -4233,27 +5089,26 @@ TclEvalEx( * per-command parsing. */ - int wordLine = line; + int wordLine = line; const char *wordStart = parsePtr->commandStart; - int* wordCLNext = clNext; + int *wordCLNext = clNext; + unsigned int objectsNeeded = 0; + unsigned int numWords = parsePtr->numWords; /* * Generate an array of objects for the words of the command. */ - unsigned int objectsNeeded = 0; - unsigned int numWords = parsePtr->numWords; - 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; lines = lineSpace; + iPtr->cmdFramePtr = eeFramePtr->nextPtr; for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr; objectsUsed < numWords; objectsUsed++, tokenPtr += tokenPtr->numComponents+1) { @@ -4266,8 +5121,8 @@ TclEvalEx( */ TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); - TclAdvanceContinuations (&wordLine, &wordCLNext, - tokenPtr->start - outerScript); + TclAdvanceContinuations(&wordLine, &wordCLNext, + tokenPtr->start - outerScript); wordStart = tokenPtr->start; lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) @@ -4279,12 +5134,12 @@ TclEvalEx( code = TclSubstTokens(interp, tokenPtr+1, tokenPtr->numComponents, NULL, wordLine, - wordCLNext, outerScript); + wordCLNext, outerScript); iPtr->evalFlags = 0; if (code != TCL_OK) { - goto error; + break; } objv[objectsUsed] = Tcl_GetObjResult(interp); Tcl_IncrRefCount(objv[objectsUsed]); @@ -4301,7 +5156,7 @@ TclEvalEx( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (expanding word %d)", objectsUsed)); Tcl_DecrRefCount(objv[objectsUsed]); - goto error; + break; } expandRequested = 1; expand[objectsUsed] = 1; @@ -4313,10 +5168,14 @@ TclEvalEx( } if (wordCLNext) { - TclContinuationsEnterDerived (objv[objectsUsed], - wordStart - outerScript, wordCLNext); + TclContinuationsEnterDerived(objv[objectsUsed], + wordStart - outerScript, wordCLNext); } } /* for loop */ + iPtr->cmdFramePtr = eeFramePtr; + if (code != TCL_OK) { + goto error; + } if (expandRequested) { /* * Some word expansion was requested. Check for objv resize. @@ -4327,11 +5186,10 @@ TclEvalEx( int wordIdx = numWords; int objIdx = objectsNeeded - 1; - if ((numWords > minObjs) || (objectsNeeded > minObjs)) { - objv = objvSpace = (Tcl_Obj **) + if ((numWords > minObjs) || (objectsNeeded > minObjs)) { + objv = objvSpace = ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = (int *) - ckalloc(objectsNeeded * sizeof(int)); + lines = lineSpace = ckalloc(objectsNeeded * sizeof(int)); } objectsUsed = 0; @@ -4358,10 +5216,10 @@ TclEvalEx( objv += objIdx+1; if (copy != stackObjArray) { - ckfree((char *) copy); + ckfree(copy); } if (lcopy != linesStack) { - ckfree((char *) lcopy); + ckfree(lcopy); } } @@ -4386,14 +5244,9 @@ TclEvalEx( eeFramePtr->nline = objectsUsed; eeFramePtr->line = lines; - TclArgumentEnter (interp, objv, objectsUsed, eeFramePtr); - iPtr->cmdFramePtr = eeFramePtr; - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objectsUsed, objv, - parsePtr->commandStart, parsePtr->commandSize, 0); - iPtr->numLevels--; - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; - TclArgumentRelease (interp, objv, objectsUsed); + TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); + code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR); + TclArgumentRelease(interp, objv, objectsUsed); eeFramePtr->line = NULL; eeFramePtr->nline = 0; @@ -4406,9 +5259,9 @@ TclEvalEx( } objectsUsed = 0; if (objvSpace != stackObjArray) { - ckfree((char *) objvSpace); + ckfree(objvSpace); objvSpace = stackObjArray; - ckfree((char *) lineSpace); + ckfree(lineSpace); lineSpace = linesStack; } @@ -4418,7 +5271,7 @@ TclEvalEx( */ if (expand != expandStack) { - ckfree((char *) expand); + ckfree(expand); expand = expandStack; } } @@ -4483,11 +5336,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; @@ -4496,6 +5349,7 @@ TclEvalEx( * TIP #280. Release the local CmdFrame, and its contents. */ + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; if (eeFramePtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eeFramePtr->data.eval.path); } @@ -4562,29 +5416,31 @@ TclAdvanceLines( */ void -TclAdvanceContinuations (line,clNextPtrPtr,loc) - int* line; - int** clNextPtrPtr; - int loc; +TclAdvanceContinuations( + int *line, + int **clNextPtrPtr, + int loc) { /* - * Track the invisible continuation lines embedded in a script, if - * any. Here they are just spaces (already). They were removed by - * TclSubstTokens() via TclParseBackslash(). + * Track the invisible continuation lines embedded in a script, if any. + * Here they are just spaces (already). They were removed by + * TclSubstTokens via TclParseBackslash. * * *clNextPtrPtr <=> We have continuation lines to track. * **clNextPtrPtr >= 0 <=> We are not beyond the last possible location. * loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line. */ - while (*clNextPtrPtr && (**clNextPtrPtr >= 0) && (loc >= **clNextPtrPtr)) { + while (*clNextPtrPtr && (**clNextPtrPtr >= 0) + && (loc >= **clNextPtrPtr)) { /* * We just stepped over an invisible continuation line. Adjust the * line counter and step to the table entry holding the location of * the next continuation line to track. */ - (*line) ++; - (*clNextPtrPtr) ++; + + (*line)++; + (*clNextPtrPtr)++; } } @@ -4602,8 +5458,8 @@ TclAdvanceContinuations (line,clNextPtrPtr,loc) * * TclArgumentEnter -- * - * This procedure is a helper for the TIP #280 uplevel extension. - * It enters location references for the arguments of a command to be + * This procedure is a helper for the TIP #280 uplevel extension. It + * enters location references for the arguments of a command to be * invoked. Only the first entry has the actual data, further entries * simply count the usage up. * @@ -4618,45 +5474,49 @@ TclAdvanceContinuations (line,clNextPtrPtr,loc) */ void -TclArgumentEnter(interp,objv,objc,cfPtr) - Tcl_Interp* interp; - Tcl_Obj** objv; - int objc; - CmdFrame* cfPtr; +TclArgumentEnter( + Tcl_Interp *interp, + Tcl_Obj **objv, + int objc, + CmdFrame *cfPtr) { - Interp* iPtr = (Interp*) interp; + Interp *iPtr = (Interp *) interp; int new, i; - Tcl_HashEntry* hPtr; - CFWord* cfwPtr; + Tcl_HashEntry *hPtr; + CFWord *cfwPtr; - for (i=1; i < objc; i++) { + for (i = 1; i < objc; i++) { /* - * Ignore argument words without line information (= dynamic). If - * they are variables they may have location information associated - * with that, either through globally recorded 'set' invokations, or + * Ignore argument words without line information (= dynamic). If they + * are variables they may have location information associated with + * that, either through globally recorded 'set' invokations, or * literals in bytecode. Eitehr way there is no need to record * something here. */ - if (cfPtr->line [i] < 0) continue; - hPtr = Tcl_CreateHashEntry (iPtr->lineLAPtr, (char*) objv[i], &new); + if (cfPtr->line[i] < 0) { + continue; + } + 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->framePtr = cfPtr; - cfwPtr->word = i; - cfwPtr->refCount = 1; - Tcl_SetHashValue (hPtr, cfwPtr); + /* + * The word is not on the stack yet, remember the current location + * and initialize references. + */ + + cfwPtr = ckalloc(sizeof(CFWord)); + cfwPtr->framePtr = cfPtr; + cfwPtr->word = i; + cfwPtr->refCount = 1; + Tcl_SetHashValue(hPtr, cfwPtr); } else { - /* - * The word is already on the stack, its current location is not - * relevant. Just remember the reference to prevent early removal. - */ - cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); - cfwPtr->refCount ++; + /* + * The word is already on the stack, its current location is not + * relevant. Just remember the reference to prevent early removal. + */ + + cfwPtr = Tcl_GetHashValue(hPtr); + cfwPtr->refCount++; } } } @@ -4666,10 +5526,10 @@ TclArgumentEnter(interp,objv,objc,cfPtr) * * TclArgumentRelease -- * - * This procedure is a helper for the TIP #280 uplevel extension. - * It removes the location references for the arguments of a command - * just done. Usage is counted down, the data is removed only when - * no user is left over. + * This procedure is a helper for the TIP #280 uplevel extension. It + * removes the location references for the arguments of a command just + * done. Usage is counted down, the data is removed only when no user is + * left over. * * Results: * None. @@ -4682,27 +5542,31 @@ TclArgumentEnter(interp,objv,objc,cfPtr) */ void -TclArgumentRelease(interp,objv,objc) - Tcl_Interp* interp; - Tcl_Obj** objv; - int objc; -{ - Interp* iPtr = (Interp*) interp; - Tcl_HashEntry* hPtr; - CFWord* cfwPtr; +TclArgumentRelease( + Tcl_Interp *interp, + Tcl_Obj **objv, + int objc) +{ + Interp *iPtr = (Interp *) interp; int i; - for (i=1; i < objc; i++) { - hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) objv[i]); + for (i = 1; i < objc; i++) { + CFWord *cfwPtr; + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]); - if (!hPtr) { continue; } - cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); + if (!hPtr) { + continue; + } + cfwPtr = Tcl_GetHashValue(hPtr); - cfwPtr->refCount --; - if (cfwPtr->refCount > 0) { continue; } + cfwPtr->refCount--; + if (cfwPtr->refCount > 0) { + continue; + } - ckfree ((char*) cfwPtr); - Tcl_DeleteHashEntry (hPtr); + ckfree(cfwPtr); + Tcl_DeleteHashEntry(hPtr); } } @@ -4711,9 +5575,9 @@ TclArgumentRelease(interp,objv,objc) * * TclArgumentBCEnter -- * - * This procedure is a helper for the TIP #280 uplevel extension. - * It enters location references for the literal arguments of commands - * in bytecode about to be invoked. Only the first entry has the actual + * This procedure is a helper for the TIP #280 uplevel extension. It + * enters location references for the literal arguments of commands in + * bytecode about to be invoked. Only the first entry has the actual * data, further entries simply count the usage up. * * Results: @@ -4727,72 +5591,81 @@ TclArgumentRelease(interp,objv,objc) */ void -TclArgumentBCEnter(interp,objv,objc,codePtr,cfPtr,pc) - Tcl_Interp* interp; - Tcl_Obj* objv[]; - int objc; - void* codePtr; - CmdFrame* cfPtr; - int pc; +TclArgumentBCEnter( + Tcl_Interp *interp, + Tcl_Obj *objv[], + int objc, + void *codePtr, + CmdFrame *cfPtr, + int pc) { - Interp* iPtr = (Interp*) interp; - Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); + 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) { - ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); - hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); + int word; + int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); + ECL *ePtr = &eclPtr->loc[cmd]; + CFWordBC *lastPtr = NULL; - if (hePtr) { - int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); - ECL* ePtr = &eclPtr->loc[cmd]; - int word; + /* + * 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. + */ - /* - * 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. - */ + if (ePtr->nline != objc) { + Tcl_Panic ("TIP 280 data structure inconsistency"); + } + + 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. + */ + + cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); + } - if (ePtr->nline != objc) { - Tcl_Panic ("TIP 280 data structure inconsistency"); + Tcl_SetHashValue(hPtr, cfwPtr); } + } /* for */ - 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->pc = pc; - cfwPtr->word = word; - - 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 = (CFWordBC*) Tcl_GetHashValue(hPtr); - } - - Tcl_SetHashValue (hPtr, cfwPtr); - } - } /* for */ - } /* if */ + cfPtr->litarg = lastPtr; } /* if */ } @@ -4801,10 +5674,10 @@ TclArgumentBCEnter(interp,objv,objc,codePtr,cfPtr,pc) * * TclArgumentBCRelease -- * - * This procedure is a helper for the TIP #280 uplevel extension. - * It removes the location references for the literal arguments of - * commands in bytecode just done. Usage is counted down, the data - * is removed only when no user is left over. + * This procedure is a helper for the TIP #280 uplevel extension. It + * removes the location references for the literal arguments of commands + * in bytecode just done. Usage is counted down, the data is removed only + * when no user is left over. * * Results: * None. @@ -4817,48 +5690,34 @@ TclArgumentBCEnter(interp,objv,objc,codePtr,cfPtr,pc) */ void -TclArgumentBCRelease(interp,objv,objc,codePtr,pc) - Tcl_Interp* interp; - Tcl_Obj* objv[]; - int objc; - void* codePtr; - int pc; +TclArgumentBCRelease( + Tcl_Interp *interp, + CmdFrame *cfPtr) { - Interp* iPtr = (Interp*) interp; - Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); - - if (hePtr) { - ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); - hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); + Interp *iPtr = (Interp *) interp; + CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg; - if (hePtr) { - int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); - ECL* ePtr = &eclPtr->loc[cmd]; - int word; + while (cfwPtr) { + CFWordBC *nextPtr = cfwPtr->nextPtr; + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj); + CFWordBC *xPtr = Tcl_GetHashValue(hPtr); - /* - * Iterate in reverse order, to properly match our pop to the push - * in TclArgumentBCEnter(). - */ - for (word = objc-1; word >= 1; word--) { - if (ePtr->line[word] >= 0) { - Tcl_HashEntry* hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, - (char *) objv[word]); - if (hPtr) { - CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); - - if (cfwPtr->prevPtr) { - Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); - } else { - Tcl_DeleteHashEntry(hPtr); - } + if (xPtr != cfwPtr) { + Tcl_Panic("TclArgumentBC Enter/Release Mismatch"); + } - ckfree((char *) cfwPtr); - } - } - } + if (cfwPtr->prevPtr) { + Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); + } else { + Tcl_DeleteHashEntry(hPtr); } + + ckfree(cfwPtr); + cfwPtr = nextPtr; } + + cfPtr->litarg = NULL; } /* @@ -4866,8 +5725,8 @@ TclArgumentBCRelease(interp,objv,objc,codePtr,pc) * * TclArgumentGet -- * - * This procedure is a helper for the TIP #280 uplevel extension. - * It find the location references for a Tcl_Obj, if any. + * This procedure is a helper for the TIP #280 uplevel extension. It + * finds the location references for a Tcl_Obj, if any. * * Results: * None. @@ -4880,15 +5739,15 @@ TclArgumentBCRelease(interp,objv,objc,codePtr,pc) */ void -TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) - Tcl_Interp* interp; - Tcl_Obj* obj; - CmdFrame** cfPtrPtr; - int* wordPtr; +TclArgumentGet( + Tcl_Interp *interp, + Tcl_Obj *obj, + CmdFrame **cfPtrPtr, + int *wordPtr) { - Interp* iPtr = (Interp*) interp; - Tcl_HashEntry* hPtr; - CmdFrame* framePtr; + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + CmdFrame *framePtr; /* * An object which either has no string rep or else is a canonical list is @@ -4906,10 +5765,11 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) * stack. That is nearest. */ - hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) obj); + hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj); if (hPtr) { - CFWord* cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); - *wordPtr = cfwPtr->word; + CFWord *cfwPtr = Tcl_GetHashValue(hPtr); + + *wordPtr = cfwPtr->word; *cfPtrPtr = cfwPtr->framePtr; return; } @@ -4919,16 +5779,15 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) * that stack. */ - hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj); - + hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj); if (hPtr) { - CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); + CFWordBC *cfwPtr = Tcl_GetHashValue(hPtr); framePtr = cfwPtr->framePtr; - framePtr->data.tebc.pc = (char *) (((ByteCode*) + framePtr->data.tebc.pc = (char *) (((ByteCode *) framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc); *cfPtrPtr = cfwPtr->framePtr; - *wordPtr = cfwPtr->word; + *wordPtr = cfwPtr->word; return; } } @@ -4998,7 +5857,6 @@ Tcl_EvalObj( { return Tcl_EvalObjEx(interp, objPtr, 0); } - #undef Tcl_GlobalEvalObj int Tcl_GlobalEvalObj( @@ -5056,80 +5914,146 @@ TclEvalObjEx( const CmdFrame *invoker, /* Frame of the command doing the eval. */ int word) /* Index of the word which is in objPtr. */ { - register Interp *iPtr = (Interp *) interp; - char *script; - int numSrcBytes; - int result; - CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case - * TCL_EVAL_GLOBAL was set. */ + int result = TCL_OK; + NRE_callback *rootPtr = TOP_CB(interp); - Tcl_IncrRefCount(objPtr); + result = TclNREvalObjEx(interp, objPtr, flags, invoker, word); + return TclNRRunCallbacks(interp, result, rootPtr); +} - /* Pure List Optimization (no string representation). 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 string and back out again. - * - * 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). +int +TclNREvalObjEx( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * a previous call to Tcl_CreateInterp). */ + register Tcl_Obj *objPtr, /* Pointer to object containing commands to + * execute. */ + int flags, /* Collection of OR-ed bits that control the + * evaluation of the script. Supported values + * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ + const CmdFrame *invoker, /* Frame of the command doing the eval. */ + int word) /* Index of the word which is in objPtr. */ +{ + Interp *iPtr = (Interp *) interp; + int result; + + /* + * This function consists of three independent blocks for: direct + * evaluation of canonical lists, compilation and bytecode execution and + * finally direct evaluation. Precisely one of these blocks will be run. */ if (TclListObjIsCanonical(objPtr)) { + Tcl_Obj *listPtr = objPtr; + CmdFrame *eoFramePtr = NULL; + int objc; + Tcl_Obj **objv; + + /* + * Pure List Optimization (no string representation). 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 + * string and back out again. + * + * 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). + */ + /* - * TIP #280 Structures for tracking lines. As we know that this is - * dynamic execution we ignore the invoker, even if known. + * Shimmer protection! Always pass an unshared obj. The caller could + * incr the refCount of objPtr AFTER calling us! To be completely safe + * we always make a copy. The callback takes care od the refCounts for + * both listPtr and objPtr. + * + * FIXME OPT: preserve just the internal rep? */ - int nelements; - Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr); - CmdFrame *eoFramePtr = (CmdFrame *) - TclStackAlloc(interp, sizeof(CmdFrame)); + Tcl_IncrRefCount(objPtr); + listPtr = TclListObjCopy(interp, objPtr); + Tcl_IncrRefCount(listPtr); + TclDecrRefCount(objPtr); - eoFramePtr->type = TCL_LOCATION_EVAL_LIST; - eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 - : iPtr->cmdFramePtr->level + 1); - eoFramePtr->framePtr = iPtr->framePtr; - eoFramePtr->nextPtr = iPtr->cmdFramePtr; + if (word != INT_MIN) { + /* + * TIP #280 Structures for tracking lines. As we know that this is + * dynamic execution we ignore the invoker, even if known. + * + * TIP #280. We do _not_ compute all the line numbers for the + * words in the command. For the eval of a pure list the most + * sensible choice is to put all words on line 1. Given that we + * neither need memory for them nor compute anything. 'line' is + * left NULL. The two places using this information (TclInfoFrame, + * and TclInitCompileEnv), are special-cased to use the proper + * line number directly instead of accessing the 'line' array. + * + * Note that we use (word==INTMIN) to signal that no command frame + * should be pushed, as needed by alias and ensemble redirections. + */ - eoFramePtr->nline = 0; - eoFramePtr->line = NULL; + eoFramePtr = TclStackAlloc(interp, sizeof(CmdFrame)); + eoFramePtr->nline = 0; + eoFramePtr->line = NULL; - eoFramePtr->cmd.listPtr = objPtr; - Tcl_IncrRefCount(eoFramePtr->cmd.listPtr); - eoFramePtr->data.eval.path = NULL; + eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->level = (iPtr->cmdFramePtr == NULL? + 1 : iPtr->cmdFramePtr->level + 1); + eoFramePtr->numLevels = iPtr->numLevels; + eoFramePtr->framePtr = iPtr->framePtr; + eoFramePtr->nextPtr = iPtr->cmdFramePtr; - /* - * TIP #280 We do _not_ compute all the line numbers for the words - * in the command. For the eval of a pure list the most sensible - * choice is to put all words on line 1. Given that we neither - * need memory for them nor compute anything. 'line' is left - * NULL. The two places using this information (TclInfoFrame, and - * TclInitCompileEnv), are special-cased to use the proper line - * number directly instead of accessing the 'line' array. - */ + eoFramePtr->cmd.listPtr = listPtr; + eoFramePtr->data.eval.path = NULL; - Tcl_ListObjGetElements(NULL, copyPtr, &nelements, &elements); + iPtr->cmdFramePtr = eoFramePtr; + } - iPtr->cmdFramePtr = eoFramePtr; - result = Tcl_EvalObjv(interp, nelements, elements, flags); + TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, + NULL, NULL); - Tcl_DecrRefCount(copyPtr); - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; - Tcl_DecrRefCount(eoFramePtr->cmd.listPtr); - TclStackFree(interp, eoFramePtr); - } else if (flags & TCL_EVAL_DIRECT) { + ListObjGetElements(listPtr, objc, objv); + return TclNREvalObjv(interp, objc, objv, flags, NULL); + } + + if (!(flags & TCL_EVAL_DIRECT)) { /* - * We're not supposed to use the compiler or byte-code interpreter. - * Let Tcl_EvalEx evaluate the command directly (and probably more - * slowly). + * Let the compiler/engine subsystem do the evaluation. + * + * TIP #280 The invoker provides us with the context for the script. + * We transfer this to the byte code compiler. */ + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + ByteCode *codePtr; + CallFrame *savedVarFramePtr = NULL; /* Saves old copy of + * 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; + } + Tcl_IncrRefCount(objPtr); + codePtr = TclCompileObj(interp, objPtr, invoker, word); + + TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr, + objPtr, INT2PTR(allowExceptions), NULL); + return TclNRExecuteByteCode(interp, codePtr); + } + + { /* + * 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 @@ -5139,6 +6063,9 @@ TclEvalObjEx( * in the bytecode compiler. */ + const char *script; + int numSrcBytes; + /* * Now we check if we have data about invisible continuation lines for * the script, and make it available to the direct script parser and @@ -5148,7 +6075,7 @@ TclEvalObjEx( * evaluator is using it, leading to the release of the associated * ContLineLoc structure as well. To ensure that the latter doesn't * happen we set a lock on it. We release this lock later in this - * function, after the evaluator is done. The relevant "lineCLPtr" + * function, after the evaluator is done. The relevant "lineCLPtr" * hashtable is managed in the file "tclObj.c". * * Another important action is to save (and later restore) the @@ -5156,16 +6083,17 @@ TclEvalObjEx( * executing nested commands in the eval/direct path. */ - ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr; - ContLineLoc* clLocPtr = TclContinuationsGet (objPtr); + ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; + ContLineLoc *clLocPtr = TclContinuationsGet(objPtr); if (clLocPtr) { iPtr->scriptCLLocPtr = clLocPtr; - Tcl_Preserve (iPtr->scriptCLLocPtr); + Tcl_Preserve(iPtr->scriptCLLocPtr); } else { iPtr->scriptCLLocPtr = NULL; } + Tcl_IncrRefCount(objPtr); if (invoker == NULL) { /* * No context, force opening of our own. @@ -5188,8 +6116,7 @@ TclEvalObjEx( */ int pc = 0; - CmdFrame *ctxPtr = (CmdFrame *) - TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); *ctxPtr = *invoker; if (invoker->type == TCL_LOCATION_BC) { @@ -5204,16 +6131,14 @@ TclEvalObjEx( script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - if ((ctxPtr->nline <= word) || - (ctxPtr->line[word] < 0) || - (ctxPtr->type != TCL_LOCATION_SOURCE)) { + if ((invoker->nline <= word) || + (invoker->line[word] < 0) || + (ctxPtr->type != TCL_LOCATION_SOURCE)) { /* - * Dynamic script, or dynamic context, force our own - * context. + * Dynamic script, or dynamic context, force our own context. */ result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } else { /* * Absolute context to reuse. @@ -5223,9 +6148,8 @@ TclEvalObjEx( iPtr->evalFlags |= TCL_EVAL_CTX; result = TclEvalEx(interp, script, numSrcBytes, flags, - ctxPtr->line[word], NULL, script); + ctxPtr->line[word], NULL, script); } - if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* * Death of SrcInfo reference. @@ -5237,54 +6161,87 @@ TclEvalObjEx( } /* - * Now release the lock on the continuation line information, if - * any, and restore the caller's settings. + * Now release the lock on the continuation line information, if any, + * and restore the caller's settings. */ if (iPtr->scriptCLLocPtr) { - Tcl_Release (iPtr->scriptCLLocPtr); + Tcl_Release(iPtr->scriptCLLocPtr); } iPtr->scriptCLLocPtr = saveCLLocPtr; - } else { - /* - * Let the compiler/engine subsystem do the evaluation. - * - * TIP #280 The invoker provides us with the context for the script. - * We transfer this to the byte code compiler. - */ - int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + TclDecrRefCount(objPtr); + return result; + } +} - savedVarFramePtr = iPtr->varFramePtr; - if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = iPtr->rootFramePtr; +static int +TEOEx_ByteCodeCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *savedVarFramePtr = data[0]; + Tcl_Obj *objPtr = data[1]; + int allowExceptions = PTR2INT(data[2]); + + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); } + if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { + const char *script; + int numSrcBytes; - result = TclCompEvalObj(interp, objPtr, invoker, word); + ProcessUnexpectedResult(interp, result); + result = TCL_ERROR; + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, numSrcBytes); + } /* - * If we are again at the top level, process any unusual return code - * returned by the evaluated code. + * We are returning to level 0, so should call TclResetCancellation. + * Let us just unset the flags inline. */ - if (iPtr->numLevels == 0) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } - if ((result != TCL_OK) && (result != TCL_ERROR) - && !allowExceptions) { - ProcessUnexpectedResult(interp, result); - result = TCL_ERROR; - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - Tcl_LogCommandInfo(interp, script, script, numSrcBytes); - } - } - iPtr->evalFlags = 0; + TclUnsetCancelFlags(iPtr); + } + iPtr->evalFlags = 0; + + /* + * Restore the callFrame if this was a TCL_EVAL_GLOBAL. + */ + + if (savedVarFramePtr) { iPtr->varFramePtr = savedVarFramePtr; } TclDecrRefCount(objPtr); return result; } + +static int +TEOEx_ListCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *listPtr = data[0]; + CmdFrame *eoFramePtr = data[1]; + + /* + * Remove the cmdFrame + */ + + if (eoFramePtr) { + iPtr->cmdFramePtr = eoFramePtr->nextPtr; + TclStackFree(interp, eoFramePtr); + } + TclDecrRefCount(listPtr); + + return result; +} /* *---------------------------------------------------------------------- @@ -5312,17 +6269,21 @@ ProcessUnexpectedResult( * result code was returned. */ int returnCode) /* The unexpected result code. */ { + char buf[TCL_INTEGER_SPACE]; + 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)); } + sprintf(buf, "%d", returnCode); + Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, NULL); } /* @@ -5473,7 +6434,7 @@ Tcl_ExprLongObj( return TCL_ERROR; } - if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type) != TCL_OK){ + if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) { return TCL_ERROR; } @@ -5566,6 +6527,7 @@ Tcl_ExprBooleanObj( * * Object version: Invokes a Tcl command, given an objv/objc, from either * the exposed or hidden set of commands in the given interpreter. + * * NOTE: The command is invoked in the global stack frame of the * interpreter or namespace, thus it cannot see any current state on the * stack of that interpreter. @@ -5640,7 +6602,7 @@ TclObjInvoke( { register Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ - char *cmdName; /* Name of the command from objv[0]. */ + const char *cmdName; /* Name of the command from objv[0]. */ Tcl_HashEntry *hPtr = NULL; Command *cmdPtr; int result; @@ -5650,7 +6612,8 @@ TclObjInvoke( } if ((objc < 1) || (objv == NULL)) { - Tcl_AppendResult(interp, "illegal argument vector", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal argument vector", -1)); return TCL_ERROR; } @@ -5668,8 +6631,10 @@ 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); @@ -5679,7 +6644,12 @@ TclObjInvoke( */ iPtr->cmdCount++; - result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); + if (cmdPtr->objProc != NULL) { + result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); + } else { + result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, + cmdPtr->objClientData, objc, objv); + } /* * If an error occurred, record information about what was being executed @@ -5735,7 +6705,7 @@ Tcl_ExprString( * An empty string. Just set the interpreter's result to 0. */ - Tcl_SetResult(interp, "0", TCL_VOLATILE); + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } else { Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); @@ -5746,13 +6716,13 @@ Tcl_ExprString( Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); } + } - /* - * Force the string rep of the interp result. - */ + /* + * Force the string rep of the interp result. + */ - (void) Tcl_GetStringResult(interp); - } + (void) Tcl_GetStringResult(interp); return code; } @@ -5865,7 +6835,7 @@ Tcl_AddObjErrorInfo( * interp->result completely. */ - iPtr->errorInfo = Tcl_NewStringObj(interp->result, -1); + iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); } else { iPtr->errorInfo = iPtr->objResultPtr; } @@ -5909,7 +6879,7 @@ Tcl_AddObjErrorInfo( int Tcl_VarEvalVA( - Tcl_Interp *interp, /* Interpreter in which to evaluate command. */ + Tcl_Interp *interp, /* Interpreter in which to evaluate command */ va_list argList) /* Variable argument list. */ { Tcl_DString buf; @@ -5990,7 +6960,8 @@ Tcl_VarEval( int Tcl_GlobalEval( - Tcl_Interp *interp, /* Interpreter in which to evaluate command. */ + Tcl_Interp *interp, /* Interpreter in which to evaluate + * command. */ const char *command) /* Command to evaluate. */ { register Interp *iPtr = (Interp *) interp; @@ -6148,6 +7119,7 @@ ExprCeilFunc( if (code != TCL_OK) { return TCL_ERROR; } + if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big))); mp_clear(&big); @@ -6183,6 +7155,7 @@ ExprFloorFunc( if (code != TCL_OK) { return TCL_ERROR; } + if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big))); mp_clear(&big); @@ -6204,9 +7177,8 @@ ExprIsqrtFunc( double d; Tcl_WideInt w; mp_int big; - int exact = 0; /* Flag == 1 if the argument can be - * represented in a double as an exact - * integer. */ + int exact = 0; /* Flag ==1 if the argument can be represented + * in a double as an exact integer. */ /* * Check syntax. @@ -6283,12 +7255,13 @@ ExprIsqrtFunc( mp_clear(&big); Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root)); } - return TCL_OK; negarg: - Tcl_SetObjResult(interp, - Tcl_NewStringObj("square root of negative argument", -1)); + 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; } @@ -6363,7 +7336,7 @@ ExprUnaryFunc( return TCL_ERROR; } errno = 0; - return CheckDoubleResult(interp, (*func)(d)); + return CheckDoubleResult(interp, func(d)); } static int @@ -6434,7 +7407,7 @@ ExprBinaryFunc( return TCL_ERROR; } errno = 0; - return CheckDoubleResult(interp, (*func)(d1, d2)); + return CheckDoubleResult(interp, func(d1, d2)); } static int @@ -6487,17 +7460,17 @@ ExprAbsFunc( double d = *((const double *) ptr); static const double poszero = 0.0; - /* We need to distinguish here between positive 0.0 and - * negative -0.0, see Bug ID #2954959. + /* + * 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) { + if (!memcmp(&d, &poszero, sizeof(double))) { goto unChanged; } + } else if (d > -0.0) { + goto unChanged; } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); return TCL_OK; @@ -6520,8 +7493,7 @@ ExprAbsFunc( #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); @@ -6539,6 +7511,7 @@ ExprAbsFunc( return TCL_OK; #else double d; + Tcl_GetDoubleFromObj(interp, objv[1], &d); return TCL_ERROR; #endif @@ -6576,6 +7549,7 @@ ExprDoubleFunc( Tcl_Obj *const *objv) /* Actual parameter vector. */ { double dResult; + if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; @@ -6691,6 +7665,7 @@ ExprWideFunc( { Tcl_WideInt wResult; Tcl_Obj *objPtr; + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { return TCL_ERROR; } @@ -6919,7 +7894,7 @@ ExprSrandFunc( /* * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in - * ExprRandFunc() for more details. + * ExprRandFunc for more details. */ iPtr->flags |= RAND_SEED_INITIALIZED; @@ -6966,7 +7941,7 @@ MathFuncWrongNumArgs( const char *tail = name + strlen(name); while (tail > name+1) { - --tail; + tail--; if (*tail == ':' && tail[-1] == ':') { name = tail+1; break; @@ -6975,9 +7950,10 @@ MathFuncWrongNumArgs( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "too %s arguments for math function \"%s\"", (found < expected ? "few" : "many"), name)); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); } -#ifdef USE_DTRACE +#ifdef USE_DTRACE /* *---------------------------------------------------------------------- * @@ -7033,49 +8009,1082 @@ DTraceObjCmd( void TclDTraceInfo( Tcl_Obj *info, - char **args, + const char **args, int *argsi) { - static Tcl_Obj *keys[7] = { NULL }; + static Tcl_Obj *keys[10] = { NULL }; Tcl_Obj **k = keys, *val; - int i; + int i = 0; if (!*k) { - TclNewLiteralStringObj(keys[0], "cmd"); - TclNewLiteralStringObj(keys[1], "type"); - TclNewLiteralStringObj(keys[2], "proc"); - TclNewLiteralStringObj(keys[3], "file"); - TclNewLiteralStringObj(keys[4], "lambda"); - TclNewLiteralStringObj(keys[5], "line"); - TclNewLiteralStringObj(keys[6], "level"); - } - for (i = 0; i < 4; i++) { +#define kini(s) TclNewLiteralStringObj(keys[i], s); i++ + kini("cmd"); kini("type"); kini("proc"); kini("file"); + kini("method"); kini("class"); kini("lambda"); kini("object"); + kini("line"); kini("level"); +#undef kini + } + for (i = 0; i < 6; i++) { Tcl_DictObjGet(NULL, info, *k++, &val); args[i] = val ? TclGetString(val) : NULL; } + /* no "proc" -> use "lambda" */ if (!args[2]) { Tcl_DictObjGet(NULL, info, *k, &val); args[2] = val ? TclGetString(val) : NULL; } k++; + /* no "class" -> use "object" */ + if (!args[5]) { + Tcl_DictObjGet(NULL, info, *k, &val); + args[5] = val ? TclGetString(val) : NULL; + } + k++; for (i = 0; i < 2; i++) { Tcl_DictObjGet(NULL, info, *k++, &val); if (val) { - TclGetIntFromObj(NULL, val, &(argsi[i])); + TclGetIntFromObj(NULL, val, &argsi[i]); } else { argsi[i] = 0; } } } + +/* + *---------------------------------------------------------------------- + * + * DTraceCmdReturn -- + * + * NR callback for DTrace command return probes. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DTraceCmdReturn( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + char *cmdName = TclGetString((Tcl_Obj *) data[0]); + + if (TCL_DTRACE_CMD_RETURN_ENABLED()) { + TCL_DTRACE_CMD_RETURN(cmdName, result); + } + if (TCL_DTRACE_CMD_RESULT_ENABLED()) { + Tcl_Obj *r = Tcl_GetObjResult(interp); + + TCL_DTRACE_CMD_RESULT(cmdName, result, TclGetString(r), r); + } + return result; +} TCL_DTRACE_DEBUG_LOG() #endif /* USE_DTRACE */ /* + *---------------------------------------------------------------------- + * + * Tcl_NRCallObjProc -- + * + * This function calls an objProc directly while managing things properly + * if it happens to be an NR objProc. It is meant to be used by extenders + * that provide an NR implementation of a command, as this function + * permits a trivial coding of the non-NR objProc. + * + * Results: + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR. A result or error message is left in interp's result. + * + * Side effects: + * Depends on the objProc. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_NRCallObjProc( + Tcl_Interp *interp, + Tcl_ObjCmdProc *objProc, + ClientData clientData, + int objc, + Tcl_Obj *const objv[]) +{ + int result = TCL_OK; + NRE_callback *rootPtr = TOP_CB(interp); + +#ifdef USE_DTRACE + 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]; + + 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)); + } +#endif /* USE_DTRACE */ + result = objProc(clientData, interp, objc, objv); + return TclNRRunCallbacks(interp, result, rootPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NRCreateCommand -- + * + * Define a new NRE-enabled object-based command in a command table. + * + * Results: + * The return value is a token for the command, which can be used in + * 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. + * + * 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 + * Tcl_ObjCmdProc proc will be called. When the command is deleted from + * the table, deleteProc will be called. See the manual entry for details + * on the calling sequence. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_NRCreateCommand( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ + const char *cmdName, /* Name of command. If it contains namespace + * qualifiers, the new command is put in the + * specified namespace; otherwise it is put in + * the global namespace. */ + Tcl_ObjCmdProc *proc, /* Object-based function to associate with + * name, provides direct access for direct + * calls. */ + Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with + * name, provides NR implementation */ + ClientData clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc) + /* If not NULL, gives a function to call when + * this command is deleted. */ +{ + Command *cmdPtr = (Command *) + Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); + + cmdPtr->nreProc = nreProc; + return (Tcl_Command) cmdPtr; +} + +/**************************************************************************** + * Stuff for the public api + ****************************************************************************/ + +int +Tcl_NREvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + int flags) +{ + return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN); +} + +int +Tcl_NREvalObjv( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * command. Also used for error reporting. */ + int objc, /* Number of words in command. */ + Tcl_Obj *const objv[], /* An array of pointers to objects that are + * the words that make up the command. */ + int flags) /* Collection of OR-ed bits that control the + * evaluation of the script. Only + * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and + * TCL_EVAL_NOERR are currently supported. */ +{ + return TclNREvalObjv(interp, objc, objv, flags, NULL); +} + +int +Tcl_NRCmdSwap( + Tcl_Interp *interp, + Tcl_Command cmd, + int objc, + Tcl_Obj *const objv[], + int flags) +{ + return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd); +} + +/***************************************************************************** + * Stuff for tailcalls + ***************************************************************************** + * + * Just to show that IT CAN BE DONE! The precise semantics are not simple, + * require more thought. Possibly need a new Tcl return code to do it right? + * Questions include: + * (1) How is the objc/objv tailcall to be run? My current thinking is that + * it should essentially be + * [tailcall a b c] <=> [uplevel 1 [list a b c]] + * with two caveats + * (a) the current frame is dropped first, after running all pending + * cleanup tasks and saving its namespace + * (b) 'a' is looked up in the returning frame's namespace, but the + * command is run in the context to which we are returning + * Current implementation does this if [tailcall] is called from within + * a proc, errors otherwise. + * (2) Should a tailcall bypass [catch] in the returning frame? Current + * implementation does not (or does it? Changed, test!) - it causes an + * error. + * + * FIXME NRE! + */ + +void +TclSpliceTailcall( + Tcl_Interp *interp, + NRE_callback *tailcallPtr) +{ + /* + * 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). + */ + + NRE_callback *runPtr; + + for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { + if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { + break; + } + } + if (!runPtr) { + Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); + } + + tailcallPtr->nextPtr = runPtr->nextPtr; + runPtr->nextPtr = tailcallPtr; +} + +int +TclNRTailcallObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?"); + return TCL_ERROR; + } + + 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; + } + + /* + * Invocation without args just clears a scheduled tailcall; invocation + * with an argument replaces any previously scheduled tailcall. + */ + + if (iPtr->varFramePtr->tailcallPtr) { + ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr); + iPtr->varFramePtr->tailcallPtr = NULL; + } + + /* + * Create the callback to actually evaluate the tailcalled + * 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. + */ + + if (objc > 1) { + Tcl_Obj *listPtr, *nsObjPtr; + Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + Tcl_Namespace *ns1Ptr; + NRE_callback *tailcallPtr; + + listPtr = Tcl_NewListObj(objc-1, objv+1); + Tcl_IncrRefCount(listPtr); + + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); + if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) + || (nsPtr != ns1Ptr)) { + Tcl_Panic("Tailcall failed to find the proper namespace"); + } + Tcl_IncrRefCount(nsObjPtr); + + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr, + NULL, NULL); + tailcallPtr = TOP_CB(interp); + TOP_CB(interp) = tailcallPtr->nextPtr; + iPtr->varFramePtr->tailcallPtr = tailcallPtr; + } + return TCL_RETURN; +} + +int +TclNRTailcallEval( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *listPtr = data[0]; + Tcl_Obj *nsObjPtr = data[1]; + Tcl_Namespace *nsPtr; + int objc; + Tcl_Obj **objv; + + if (result == TCL_OK) { + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + } + + 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 + */ + + TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL); + iPtr->lookupNsPtr = (Namespace *) nsPtr; + ListObjGetElements(listPtr, objc, objv); + return TclNREvalObjv(interp, objc, objv, 0, NULL); +} + +static int +TailcallCleanup( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_DecrRefCount((Tcl_Obj *) data[0]); + Tcl_DecrRefCount((Tcl_Obj *) data[1]); + return result; +} + +static void +ClearTailcall( + Tcl_Interp *interp, + NRE_callback *tailcallPtr) +{ + TailcallCleanup(tailcallPtr->data, interp, TCL_OK); + TCLNR_FREE(interp, tailcallPtr); +} + + +void +Tcl_NRAddCallback( + Tcl_Interp *interp, + Tcl_NRPostProc *postProcPtr, + ClientData data0, + ClientData data1, + ClientData data2, + ClientData data3) +{ + if (!(postProcPtr)) { + Tcl_Panic("Adding a callback without an objProc?!"); + } + TclNRAddCallback(interp, postProcPtr, data0, data1, data2, data3); +} + +/* + *---------------------------------------------------------------------- + * + * TclNRCoroutineObjCmd -- (and friends) + * + * This object-based function is invoked to process the "coroutine" Tcl + * command. It is heavily based on "apply". + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * A new procedure gets created. + * + * ** FIRST EXPERIMENTAL IMPLEMENTATION ** + * + * It is fairly amateurish and not up to our standards - mainly in terms of + * error messages and [info] interaction. Just to test the infrastructure in + * teov and tebc. + *---------------------------------------------------------------------- + */ + +#define iPtr ((Interp *) interp) + +int +TclNRYieldObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?"); + return TCL_ERROR; + } + + if (!corPtr) { + 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; + } + + if (objc == 2) { + Tcl_SetObjResult(interp, objv[1]); + } + + NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, + clientData, NULL, NULL); + return TCL_OK; +} + +int +TclNRYieldToObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + Tcl_Obj *listPtr, *nsObjPtr; + Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + Tcl_Namespace *ns1Ptr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); + return TCL_ERROR; + } + + if (!corPtr) { + 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; + } + + /* + * 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); + + 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); + + /* + * Add the callback in the caller's env, then instruct TEBC to yield. + */ + + iPtr->execEnvPtr = corPtr->callerEEPtr; + TclNRAddCallback(interp, YieldToCallback, corPtr, listPtr, nsObjPtr, + NULL); + iPtr->execEnvPtr = corPtr->eePtr; + + return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); +} + +static int +YieldToCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + /* CoroutineData *corPtr = data[0];*/ + Tcl_Obj *listPtr = data[1]; + ClientData nsPtr = data[2]; + NRE_callback *cbPtr; + + /* + * yieldTo: invoke the command using tailcall tech. + */ + + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL); + cbPtr = TOP_CB(interp); + TOP_CB(interp) = cbPtr->nextPtr; + + TclSpliceTailcall(interp, cbPtr); + return TCL_OK; +} + +static int +RewindCoroutineCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + return Tcl_RestoreInterpState(interp, data[0]); +} + +static int +RewindCoroutine( + CoroutineData *corPtr, + int result) +{ + Tcl_Interp *interp = corPtr->eePtr->interp; + Tcl_InterpState state = Tcl_SaveInterpState(interp, result); + + NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); + NRE_ASSERT(corPtr->eePtr != NULL); + NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr); + + corPtr->eePtr->rewind = 1; + TclNRAddCallback(interp, RewindCoroutineCallback, state, + NULL, NULL, NULL); + return TclNRInterpCoroutine(corPtr, interp, 0, NULL); +} + +static void +DeleteCoroutine( + ClientData clientData) +{ + CoroutineData *corPtr = clientData; + Tcl_Interp *interp = corPtr->eePtr->interp; + NRE_callback *rootPtr = TOP_CB(interp); + + if (COR_IS_SUSPENDED(corPtr)) { + TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr); + } +} + +static int +NRCoroutineCallerCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CoroutineData *corPtr = data[0]; + Command *cmdPtr = corPtr->cmdPtr; + + /* + * This is the last callback in the caller execEnv, right before switching + * to the coroutine's + */ + + NRE_ASSERT(iPtr->execEnvPtr == corPtr->callerEEPtr); + + if (!corPtr->eePtr) { + /* + * The execEnv was wound down but not deleted for our sake. We finish + * the job here. The caller context has already been restored. + */ + + NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr); + NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); + NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); + ckfree(corPtr); + return result; + } + + NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); + SAVE_CONTEXT(corPtr->running); + RESTORE_CONTEXT(corPtr->caller); + + if (cmdPtr->flags & CMD_IS_DELETED) { + /* + * The command was deleted while it was running: wind down the + * execEnv, this will do the complete cleanup. RewindCoroutine will + * restore both the caller's context and interp state. + */ + + return RewindCoroutine(corPtr, result); + } + + return result; +} + +static int +NRCoroutineExitCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CoroutineData *corPtr = data[0]; + Command *cmdPtr = corPtr->cmdPtr; + + /* + * This runs at the bottom of the Coroutine's execEnv: it will be executed + * when the coroutine returns or is wound down, but not when it yields. It + * deletes the coroutine and restores the caller's environment. + */ + + NRE_ASSERT(interp == corPtr->eePtr->interp); + NRE_ASSERT(TOP_CB(interp) == NULL); + NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); + NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); + NRE_ASSERT((corPtr->callerEEPtr->callbackPtr->procPtr == NRCoroutineCallerCallback)); + + cmdPtr->deleteProc = NULL; + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + TclCleanupCommandMacro(cmdPtr); + + corPtr->eePtr->corPtr = NULL; + TclDeleteExecEnv(corPtr->eePtr); + corPtr->eePtr = NULL; + + corPtr->stackLevel = NULL; + + /* + * #280. + * Drop the coroutine-owned copy of the lineLABCPtr hashtable for literal + * command arguments in bytecode. + */ + + 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 +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, + int objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr; + CoroutineData *corPtr; + ExecEnv *savedEEPtr = iPtr->execEnvPtr; + + /* + * Usage more or less like tailcall: + * inject coroName cmd ?arg1 arg2 ...? + */ + + 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_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a suspended coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); + return TCL_ERROR; + } + + /* + * Add the callback to the coro's execEnv, so that it is the first thing + * to happen when the coro is resumed. + */ + + iPtr->execEnvPtr = corPtr->eePtr; + TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN); + iPtr->execEnvPtr = savedEEPtr; + + 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; + + 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; + } + + /* + * 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! + */ + + 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. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Command *cmdPtr; + CoroutineData *corPtr; + 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 ...?"); + return TCL_ERROR; + } + + /* + * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have + * something in tclUtil.c to find the FQ name. + */ + + fullName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, fullName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + + if (nsPtr == 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_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_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 and create the corresponding command. + */ + + corPtr = ckalloc(sizeof(CoroutineData)); + + Tcl_DStringInit(&ds); + if (nsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + TclDStringAppendLiteral(&ds, "::"); + } + Tcl_DStringAppend(&ds, procName, -1); + + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), + /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); + Tcl_DStringFree(&ds); + + corPtr->cmdPtr = cmdPtr; + cmdPtr->refCount++; + + /* + * #280. + * Provide the new coroutine with its own copy of the lineLABCPtr + * hashtable for literal command arguments in bytecode. Note that that + * CFWordBC chains are not duplicated, only the entrypoints to them. This + * means that in the presence of coroutines each chain is potentially a + * tree. Like the chain -> tree conversion of the CmdFrame stack. + */ + + { + Tcl_HashSearch hSearch; + Tcl_HashEntry *hePtr; + + 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->lineLABCPtr, + Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr), + &isNew); + + Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr)); + } + } + + /* + * Create the base 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 = 0; + + /* + * 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); + + /* 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; +} + +/* + * This is used in the [info] ensemble + */ + +int +TclInfoCoroutineCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { + Tcl_Obj *namePtr; + + TclNewObj(namePtr); + Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, namePtr); + Tcl_SetObjResult(interp, namePtr); + } + return TCL_OK; +} + +#undef iPtr + +/* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ |