diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 9108 |
1 files changed, 9108 insertions, 0 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c new file mode 100644 index 0000000..9d1e98d --- /dev/null +++ b/generic/tclBasic.c @@ -0,0 +1,9108 @@ +/* + * tclBasic.c -- + * + * Contains the basic facilities for TCL command interpretation, + * including interpreter creation and deletion, command creation and + * deletion, and command/script execution. + * + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> + * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. + * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net> + * + * 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 "tommath.h" +#include <math.h> +#include <assert.h> + +#define INTERP_STACK_INITIAL_SIZE 2000 +#define CORO_STACK_INITIAL_SIZE 200 + +/* + * Determine whether we're using IEEE floating point + */ + +#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) +# define IEEE_FLOATING_POINT +/* Largest odd integer that can be represented exactly in a double */ +# define MAX_EXACT 9007199254740991.0 +#endif + +/* + * The following structure defines the client data for a math function + * registered with Tcl_CreateMathFunc + */ + +typedef struct OldMathFuncData { + Tcl_MathProc *proc; /* Handler function */ + int numArgs; /* Number of args expected */ + Tcl_ValueType *argTypes; /* Types of the args */ + ClientData clientData; /* Client data for the handler function */ +} 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 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 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 void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, + int actual, Tcl_Obj *const *objv); +static Tcl_NRPostProc NRCoroutineCallerCallback; +static Tcl_NRPostProc NRCoroutineExitCallback; +static Tcl_NRPostProc NRCommand; + +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, Tcl_Obj *commandPtr, int objc, + Tcl_Obj *const objv[]); +static Tcl_NRPostProc RewindCoroutineCallback; +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 EvalObjvCore; +static Tcl_NRPostProc Dispatch; + +static Tcl_ObjCmdProc NRCoroInjectObjCmd; +static Tcl_NRPostProc NRPostInvoke; + +MODULE_SCOPE const TclStubs tclStubs; + +/* + * Magical counts for the number of arguments accepted by a coroutine command + * after particular kinds of [yield]. + */ + +#define CORO_ACTIVATE_YIELD PTR2INT(NULL) +#define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1 + +#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) +#define COROUTINE_ARGUMENTS_ARBITRARY (-2) + +/* + * The following structure define the commands in the Tcl core. + */ + +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 flags; /* Various flag bits, as defined below. */ +} CmdInfo; + +#define CMD_IS_SAFE 1 /* Whether this command is part of the set of + * commands present by default in a safe + * interpreter. */ +/* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle + * expansion for itself rather than needing the generic layer to take care of + * it for it. Defined in tclInt.h. */ + +/* + * The built-in commands, and the functions that implement them: + */ + +static const CmdInfo builtInCmds[] = { + /* + * Commands in the generic core. + */ + + {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, + {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, + {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, +#ifndef TCL_NO_DEPRECATED + {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, +#endif + {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, + {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, + {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, + {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, + {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, + {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE}, + {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, CMD_IS_SAFE}, + {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE}, + {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE}, + {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE}, + {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE}, + {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, + {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, + {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, + {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, + {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, + {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, + {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, + {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, + {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, + {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, + {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, + {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, + {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"package", Tcl_PackageObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, + {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, + {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, CMD_IS_SAFE}, + {"scan", Tcl_ScanObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, CMD_IS_SAFE}, + {"split", Tcl_SplitObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, CMD_IS_SAFE}, + {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, CMD_IS_SAFE}, + {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, CMD_IS_SAFE}, + {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, CMD_IS_SAFE}, + {"trace", Tcl_TraceObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, CMD_IS_SAFE}, + {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, CMD_IS_SAFE}, + {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, CMD_IS_SAFE}, + {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, CMD_IS_SAFE}, + {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, + {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, + {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, + {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE}, + + /* + * Commands in the OS-interface. Note that many of these are unsafe. + */ + + {"after", Tcl_AfterObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"eof", Tcl_EofObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"exec", Tcl_ExecObjCmd, NULL, NULL, 0}, + {"exit", Tcl_ExitObjCmd, NULL, NULL, 0}, + {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, + {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"flush", Tcl_FlushObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"gets", Tcl_GetsObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"glob", Tcl_GlobObjCmd, NULL, NULL, 0}, + {"load", Tcl_LoadObjCmd, NULL, NULL, 0}, + {"open", Tcl_OpenObjCmd, NULL, NULL, 0}, + {"pid", Tcl_PidObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"puts", Tcl_PutsObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"pwd", Tcl_PwdObjCmd, NULL, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"seek", Tcl_SeekObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"socket", Tcl_SocketObjCmd, NULL, NULL, 0}, + {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, + {"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, + {"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE}, + {NULL, NULL, NULL, NULL, 0} +}; + +/* + * Math functions. All are safe. + */ + +typedef struct { + const char *name; /* Name of the function. The full name is + * "::tcl::mathfunc::<name>". */ + Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */ + ClientData clientData; /* Client data for the function */ +} BuiltinFuncDef; +static const BuiltinFuncDef BuiltinFuncTable[] = { + { "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 }, + { "cosh", ExprUnaryFunc, (ClientData) cosh }, + { "double", ExprDoubleFunc, NULL }, + { "entier", ExprEntierFunc, NULL }, + { "exp", ExprUnaryFunc, (ClientData) exp }, + { "floor", ExprFloorFunc, NULL }, + { "fmod", ExprBinaryFunc, (ClientData) fmod }, + { "hypot", ExprBinaryFunc, (ClientData) hypot }, + { "int", ExprIntFunc, NULL }, + { "isqrt", ExprIsqrtFunc, NULL }, + { "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 }, + { "srand", ExprSrandFunc, NULL }, + { "tan", ExprUnaryFunc, (ClientData) tan }, + { "tanh", ExprUnaryFunc, (ClientData) tanh }, + { "wide", ExprWideFunc, NULL }, + { NULL, NULL, NULL } +}; + +/* + * TIP#174's math operators. All are safe. + */ + +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. */ + union { + int numArgs; + int identity; + } i; + const char *expected; /* For error message, what argument(s) + * were expected. */ +} OpCmdInfo; +static const OpCmdInfo mathOpCmds[] = { + { "~", TclSingleOpCmd, TclCompileInvertOpCmd, + /* numArgs */ {1}, "integer"}, + { "!", TclSingleOpCmd, TclCompileNotOpCmd, + /* numArgs */ {1}, "boolean"}, + { "+", TclVariadicOpCmd, TclCompileAddOpCmd, + /* identity */ {0}, NULL}, + { "*", TclVariadicOpCmd, TclCompileMulOpCmd, + /* identity */ {1}, NULL}, + { "&", TclVariadicOpCmd, TclCompileAndOpCmd, + /* identity */ {-1}, NULL}, + { "|", TclVariadicOpCmd, TclCompileOrOpCmd, + /* identity */ {0}, NULL}, + { "^", TclVariadicOpCmd, TclCompileXorOpCmd, + /* identity */ {0}, NULL}, + { "**", TclVariadicOpCmd, TclCompilePowOpCmd, + /* identity */ {1}, NULL}, + { "<<", TclSingleOpCmd, TclCompileLshiftOpCmd, + /* numArgs */ {2}, "integer shift"}, + { ">>", TclSingleOpCmd, TclCompileRshiftOpCmd, + /* numArgs */ {2}, "integer shift"}, + { "%", TclSingleOpCmd, TclCompileModOpCmd, + /* numArgs */ {2}, "integer integer"}, + { "!=", TclSingleOpCmd, TclCompileNeqOpCmd, + /* numArgs */ {2}, "value value"}, + { "ne", TclSingleOpCmd, TclCompileStrneqOpCmd, + /* numArgs */ {2}, "value value"}, + { "in", TclSingleOpCmd, TclCompileInOpCmd, + /* numArgs */ {2}, "value list"}, + { "ni", TclSingleOpCmd, TclCompileNiOpCmd, + /* numArgs */ {2}, "value list"}, + { "-", TclNoIdentOpCmd, TclCompileMinusOpCmd, + /* unused */ {0}, "value ?value ...?"}, + { "/", TclNoIdentOpCmd, TclCompileDivOpCmd, + /* unused */ {0}, "value ?value ...?"}, + { "<", TclSortingOpCmd, TclCompileLessOpCmd, + /* unused */ {0}, NULL}, + { "<=", TclSortingOpCmd, TclCompileLeqOpCmd, + /* unused */ {0}, NULL}, + { ">", TclSortingOpCmd, TclCompileGreaterOpCmd, + /* unused */ {0}, NULL}, + { ">=", TclSortingOpCmd, TclCompileGeqOpCmd, + /* unused */ {0}, NULL}, + { "==", TclSortingOpCmd, TclCompileEqOpCmd, + /* unused */ {0}, NULL}, + { "eq", TclSortingOpCmd, TclCompileStreqOpCmd, + /* unused */ {0}, NULL}, + { NULL, NULL, NULL, + {0}, NULL} +}; + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeEvaluation -- + * + * Finalizes the script cancellation hash table. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeEvaluation(void) +{ + Tcl_MutexLock(&cancelLock); + if (cancelTableInitialized == 1) { + Tcl_DeleteHashTable(&cancelTable); + cancelTableInitialized = 0; + } + Tcl_MutexUnlock(&cancelLock); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateInterp -- + * + * Create a new TCL command interpreter. + * + * Results: + * The return value is a token for the interpreter, which may be used in + * calls to functions like Tcl_CreateCmd, Tcl_Eval, or Tcl_DeleteInterp. + * + * Side effects: + * The command interpreter is initialized with the built-in commands and + * with the variables documented in tclvars(n). + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_CreateInterp(void) +{ + Interp *iPtr; + Tcl_Interp *interp; + Command *cmdPtr; + const BuiltinFuncDef *builtinFuncPtr; + const OpCmdInfo *opcmdInfoPtr; + const CmdInfo *cmdInfoPtr; + Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr; + Tcl_HashEntry *hPtr; + int isNew; + CancelInfo *cancelInfo; + union { + char c[sizeof(short)]; + short s; + } order; +#ifdef TCL_COMPILE_STATS + ByteCodeStats *statsPtr; +#endif /* TCL_COMPILE_STATS */ + char mathFuncName[32]; + CallFrame *framePtr; + + TclInitSubsystems(); + + /* + * Panic if someone updated the CallFrame structure without also updating + * the Tcl_CallFrame structure (or vice versa). + */ + + if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) { + /*NOTREACHED*/ + Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); + } + +#if defined(_WIN32) && !defined(_WIN64) + if (sizeof(time_t) != 4) { + /*NOTREACHED*/ + Tcl_Panic("<time.h> is not compatible with MSVC"); + } + if ((TclOffset(Tcl_StatBuf,st_atime) != 32) + || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) { + /*NOTREACHED*/ + Tcl_Panic("<sys/stat.h> is not compatible with MSVC"); + } +#endif + + 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 = ckalloc(sizeof(Interp)); + interp = (Tcl_Interp *) iPtr; + +#ifdef TCL_NO_DEPRECATED + iPtr->result = &tclEmptyString; +#else + iPtr->result = iPtr->resultSpace; +#endif + iPtr->freeProc = NULL; + iPtr->errorLine = 0; + iPtr->objResultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(iPtr->objResultPtr); + iPtr->handle = TclHandleCreate(iPtr); + iPtr->globalNsPtr = NULL; + iPtr->hiddenCmdTablePtr = NULL; + iPtr->interpInfo = NULL; + + TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable)); + iPtr->extra.optimizer = TclOptimizeBytecode; + + iPtr->numLevels = 0; + iPtr->maxNestingDepth = MAX_NESTING_DEPTH; + iPtr->framePtr = NULL; /* Initialise as soon as :: is available */ + iPtr->varFramePtr = NULL; /* Initialise as soon as :: is available */ + + /* + * TIP #280 - Initialize the arrays used to extend the ByteCode and Proc + * structures. + */ + + iPtr->cmdFramePtr = NULL; + 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); + Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); + iPtr->scriptCLLocPtr = NULL; + + iPtr->activeVarTracePtr = NULL; + + iPtr->returnOpts = NULL; + 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); + iPtr->returnLevel = 1; + iPtr->returnCode = TCL_OK; + + iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ + iPtr->lookupNsPtr = NULL; + +#ifndef TCL_NO_DEPRECATED + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + iPtr->appendUsed = 0; +#endif + + Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); + iPtr->packageUnknown = NULL; + + /* TIP #268 */ +#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE) + if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { + iPtr->packagePrefer = PKG_PREFER_STABLE; + } else +#endif + iPtr->packagePrefer = PKG_PREFER_LATEST; + + iPtr->cmdCount = 0; + TclInitLiteralTable(&iPtr->literalTable); + iPtr->compileEpoch = 1; + iPtr->compiledProcPtr = NULL; + iPtr->resolverPtr = NULL; + iPtr->evalFlags = 0; + iPtr->scriptFile = NULL; + iPtr->flags = 0; + iPtr->tracePtr = NULL; + iPtr->tracesForbiddingInline = 0; + iPtr->activeCmdTracePtr = NULL; + iPtr->activeInterpTracePtr = NULL; + iPtr->assocData = NULL; + iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ + iPtr->emptyObjPtr = Tcl_NewObj(); + /* Another empty object. */ + Tcl_IncrRefCount(iPtr->emptyObjPtr); +#ifndef TCL_NO_DEPRECATED + iPtr->resultSpace[0] = 0; +#endif + iPtr->threadId = Tcl_GetCurrentThread(); + + /* TIP #378 */ +#ifdef TCL_INTERP_DEBUG_FRAME + iPtr->flags |= INTERP_DEBUG_FRAME; +#else + if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) { + iPtr->flags |= INTERP_DEBUG_FRAME; + } +#endif + + /* + * Initialise the tables for variable traces and searches *before* + * creating the global ns - so that the trace on errorInfo can be + * recorded. + */ + + Tcl_InitHashTable(&iPtr->varTraces, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&iPtr->varSearches, TCL_ONE_WORD_KEYS); + + iPtr->globalNsPtr = NULL; /* Force creation of global ns below. */ + iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", + NULL, NULL); + if (iPtr->globalNsPtr == NULL) { + Tcl_Panic("Tcl_CreateInterp: can't create global namespace"); + } + + /* + * Initialise the rootCallframe. It cannot be allocated on the stack, as + * it has to be in place before TclCreateExecEnv tries to use a variable. + */ + + /* This is needed to satisfy GCC 3.3's strict aliasing rules */ + framePtr = ckalloc(sizeof(CallFrame)); + (void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); + framePtr->objc = 0; + + iPtr->framePtr = framePtr; + iPtr->varFramePtr = framePtr; + iPtr->rootFramePtr = framePtr; + + /* + * Initialize support for code compilation and execution. We call + * TclCreateExecEnv after initializing namespaces since it tries to + * reference a Tcl variable (it links to the Tcl "tcl_traceExec" + * variable). + */ + + iPtr->execEnvPtr = TclCreateExecEnv(interp, INTERP_STACK_INITIAL_SIZE); + + /* + * TIP #219, Tcl Channel Reflection API support. + */ + + 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->numExecutions = 0; + statsPtr->numCompilations = 0; + statsPtr->numByteCodesFreed = 0; + memset(statsPtr->instructionCount, 0, + sizeof(statsPtr->instructionCount)); + + statsPtr->totalSrcBytes = 0.0; + statsPtr->totalByteCodeBytes = 0.0; + statsPtr->currentSrcBytes = 0.0; + statsPtr->currentByteCodeBytes = 0.0; + 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; + statsPtr->currentExceptBytes = 0.0; + statsPtr->currentAuxBytes = 0.0; + statsPtr->currentCmdMapBytes = 0.0; + + statsPtr->numLiteralsCreated = 0; + statsPtr->totalLitStringBytes = 0.0; + statsPtr->currentLitStringBytes = 0.0; + memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); +#endif /* TCL_COMPILE_STATS */ + + /* + * Initialise the stub table pointer. + */ + + iPtr->stubTable = &tclStubs; + + /* + * Initialize the ensemble error message rewriting support. + */ + + TclResetRewriteEnsemble(interp, 1); + + /* + * TIP#143: Initialise the resource limit support. + */ + + TclInitLimitSupport(interp); + + /* + * 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) + iPtr->allocCache = TclpGetAllocCache(); +#else + iPtr->allocCache = NULL; +#endif + iPtr->pendingObjDataPtr = NULL; + iPtr->asyncReadyPtr = TclGetAsyncReadyPtr(); + iPtr->deferredCallbacks = NULL; + + /* + * Create the core commands. Do it here, rather than calling + * Tcl_CreateCommand, because it's faster (there's no need to check for a + * pre-existing command by the same name). If a command has a Tcl_CmdProc + * but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to + * TclInvokeStringCommand. This is an object-based wrapper function that + * extracts strings, calls the string function, and creates an object for + * the result. Similarly, if a command has a Tcl_ObjCmdProc but no + * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. + */ + + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + if ((cmdInfoPtr->objProc == 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 = ckalloc(sizeof(Command)); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = iPtr->globalNsPtr; + cmdPtr->refCount = 1; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = cmdInfoPtr->compileProc; + cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->clientData = cmdPtr; + cmdPtr->objProc = cmdInfoPtr->objProc; + cmdPtr->objClientData = NULL; + cmdPtr->deleteProc = NULL; + cmdPtr->deleteData = NULL; + cmdPtr->flags = 0; + if (cmdInfoPtr->flags & CMD_COMPILES_EXPANDED) { + cmdPtr->flags |= CMD_COMPILES_EXPANDED; + } + cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; + cmdPtr->nreProc = cmdInfoPtr->nreProc; + Tcl_SetHashValue(hPtr, cmdPtr); + } + } + + /* + * Create the "array", "binary", "chan", "clock", "dict", "encoding", + * "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 "clock", "encoding" and "file". + */ + + TclInitArrayCmd(interp); + TclInitBinaryCmd(interp); + TclInitChanCmd(interp); + TclInitDictCmd(interp); + TclInitEncodingCmd(interp); + TclInitFileCmd(interp); + TclInitInfoCmd(interp); + TclInitNamespaceCmd(interp); + TclInitStringCmd(interp); + TclInitPrefixCmd(interp); + + /* + * Register "clock" subcommands. These *do* go through + * Tcl_CreateObjCommand, since they aren't in the global namespace and + * involve ensembles. + */ + + TclClockInit(interp); + + /* + * Register the built-in functions. This is empty now that they are + * implemented as commands in the ::tcl::mathfunc namespace. + */ + + /* + * Register the default [interp bgerror] handler. + */ + + Tcl_CreateObjCommand(interp, "::tcl::Bgerror", + TclDefaultBgErrorHandlerObjCmd, NULL, NULL); + + /* + * Create unsupported commands for debugging bytecode and objects. + */ + + Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", + Tcl_DisassembleObjCmd, INT2PTR(0), NULL); + Tcl_CreateObjCommand(interp, "::tcl::unsupported::getbytecode", + Tcl_DisassembleObjCmd, INT2PTR(1), 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 + /* + * Register the tcl::dtrace command. + */ + + Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL); +#endif /* USE_DTRACE */ + + /* + * Register the builtin math functions. + */ + + mathfuncNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL); + if (mathfuncNSPtr == NULL) { + Tcl_Panic("Can't create math function namespace"); + } +#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); + Tcl_CreateObjCommand(interp, mathFuncName, + builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL); + Tcl_Export(interp, mathfuncNSPtr, builtinFuncPtr->name, 0); + } + + /* + * Register the mathematical "operator" commands. [TIP #174] + */ + + mathopNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL); + if (mathopNSPtr == NULL) { + Tcl_Panic("can't create math operator namespace"); + } + 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 = ckalloc(sizeof(TclOpCmdClientData)); + + occdPtr->op = opcmdInfoPtr->name; + occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs; + occdPtr->expected = opcmdInfoPtr->expected; + strcpy(mathFuncName + MATH_OP_PREFIX_LEN, opcmdInfoPtr->name); + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, mathFuncName, + opcmdInfoPtr->objProc, occdPtr, DeleteOpCmdClientData); + if (cmdPtr == NULL) { + Tcl_Panic("failed to create math operator %s", + opcmdInfoPtr->name); + } else if (opcmdInfoPtr->compileProc != NULL) { + cmdPtr->compileProc = opcmdInfoPtr->compileProc; + } + } + + /* + * Do Multiple/Safe Interps Tcl init stuff + */ + + TclInterpInit(interp); + TclSetupEnv(interp); + + /* + * TIP #59: Make embedded configuration information available. + */ + + TclInitEmbeddedConfigurationInformation(interp); + + /* + * TIP #440: Declare the name of the script engine to be "Tcl". + */ + + Tcl_SetVar2(interp, "tcl_platform", "engine", "Tcl", + TCL_GLOBAL_ONLY); + + /* + * Compute the byte order of this machine. + */ + + order.s = 1; + Tcl_SetVar2(interp, "tcl_platform", "byteOrder", + ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), + TCL_GLOBAL_ONLY); + + Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize", + Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY); + + /* TIP #291 */ + Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize", + Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY); + + /* + * Set up other variables such as tcl_version and tcl_library + */ + + Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY); + Tcl_TraceVar2(interp, "tcl_precision", NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, NULL); + TclpSetVariables(interp); + +#ifdef TCL_THREADS + /* + * The existence of the "threaded" element of the tcl_platform array + * indicates that this particular Tcl shell has been compiled with threads + * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can + * introspect on the interpreter level of thread safety. + */ + + Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY); +#endif + + /* + * Register Tcl's version number. + * TIP #268: Full patchlevel instead of just major.minor + */ + + Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); + + if (TclTommath_Init(interp) != TCL_OK) { + Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + } + + if (TclOOInit(interp) != TCL_OK) { + Tcl_Panic("%s", TclGetString(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", TclGetString(Tcl_GetObjResult(interp))); + } +#endif + + TOP_CB(iPtr) = NULL; + return interp; +} + +static void +DeleteOpCmdClientData( + ClientData clientData) +{ + TclOpCmdClientData *occdPtr = clientData; + + ckfree(occdPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclHideUnsafeCommands -- + * + * Hides base commands that are not marked as safe from this interpreter. + * + * Results: + * TCL_OK if it succeeds, TCL_ERROR else. + * + * Side effects: + * Hides functionality in an interpreter. + * + *---------------------------------------------------------------------- + */ + +int +TclHideUnsafeCommands( + Tcl_Interp *interp) /* Hide commands in this interpreter. */ +{ + register const CmdInfo *cmdInfoPtr; + + if (interp == NULL) { + return TCL_ERROR; + } + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) { + Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); + } + } + TclMakeEncodingCommandSafe(interp); /* Ugh! */ + TclMakeFileCommandSafe(interp); /* Ugh! */ + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_CallWhenDeleted -- + * + * Arrange for a function to be called before a given interpreter is + * deleted. The function is called as soon as Tcl_DeleteInterp is called; + * if Tcl_CallWhenDeleted is called on an interpreter that has already + * been deleted, the function will be called when the last Tcl_Release is + * done on the interpreter. + * + * Results: + * None. + * + * Side effects: + * When Tcl_DeleteInterp is invoked to delete interp, proc will be + * invoked. See the manual entry for details. + * + *-------------------------------------------------------------- + */ + +void +Tcl_CallWhenDeleted( + Tcl_Interp *interp, /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about + * to be deleted. */ + ClientData clientData) /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + static Tcl_ThreadDataKey assocDataCounterKey; + int *assocDataCounterPtr = + Tcl_GetThreadData(&assocDataCounterKey, sizeof(int)); + int isNew; + char buffer[32 + TCL_INTEGER_SPACE]; + AssocData *dPtr = ckalloc(sizeof(AssocData)); + Tcl_HashEntry *hPtr; + + sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr); + (*assocDataCounterPtr)++; + + if (iPtr->assocData == NULL) { + iPtr->assocData = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + } + hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew); + dPtr->proc = proc; + dPtr->clientData = clientData; + Tcl_SetHashValue(hPtr, dPtr); +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DontCallWhenDeleted -- + * + * Cancel the arrangement for a function to be called when a given + * interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * If proc and clientData were previously registered as a callback via + * Tcl_CallWhenDeleted, they are unregistered. If they weren't previously + * registered then nothing happens. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DontCallWhenDeleted( + Tcl_Interp *interp, /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about + * to be deleted. */ + ClientData clientData) /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTablePtr; + Tcl_HashSearch hSearch; + Tcl_HashEntry *hPtr; + AssocData *dPtr; + + hTablePtr = iPtr->assocData; + if (hTablePtr == NULL) { + return; + } + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + dPtr = Tcl_GetHashValue(hPtr); + if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { + ckfree(dPtr); + Tcl_DeleteHashEntry(hPtr); + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetAssocData -- + * + * Creates a named association between user-specified data, a delete + * function and this interpreter. If the association already exists the + * data is overwritten with the new data. The delete function will be + * invoked when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * Sets the associated data, creates the association if needed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetAssocData( + Tcl_Interp *interp, /* Interpreter to associate with. */ + const char *name, /* Name for association. */ + Tcl_InterpDeleteProc *proc, /* Proc to call when interpreter is about to + * be deleted. */ + ClientData clientData) /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + int isNew; + + if (iPtr->assocData == NULL) { + 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 = ckalloc(sizeof(AssocData)); + } + dPtr->proc = proc; + dPtr->clientData = clientData; + + Tcl_SetHashValue(hPtr, dPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteAssocData -- + * + * Deletes a named association of user-specified data with the specified + * interpreter. + * + * Results: + * None. + * + * Side effects: + * Deletes the association. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteAssocData( + Tcl_Interp *interp, /* Interpreter to associate with. */ + const char *name) /* Name of association. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + + if (iPtr->assocData == NULL) { + return; + } + hPtr = Tcl_FindHashEntry(iPtr->assocData, name); + if (hPtr == NULL) { + return; + } + dPtr = Tcl_GetHashValue(hPtr); + if (dPtr->proc != NULL) { + dPtr->proc(dPtr->clientData, interp); + } + ckfree(dPtr); + Tcl_DeleteHashEntry(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetAssocData -- + * + * Returns the client data associated with this name in the specified + * interpreter. + * + * Results: + * The client data in the AssocData record denoted by the named + * association, or NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_GetAssocData( + Tcl_Interp *interp, /* Interpreter associated with. */ + const char *name, /* Name of association. */ + Tcl_InterpDeleteProc **procPtr) + /* Pointer to place to store address of + * current deletion callback. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + + if (iPtr->assocData == NULL) { + return NULL; + } + hPtr = Tcl_FindHashEntry(iPtr->assocData, name); + if (hPtr == NULL) { + return NULL; + } + dPtr = Tcl_GetHashValue(hPtr); + if (procPtr != NULL) { + *procPtr = dPtr->proc; + } + return dPtr->clientData; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InterpDeleted -- + * + * Returns nonzero if the interpreter has been deleted with a call to + * Tcl_DeleteInterp. + * + * Results: + * Nonzero if the interpreter is deleted, zero otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InterpDeleted( + Tcl_Interp *interp) +{ + return (((Interp *) interp)->flags & DELETED) ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteInterp -- + * + * Ensures that the interpreter will be deleted eventually. If there are + * no Tcl_Preserve calls in effect for this interpreter, it is deleted + * immediately, otherwise the interpreter is deleted when the last + * Tcl_Preserve is matched by a call to Tcl_Release. In either case, the + * function runs the currently registered deletion callbacks. + * + * Results: + * None. + * + * Side effects: + * The interpreter is marked as deleted. The caller may still use it + * safely if there are calls to Tcl_Preserve in effect for the + * interpreter, but further calls to Tcl_Eval etc in this interpreter + * will fail. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteInterp( + Tcl_Interp *interp) /* Token for command interpreter (returned by + * a previous call to Tcl_CreateInterp). */ +{ + Interp *iPtr = (Interp *) interp; + + /* + * If the interpreter has already been marked deleted, just punt. + */ + + if (iPtr->flags & DELETED) { + return; + } + + /* + * Mark the interpreter as deleted. No further evals will be allowed. + * Increase the compileEpoch as a signal to compiled bytecodes. + */ + + iPtr->flags |= DELETED; + iPtr->compileEpoch++; + + /* + * Ensure that the interpreter is eventually deleted. + */ + + Tcl_EventuallyFree(interp, (Tcl_FreeProc *) DeleteInterpProc); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteInterpProc -- + * + * Helper function to delete an interpreter. This function is called when + * the last call to Tcl_Preserve on this interpreter is matched by a call + * to Tcl_Release. The function cleans up all resources used in the + * interpreter and calls all currently registered interpreter deletion + * callbacks. + * + * Results: + * None. + * + * Side effects: + * Whatever the interpreter deletion callbacks do. Frees resources used + * by the interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteInterpProc( + Tcl_Interp *interp) /* Interpreter to delete. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable *hTablePtr; + ResolverScheme *resPtr, *nextResPtr; + int i; + + /* + * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup, + * unless we are exiting. + */ + + if ((iPtr->numLevels > 0) && !TclInExit()) { + Tcl_Panic("DeleteInterpProc called with active evals"); + } + + /* + * The interpreter should already be marked deleted; otherwise how did we + * get here? + */ + + if (!(iPtr->flags & DELETED)) { + Tcl_Panic("DeleteInterpProc called on interpreter not marked deleted"); + } + + /* + * TIP #219, Tcl Channel Reflection API. Discard a leftover state. + */ + + if (iPtr->chanMsg != NULL) { + Tcl_DecrRefCount(iPtr->chanMsg); + iPtr->chanMsg = NULL; + } + + /* + * 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. + */ + + TclRemoveScriptLimitCallbacks(interp); + TclLimitRemoveAllHandlers(interp); + + /* + * Dismantle the namespace here, before we clear the assocData. If any + * background errors occur here, they will be deleted below. + * + * Dismantle the namespace after freeing the iPtr->handle so that each + * bytecode releases its literals without caring to update the literal + * table, as it will be freed later in this function without further use. + */ + + TclHandleFree(iPtr->handle); + TclTeardownNamespace(iPtr->globalNsPtr); + + /* + * Delete all the hidden commands. + */ + + hTablePtr = iPtr->hiddenCmdTablePtr; + if (hTablePtr != NULL) { + /* + * 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 + * hiddenCmdTablePtr. + */ + + hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree(hTablePtr); + } + + /* + * Invoke deletion callbacks; note that a callback can create new + * callbacks, so we iterate. + */ + + while (iPtr->assocData != NULL) { + AssocData *dPtr; + + hTablePtr = iPtr->assocData; + iPtr->assocData = NULL; + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { + dPtr = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (dPtr->proc != NULL) { + dPtr->proc(dPtr->clientData, interp); + } + ckfree(dPtr); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree(hTablePtr); + } + + /* + * Pop the root frame pointer and finish deleting the global + * namespace. The order is important [Bug 1658572]. + */ + + if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) { + Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); + } + Tcl_PopCallFrame(interp); + ckfree(iPtr->rootFramePtr); + iPtr->rootFramePtr = NULL; + Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); + + /* + * Free up the result *after* deleting variables, since variable deletion + * could have transferred ownership of the result string to Tcl. + */ + + Tcl_FreeResult(interp); + iPtr->result = NULL; + Tcl_DecrRefCount(iPtr->objResultPtr); + iPtr->objResultPtr = NULL; + Tcl_DecrRefCount(iPtr->ecVar); + if (iPtr->errorCode) { + Tcl_DecrRefCount(iPtr->errorCode); + iPtr->errorCode = NULL; + } + Tcl_DecrRefCount(iPtr->eiVar); + if (iPtr->errorInfo) { + 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); + } +#ifndef TCL_NO_DEPRECATED + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + } +#endif + TclFreePackageInfo(iPtr); + while (iPtr->tracePtr != NULL) { + Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); + } + if (iPtr->execEnvPtr != NULL) { + TclDeleteExecEnv(iPtr->execEnvPtr); + } + if (iPtr->scriptFile) { + Tcl_DecrRefCount(iPtr->scriptFile); + iPtr->scriptFile = NULL; + } + Tcl_DecrRefCount(iPtr->emptyObjPtr); + iPtr->emptyObjPtr = NULL; + + resPtr = iPtr->resolverPtr; + while (resPtr) { + nextResPtr = resPtr->nextPtr; + ckfree(resPtr->name); + ckfree(resPtr); + resPtr = nextResPtr; + } + + /* + * Free up literal objects created for scripts compiled by the + * interpreter. + */ + + TclDeleteLiteralTable(interp, &iPtr->literalTable); + + /* + * TIP #280 - Release the arrays for ByteCode/Proc extension, and + * contents. + */ + + for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + CmdFrame *cfPtr = Tcl_GetHashValue(hPtr); + Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr); + + procPtr->iPtr = NULL; + if (cfPtr) { + if (cfPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(cfPtr->data.eval.path); + } + ckfree(cfPtr->line); + ckfree(cfPtr); + } + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(iPtr->linePBodyPtr); + ckfree(iPtr->linePBodyPtr); + iPtr->linePBodyPtr = NULL; + + /* + * See also tclCompile.c, TclCleanupByteCode + */ + + 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(eclPtr->loc[i].line); + } + + if (eclPtr->loc != NULL) { + ckfree(eclPtr->loc); + } + + 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()) { + /* + * 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_DeleteHashTable(iPtr->lineLAPtr); + ckfree(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. + */ + + Tcl_Panic("Argument location tracking table not empty"); + } + + Tcl_DeleteHashTable(iPtr->lineLABCPtr); + ckfree(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(iPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_HideCommand -- + * + * Makes a command hidden so that it cannot be invoked from within an + * interpreter, only from within an ancestor. + * + * Results: + * A standard Tcl result; also leaves a message in the interp's result if + * an error occurs. + * + * Side effects: + * Removes a command from the command table and create an entry into the + * hidden command table under the specified token name. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_HideCommand( + Tcl_Interp *interp, /* Interpreter in which to hide command. */ + const char *cmdName, /* Name of command to hide. */ + const char *hiddenCmdToken) /* Token name of the to-be-hidden command. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Command cmd; + Command *cmdPtr; + Tcl_HashTable *hiddenCmdTablePtr; + Tcl_HashEntry *hPtr; + int isNew; + + if (iPtr->flags & DELETED) { + /* + * The interpreter is being deleted. Do not create any new structures, + * because it is not safe to modify the interpreter. + */ + + return TCL_ERROR; + } + + /* + * Disallow hiding of commands that are currently in a namespace or + * renaming (as part of hiding) into a namespace (because the current + * implementation with a single global table and the needed uniqueness of + * names cause problems with namespaces). + * + * We don't need to check for "::" in cmdName because the real check is on + * the nsPtr below. + * + * hiddenCmdToken is just a string which is not interpreted in any way. It + * may contain :: but the string is not interpreted as a namespace + * qualifier command name. Thus, hiding foo::bar to foo::bar and then + * trying to expose or invoke ::foo::bar will NOT work; but if the + * application always uses the same strings it will get consistent + * behaviour. + * + * But as we currently limit ourselves to the global namespace only for + * the source, in order to avoid potential confusion, lets prevent "::" in + * the token too. - dl + */ + + if (strstr(hiddenCmdToken, "::") != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot use namespace qualifiers in hidden command" + " token (rename)", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL); + return TCL_ERROR; + } + + /* + * Find the command to hide. An error is returned if cmdName can't be + * found. Look up the command only from the global namespace. Full path of + * the command must be given if using namespaces. + */ + + cmd = Tcl_FindCommand(interp, cmdName, NULL, + /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); + if (cmd == (Tcl_Command) NULL) { + return TCL_ERROR; + } + cmdPtr = (Command *) cmd; + + /* + * Check that the command is really in global namespace + */ + + if (cmdPtr->nsPtr != iPtr->globalNsPtr) { + 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; + } + + /* + * Initialize the hidden command table if necessary. + */ + + hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; + if (hiddenCmdTablePtr == NULL) { + hiddenCmdTablePtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); + iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; + } + + /* + * It is an error to move an exposed command to a hidden command with + * hiddenCmdToken if a hidden command with the name hiddenCmdToken already + * exists. + */ + + hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew); + if (!isNew) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "hidden command named \"%s\" already exists", + hiddenCmdToken)); + Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL); + return TCL_ERROR; + } + + /* + * NB: This code is currently 'like' a rename to a specialy set apart name + * table. Changes here and in TclRenameCommand must be kept in synch until + * the common parts are actually factorized out. + */ + + /* + * Remove the hash entry for the command from the interpreter command + * table. This is like deleting the command, so bump its command epoch; + * this invalidates any cached references that point to the command. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + cmdPtr->cmdEpoch++; + } + + /* + * 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. + */ + + TclInvalidateNsCmdLookup(cmdPtr->nsPtr); + + /* + * Now link the hash table entry with the command structure. We ensured + * above that the nsPtr was right. + */ + + cmdPtr->hPtr = hPtr; + Tcl_SetHashValue(hPtr, cmdPtr); + + /* + * If the command being hidden has a compile function, increment the + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled with + * command-specific (i.e., inline) bytecodes for the now-hidden command. + * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose + * compilation epoch doesn't match is recompiled. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExposeCommand -- + * + * Makes a previously hidden command callable from inside the interpreter + * instead of only by its ancestors. + * + * Results: + * A standard Tcl result. If an error occurs, a message is left in the + * interp's result. + * + * Side effects: + * Moves commands from one hash table to another. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ExposeCommand( + Tcl_Interp *interp, /* Interpreter in which to make command + * callable. */ + const char *hiddenCmdToken, /* Name of hidden command. */ + const char *cmdName) /* Name of to-be-exposed command. */ +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr; + Namespace *nsPtr; + Tcl_HashEntry *hPtr; + Tcl_HashTable *hiddenCmdTablePtr; + int isNew; + + if (iPtr->flags & DELETED) { + /* + * The interpreter is being deleted. Do not create any new structures, + * because it is not safe to modify the interpreter. + */ + + return TCL_ERROR; + } + + /* + * Check that we have a regular name for the command (that the user is not + * trying to do an expose and a rename (to another namespace) at the same + * time). + */ + + if (strstr(cmdName, "::") != 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; + } + + /* + * Get the command from the hidden command table: + */ + + hPtr = NULL; + hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; + if (hiddenCmdTablePtr != NULL) { + hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); + } + if (hPtr == 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 + * really know how to handle it). + */ + + if (cmdPtr->nsPtr != iPtr->globalNsPtr) { + /* + * This case is theoritically impossible, we might rather Tcl_Panic + * than 'nicely' erroring out ? + */ + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "trying to expose a non-global command namespace command", + -1)); + return TCL_ERROR; + } + + /* + * This is the global table. + */ + + nsPtr = cmdPtr->nsPtr; + + /* + * It is an error to overwrite an existing exposed command as a result of + * exposing a previously hidden command. + */ + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); + if (!isNew) { + 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. + */ + + TclInvalidateNsCmdLookup(nsPtr); + + /* + * Remove the hash entry for the command from the interpreter hidden + * command table. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + } + + /* + * Now link the hash table entry with the command structure. This is like + * creating a new command, so deal with any shadowing of commands in the + * global namespace. + */ + + cmdPtr->hPtr = hPtr; + + Tcl_SetHashValue(hPtr, cmdPtr); + + /* + * Not needed as we are only in the global namespace (but would be needed + * again if we supported namespace command hiding) + * + * TclResetShadowedCmdRefs(interp, cmdPtr); + */ + + /* + * If the command being exposed has a compile function, increment + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled assuming the + * command is hidden. This field is checked in Tcl_EvalObj and + * ObjInterpProc, and code whose compilation epoch doesn't match is + * recompiled. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateCommand -- + * + * Define a new 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 a command named cmdName already exists for interp, it is deleted. + * In the future, when cmdName is seen as the name of a command by + * Tcl_Eval, proc will be called. To support the bytecode interpreter, + * the command is created with a wrapper Tcl_ObjCmdProc + * (TclInvokeStringCommand) that eventially calls proc. 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_CreateCommand( + Tcl_Interp *interp, /* Token for command interpreter returned by a + * 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_CmdProc *proc, /* Function to associate with cmdName. */ + ClientData clientData, /* Arbitrary value passed to string proc. */ + Tcl_CmdDeleteProc *deleteProc) + /* If not NULL, gives a function to call when + * this command is deleted. */ +{ + Interp *iPtr = (Interp *) interp; + ImportRef *oldRefPtr = NULL; + Namespace *nsPtr, *dummy1, *dummy2; + Command *cmdPtr, *refCmdPtr; + Tcl_HashEntry *hPtr; + const char *tail; + int isNew; + ImportedCmdData *dataPtr; + + if (iPtr->flags & DELETED) { + /* + * The interpreter is being deleted. Don't create any new commands; + * it's not safe to muck with the interpreter anymore. + */ + + return (Tcl_Command) NULL; + } + + /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; otherwise, + * we always put it in the global namespace. + */ + + if (strstr(cmdName, "::") != NULL) { + TclGetNamespaceForQualName(interp, cmdName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + if (!isNew) { + /* + * Command already exists. Delete the old one. Be careful to preserve + * any existing import links so we can restore them down below. That + * way, you can redefine a command and its import status will remain + * intact. + */ + + cmdPtr = Tcl_GetHashValue(hPtr); + cmdPtr->refCount++; + if (cmdPtr->importRefPtr) { + cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; + } + + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + } + TclCleanupCommandMacro(cmdPtr); + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + if (!isNew) { + /* + * If the deletion callback recreated the command, just throw away + * the new command (if we try to delete it again, we could get + * stuck in an infinite loop). + */ + + 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. + */ + + TclInvalidateNsCmdLookup(nsPtr); + TclInvalidateNsPath(nsPtr); + } + cmdPtr = ckalloc(sizeof(Command)); + Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = nsPtr; + cmdPtr->refCount = 1; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = NULL; + cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objClientData = cmdPtr; + cmdPtr->proc = proc; + cmdPtr->clientData = clientData; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; + cmdPtr->flags = 0; + cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; + cmdPtr->nreProc = NULL; + + /* + * Plug in any existing import references found above. Be sure to update + * all of these references to point to the new command. + */ + + if (oldRefPtr != NULL) { + cmdPtr->importRefPtr = oldRefPtr; + while (oldRefPtr != NULL) { + refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = refCmdPtr->objClientData; + dataPtr->realCmdPtr = cmdPtr; + oldRefPtr = oldRefPtr->nextPtr; + } + } + + /* + * We just created a command, so in its namespace and all of its parent + * namespaces, it may shadow global commands with the same name. If any + * shadowed commands are found, invalidate all cached command references + * in the affected namespaces. + */ + + TclResetShadowedCmdRefs(interp, cmdPtr); + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateObjCommand -- + * + * Define a new 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 a command named "cmdName" already exists for interp, it is + * first deleted. Then the new command is created from the arguments. + * [***] (See below for exception). + * + * In the future, during bytecode evaluation when "cmdName" is seen as + * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based + * 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_CreateObjCommand( + 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. */ + 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. */ +{ + Interp *iPtr = (Interp *) interp; + ImportRef *oldRefPtr = NULL; + Namespace *nsPtr, *dummy1, *dummy2; + Command *cmdPtr, *refCmdPtr; + Tcl_HashEntry *hPtr; + const char *tail; + int isNew; + ImportedCmdData *dataPtr; + + if (iPtr->flags & DELETED) { + /* + * The interpreter is being deleted. Don't create any new commands; + * it's not safe to muck with the interpreter anymore. + */ + + return (Tcl_Command) NULL; + } + + /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; otherwise, + * we always put it in the global namespace. + */ + + if (strstr(cmdName, "::") != NULL) { + TclGetNamespaceForQualName(interp, cmdName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + TclInvalidateNsPath(nsPtr); + if (!isNew) { + cmdPtr = Tcl_GetHashValue(hPtr); + + /* Command already exists. */ + + /* + * [***] This is wrong. See Tcl Bug a16752c252. + * However, this buggy behavior is kept under particular + * circumstances to accommodate deployed binaries of the + * "tclcompiler" program. http://sourceforge.net/projects/tclpro/ + * that crash if the bug is fixed. + */ + + if (cmdPtr->objProc == TclInvokeStringCommand + && cmdPtr->clientData == clientData + && cmdPtr->deleteData == clientData + && cmdPtr->deleteProc == deleteProc) { + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + return (Tcl_Command) cmdPtr; + } + + /* + * Otherwise, we delete the old command. Be careful to preserve any + * existing import links so we can restore them down below. That way, + * you can redefine a command and its import status will remain + * intact. + */ + + cmdPtr->refCount++; + if (cmdPtr->importRefPtr) { + cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; + } + + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + } + TclCleanupCommandMacro(cmdPtr); + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + if (!isNew) { + /* + * If the deletion callback recreated the command, just throw away + * the new command (if we try to delete it again, we could get + * stuck in an infinite loop). + */ + + 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. + */ + + TclInvalidateNsCmdLookup(nsPtr); + } + cmdPtr = ckalloc(sizeof(Command)); + Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = nsPtr; + cmdPtr->refCount = 1; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = NULL; + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->clientData = cmdPtr; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; + cmdPtr->flags = 0; + cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; + cmdPtr->nreProc = NULL; + + /* + * Plug in any existing import references found above. Be sure to update + * all of these references to point to the new command. + */ + + if (oldRefPtr != NULL) { + cmdPtr->importRefPtr = oldRefPtr; + while (oldRefPtr != NULL) { + refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = refCmdPtr->objClientData; + dataPtr->realCmdPtr = cmdPtr; + oldRefPtr = oldRefPtr->nextPtr; + } + } + + /* + * We just created a command, so in its namespace and all of its parent + * namespaces, it may shadow global commands with the same name. If any + * shadowed commands are found, invalidate all cached command references + * in the affected namespaces. + */ + + TclResetShadowedCmdRefs(interp, cmdPtr); + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclInvokeStringCommand -- + * + * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based + * Tcl_CmdProc if no object-based function exists for a command. A + * pointer to this function is stored as the Tcl_ObjCmdProc in a Command + * structure. It simply turns around and calls the string Tcl_CmdProc in + * the Command structure. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * Besides those side effects of the called Tcl_CmdProc, + * TclInvokeStringCommand allocates and frees storage. + * + *---------------------------------------------------------------------- + */ + +int +TclInvokeStringCommand( + ClientData clientData, /* Points to command's Command structure. */ + Tcl_Interp *interp, /* Current interpreter. */ + register int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Command *cmdPtr = clientData; + int i, result; + const char **argv = + TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); + + for (i = 0; i < objc; i++) { + argv[i] = TclGetString(objv[i]); + } + argv[objc] = 0; + + /* + * Invoke the command's string-based Tcl_CmdProc. + */ + + result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv); + + TclStackFree(interp, (void *) argv); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclInvokeObjectCommand -- + * + * "Wrapper" Tcl_CmdProc used to call an existing object-based + * Tcl_ObjCmdProc if no string-based function exists for a command. A + * pointer to this function is stored as the Tcl_CmdProc in a Command + * structure. It simply turns around and calls the object Tcl_ObjCmdProc + * in the Command structure. + * + * Results: + * A standard Tcl string result value. + * + * Side effects: + * Besides those side effects of the called Tcl_ObjCmdProc, + * TclInvokeObjectCommand allocates and frees storage. + * + *---------------------------------------------------------------------- + */ + +int +TclInvokeObjectCommand( + ClientData clientData, /* Points to command's Command structure. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + register const char **argv) /* Argument strings. */ +{ + Command *cmdPtr = clientData; + Tcl_Obj *objPtr; + int i, length, result; + Tcl_Obj **objv = + TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *))); + + for (i = 0; i < argc; i++) { + length = strlen(argv[i]); + TclNewStringObj(objPtr, argv[i], length); + Tcl_IncrRefCount(objPtr); + objv[i] = objPtr; + } + + /* + * Invoke the command's object-based Tcl_ObjCmdProc. + */ + + 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 + * the object result. + */ + + (void) Tcl_GetStringResult(interp); + + /* + * Decrement the ref counts for the argument objects created above, then + * free the objv array if malloc'ed storage was used. + */ + + for (i = 0; i < argc; i++) { + objPtr = objv[i]; + Tcl_DecrRefCount(objPtr); + } + TclStackFree(interp, objv); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclRenameCommand -- + * + * Called to give an existing Tcl command a different name. Both the old + * command name and the new command name can have "::" namespace + * qualifiers. If the new command has a different namespace context, the + * command will be moved to that namespace and will execute in the + * context of that new namespace. + * + * If the new command name is NULL or the null string, the command is + * deleted. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, an error message is returned in the + * interpreter's result object. + * + *---------------------------------------------------------------------- + */ + +int +TclRenameCommand( + Tcl_Interp *interp, /* Current interpreter. */ + const char *oldName, /* Existing command name. */ + const char *newName) /* New command name. */ +{ + Interp *iPtr = (Interp *) interp; + const char *newTail; + Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; + Tcl_Command cmd; + Command *cmdPtr; + Tcl_HashEntry *hPtr, *oldHPtr; + int isNew, result; + Tcl_Obj *oldFullName; + Tcl_DString newFullName; + + /* + * Find the existing command. An error is returned if cmdName can't be + * found. + */ + + cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0); + cmdPtr = (Command *) cmd; + if (cmdPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't %s \"%s\": command doesn't exist", + ((newName == NULL)||(*newName == '\0'))? "delete":"rename", + oldName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); + return TCL_ERROR; + } + cmdNsPtr = cmdPtr->nsPtr; + oldFullName = Tcl_NewObj(); + Tcl_IncrRefCount(oldFullName); + Tcl_GetCommandFullName(interp, cmd, oldFullName); + + /* + * If the new command name is NULL or empty, delete the command. Do this + * with Tcl_DeleteCommandFromToken, since we already have the command. + */ + + if ((newName == NULL) || (*newName == '\0')) { + Tcl_DeleteCommandFromToken(interp, cmd); + result = TCL_OK; + goto done; + } + + /* + * Make sure that the destination command does not already exist. The + * rename operation is like creating a command, so we should automatically + * create the containing namespaces just like Tcl_CreateCommand would. + */ + + TclGetNamespaceForQualName(interp, newName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); + + if ((newNsPtr == NULL) || (newTail == 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_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). + * - dl + */ + + /* + * Put the command in the new namespace so we can check for an alias loop. + * Since we are adding a new command to a namespace, we must handle any + * shadowing of the global commands that this might create. + */ + + oldHPtr = cmdPtr->hPtr; + hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &isNew); + Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = newNsPtr; + TclResetShadowedCmdRefs(interp, cmdPtr); + + /* + * Now check for an alias loop. If we detect one, put everything back the + * way it was and report the error. + */ + + result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); + if (result != TCL_OK) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = oldHPtr; + cmdPtr->nsPtr = cmdNsPtr; + goto done; + } + + /* + * 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. These might refer to the same variable, + * but that's no big deal. + */ + + TclInvalidateNsCmdLookup(cmdNsPtr); + 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 + * TclCleanupCommand. + * + * The trace function needs to get a fully qualified name for old and new + * commands [Tcl bug #651271], or else there's no way for the trace + * function to get the namespace from which the old command is being + * renamed! + */ + + Tcl_DStringInit(&newFullName); + Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1); + if (newNsPtr != iPtr->globalNsPtr) { + TclDStringAppendLiteral(&newFullName, "::"); + } + Tcl_DStringAppend(&newFullName, newTail, -1); + cmdPtr->refCount++; + CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName), + Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); + Tcl_DStringFree(&newFullName); + + /* + * The new command name is okay, so remove the command from its current + * namespace. This is like deleting the command, so bump the cmdEpoch to + * invalidate any cached references to the command. + */ + + Tcl_DeleteHashEntry(oldHPtr); + cmdPtr->cmdEpoch++; + + /* + * If the command being renamed has a compile function, increment the + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled for the + * now-renamed command. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + + /* + * Now free the Command structure, if the "oldName" command has been + * deleted by invocation of rename traces. + */ + + TclCleanupCommandMacro(cmdPtr); + result = TCL_OK; + + done: + TclDecrRefCount(oldFullName); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCommandInfo -- + * + * Modifies various information about a Tcl command. Note that this + * function will not change a command's namespace; use TclRenameCommand + * to do that. Also, the isNativeObjectProc member of *infoPtr is + * ignored. + * + * Results: + * If cmdName exists in interp, then the information at *infoPtr is + * stored with the command in place of the current information and 1 is + * returned. If the command doesn't exist then 0 is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetCommandInfo( + Tcl_Interp *interp, /* Interpreter in which to look for + * command. */ + const char *cmdName, /* Name of desired command. */ + const Tcl_CmdInfo *infoPtr) /* Where to find information to store in the + * command. */ +{ + Tcl_Command cmd; + + cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); + return Tcl_SetCommandInfoFromToken(cmd, infoPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCommandInfoFromToken -- + * + * Modifies various information about a Tcl command. Note that this + * function will not change a command's namespace; use TclRenameCommand + * to do that. Also, the isNativeObjectProc member of *infoPtr is + * ignored. + * + * Results: + * If cmdName exists in interp, then the information at *infoPtr is + * stored with the command in place of the current information and 1 is + * returned. If the command doesn't exist then 0 is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetCommandInfoFromToken( + Tcl_Command cmd, + const Tcl_CmdInfo *infoPtr) +{ + Command *cmdPtr; /* Internal representation of the command */ + + if (cmd == NULL) { + return 0; + } + + /* + * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. + */ + + cmdPtr = (Command *) cmd; + cmdPtr->proc = infoPtr->proc; + cmdPtr->clientData = infoPtr->clientData; + if (infoPtr->objProc == NULL) { + cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objClientData = cmdPtr; + cmdPtr->nreProc = NULL; + } else { + if (infoPtr->objProc != cmdPtr->objProc) { + cmdPtr->nreProc = NULL; + cmdPtr->objProc = infoPtr->objProc; + } + cmdPtr->objClientData = infoPtr->objClientData; + } + cmdPtr->deleteProc = infoPtr->deleteProc; + cmdPtr->deleteData = infoPtr->deleteData; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandInfo -- + * + * Returns various information about a Tcl command. + * + * Results: + * If cmdName exists in interp, then *infoPtr is modified to hold + * information about cmdName and 1 is returned. If the command doesn't + * exist then 0 is returned and *infoPtr isn't modified. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetCommandInfo( + Tcl_Interp *interp, /* Interpreter in which to look for + * command. */ + const char *cmdName, /* Name of desired command. */ + Tcl_CmdInfo *infoPtr) /* Where to store information about + * command. */ +{ + Tcl_Command cmd; + + cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); + return Tcl_GetCommandInfoFromToken(cmd, infoPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandInfoFromToken -- + * + * Returns various information about a Tcl command. + * + * Results: + * Copies information from the command identified by 'cmd' into a + * caller-supplied structure and returns 1. If the 'cmd' is NULL, leaves + * the structure untouched and returns 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetCommandInfoFromToken( + Tcl_Command cmd, + Tcl_CmdInfo *infoPtr) +{ + Command *cmdPtr; /* Internal representation of the command */ + + if (cmd == NULL) { + return 0; + } + + /* + * Set isNativeObjectProc 1 if objProc was registered by a call to + * Tcl_CreateObjCommand. Otherwise set it to 0. + */ + + cmdPtr = (Command *) cmd; + infoPtr->isNativeObjectProc = + (cmdPtr->objProc != TclInvokeStringCommand); + infoPtr->objProc = cmdPtr->objProc; + infoPtr->objClientData = cmdPtr->objClientData; + infoPtr->proc = cmdPtr->proc; + infoPtr->clientData = cmdPtr->clientData; + infoPtr->deleteProc = cmdPtr->deleteProc; + infoPtr->deleteData = cmdPtr->deleteData; + infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; + + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandName -- + * + * Given a token returned by Tcl_CreateCommand, this function returns the + * current name of the command (which may have changed due to renaming). + * + * Results: + * The return value is the name of the given command. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +const char * +Tcl_GetCommandName( + Tcl_Interp *interp, /* Interpreter containing the command. */ + Tcl_Command command) /* Token for command returned by a previous + * call to Tcl_CreateCommand. The command must + * not have been deleted. */ +{ + Command *cmdPtr = (Command *) command; + + if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { + /* + * This should only happen if command was "created" after the + * interpreter began to be deleted, so there isn't really any command. + * Just return an empty string. + */ + + return ""; + } + + return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandFullName -- + * + * Given a token returned by, e.g., Tcl_CreateCommand or Tcl_FindCommand, + * this function appends to an object the command's full name, qualified + * by a sequence of parent namespace names. The command's fully-qualified + * name may have changed due to renaming. + * + * Results: + * None. + * + * Side effects: + * The command's fully-qualified name is appended to the string + * representation of objPtr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_GetCommandFullName( + Tcl_Interp *interp, /* Interpreter containing the command. */ + Tcl_Command command, /* Token for command returned by a previous + * call to Tcl_CreateCommand. The command must + * not have been deleted. */ + Tcl_Obj *objPtr) /* Points to the object onto which the + * command's full name is appended. */ + +{ + Interp *iPtr = (Interp *) interp; + register Command *cmdPtr = (Command *) command; + char *name; + + /* + * Add the full name of the containing namespace, followed by the "::" + * separator, and the command name. + */ + + if (cmdPtr != NULL) { + if (cmdPtr->nsPtr != NULL) { + Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); + if (cmdPtr->nsPtr != iPtr->globalNsPtr) { + Tcl_AppendToObj(objPtr, "::", 2); + } + } + if (cmdPtr->hPtr != NULL) { + name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); + Tcl_AppendToObj(objPtr, name, -1); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCommand -- + * + * Remove the given command from the given interpreter. + * + * Results: + * 0 is returned if the command was deleted successfully. -1 is returned + * if there didn't exist a command by that name. + * + * Side effects: + * cmdName will no longer be recognized as a valid command for interp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DeleteCommand( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * a previous Tcl_CreateInterp call). */ + const char *cmdName) /* Name of command to remove. */ +{ + Tcl_Command cmd; + + /* + * Find the desired command and delete it. + */ + + cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); + if (cmd == NULL) { + return -1; + } + return Tcl_DeleteCommandFromToken(interp, cmd); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCommandFromToken -- + * + * Removes the given command from the given interpreter. This function + * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead of + * a command name for efficiency. + * + * Results: + * 0 is returned if the command was deleted successfully. -1 is returned + * if there didn't exist a command by that name. + * + * Side effects: + * The command specified by "cmd" will no longer be recognized as a valid + * command for "interp". + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DeleteCommandFromToken( + Tcl_Interp *interp, /* Token for command interpreter returned by a + * previous call to Tcl_CreateInterp. */ + Tcl_Command cmd) /* Token for command to delete. */ +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr = (Command *) cmd; + ImportRef *refPtr, *nextRefPtr; + Tcl_Command importCmd; + + /* + * The code here is tricky. We can't delete the hash table entry before + * invoking the deletion callback because there are cases where the + * deletion callback needs to invoke the command (e.g. object systems such + * as OTcl). However, this means that the callback could try to delete or + * rename the command. The deleted flag allows us to detect these cases + * and skip nested deletes. + */ + + if (cmdPtr->flags & CMD_IS_DELETED) { + /* + * Another deletion is already in progress. Remove the hash table + * entry now, but don't invoke a callback or free the command + * structure. Take care to only remove the hash entry if it has not + * already been removed; otherwise if we manage to hit this function + * three times, everything goes up in smoke. [Bug 1220058] + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + } + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + + return 0; + } + + /* + * We must delete this command, even though both traces and delete procs + * may try to avoid this (renaming the command etc). Also traces and + * delete procs may try to delete the command themsevles. This flag + * declares that a delete is in progress and that recursive deletes should + * be ignored. + */ + + cmdPtr->flags |= CMD_IS_DELETED; + + /* + * Call trace functions for the command being deleted. Then delete its + * traces. + */ + + if (cmdPtr->tracePtr != NULL) { + CommandTrace *tracePtr; + CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); + + /* + * Now delete these traces. + */ + + tracePtr = cmdPtr->tracePtr; + while (tracePtr != NULL) { + CommandTrace *nextPtr = tracePtr->nextPtr; + + if (tracePtr->refCount-- <= 1) { + ckfree(tracePtr); + } + tracePtr = nextPtr; + } + cmdPtr->tracePtr = NULL; + } + + /* + * 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. + */ + + TclInvalidateNsCmdLookup(cmdPtr->nsPtr); + + /* + * If the command being deleted has a compile function, increment the + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled with + * command-specific (i.e., inline) bytecodes for the now-deleted command. + * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose + * compilation epoch doesn't match is recompiled. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + + if (cmdPtr->deleteProc != NULL) { + /* + * Delete the command's client data. If this was an imported command + * 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() + * 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); + } + + /* + * If this command was imported into other namespaces, then imported + * commands were created that refer back to this command. Delete these + * imported commands now. + */ + if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) { + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; + refPtr = nextRefPtr) { + nextRefPtr = refPtr->nextPtr; + importCmd = (Tcl_Command) refPtr->importedCmdPtr; + Tcl_DeleteCommandFromToken(interp, importCmd); + } + } + + /* + * Don't use hPtr to delete the hash entry here, because it's possible + * that the deletion callback renamed the command. Instead, use + * cmdPtr->hptr, and make sure that no-one else has already deleted the + * hash entry. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + } + + /* + * 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; + + /* + * Now free the Command structure, unless there is another reference to it + * 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 + * 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. */ + Command *cmdPtr, /* Command whose traces are to be invoked. */ + const char *oldName, /* Command's old name, or NULL if we must get + * the name from cmdPtr */ + const char *newName, /* Command's new name, or NULL if the command + * is not being renamed */ + int flags) /* Flags indicating the type of traces to + * trigger, either TCL_TRACE_DELETE or + * TCL_TRACE_RENAME. */ +{ + register CommandTrace *tracePtr; + ActiveCommandTrace active; + char *result; + Tcl_Obj *oldNamePtr = NULL; + Tcl_InterpState state = NULL; + + if (cmdPtr->flags & CMD_TRACE_ACTIVE) { + /* + * While a rename trace is active, we will not process any more rename + * traces; while a delete trace is active we will never reach here - + * because Tcl_DeleteCommandFromToken checks for the condition + * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a + * command deletion is in progress. For all other traces, delete + * traces will not be invoked but a call to TraceCommandProc will + * ensure that tracePtr->clientData is freed whenever the command + * "oldName" is deleted. + */ + + if (cmdPtr->flags & TCL_TRACE_RENAME) { + flags &= ~TCL_TRACE_RENAME; + } + if (flags == 0) { + return NULL; + } + } + cmdPtr->flags |= CMD_TRACE_ACTIVE; + cmdPtr->refCount++; + + result = NULL; + active.nextPtr = iPtr->activeCmdTracePtr; + active.reverseScan = 0; + iPtr->activeCmdTracePtr = &active; + + if (flags & TCL_TRACE_DELETE) { + flags |= TCL_TRACE_DESTROYED; + } + active.cmdPtr = cmdPtr; + + Tcl_Preserve(iPtr); + + for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + cmdPtr->flags |= tracePtr->flags; + if (oldName == NULL) { + TclNewObj(oldNamePtr); + Tcl_IncrRefCount(oldNamePtr); + Tcl_GetCommandFullName((Tcl_Interp *) iPtr, + (Tcl_Command) cmdPtr, oldNamePtr); + oldName = TclGetString(oldNamePtr); + } + tracePtr->refCount++; + if (state == NULL) { + state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK); + } + tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, + oldName, newName, flags); + cmdPtr->flags &= ~tracePtr->flags; + if (tracePtr->refCount-- <= 1) { + ckfree(tracePtr); + } + } + + if (state) { + Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state); + } + + /* + * If a new object was created to hold the full oldName, free it now. + */ + + if (oldNamePtr != NULL) { + TclDecrRefCount(oldNamePtr); + } + + /* + * Restore the variable's flags, remove the record of our active traces, + * and then return. + */ + + cmdPtr->flags &= ~CMD_TRACE_ACTIVE; + cmdPtr->refCount--; + iPtr->activeCmdTracePtr = active.nextPtr; + 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; +} + +/* + *---------------------------------------------------------------------- + * + * TclCleanupCommand -- + * + * This function frees up a Command structure unless it is still + * referenced from an interpreter's command hashtable or from a CmdName + * Tcl object representing the name of a command in a ByteCode + * instruction sequence. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed unless a reference to the Command structure still + * exists. In that case the cleanup is delayed until the command is + * deleted or when the last ByteCode referring to it is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclCleanupCommand( + register Command *cmdPtr) /* Points to the Command structure to + * be freed. */ +{ + if (cmdPtr->refCount-- <= 1) { + ckfree(cmdPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateMathFunc -- + * + * Creates a new math function for expressions in a given interpreter. + * + * Results: + * None. + * + * Side effects: + * The Tcl function defined by "name" is created or redefined. If the + * function already exists then its definition is replaced; this includes + * the builtin functions. Redefining a builtin function forces all + * existing code to be invalidated since that code may be compiled using + * an instruction specific to the replaced function. In addition, + * redefioning a non-builtin function will force existing code to be + * invalidated if the number of arguments has changed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateMathFunc( + Tcl_Interp *interp, /* Interpreter in which function is to be + * available. */ + const char *name, /* Name of function (e.g. "sin"). */ + int numArgs, /* Nnumber of arguments required by + * function. */ + Tcl_ValueType *argTypes, /* Array of types acceptable for each + * argument. */ + Tcl_MathProc *proc, /* C function that implements the math + * function. */ + ClientData clientData) /* Additional value to pass to the + * function. */ +{ + Tcl_DString bigName; + OldMathFuncData *data = ckalloc(sizeof(OldMathFuncData)); + + data->proc = proc; + data->numArgs = numArgs; + data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType)); + memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); + data->clientData = clientData; + + Tcl_DStringInit(&bigName); + TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::"); + Tcl_DStringAppend(&bigName, name, -1); + + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName), + OldMathFuncProc, data, OldMathFuncDeleteProc); + Tcl_DStringFree(&bigName); +} + +/* + *---------------------------------------------------------------------- + * + * OldMathFuncProc -- + * + * Dispatch to a math function created with Tcl_CreateMathFunc + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Whatever the math function does. + * + *---------------------------------------------------------------------- + */ + +static int +OldMathFuncProc( + ClientData clientData, /* Ponter to OldMathFuncData describing the + * function being called */ + Tcl_Interp *interp, /* Tcl interpreter */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Parameter vector */ +{ + Tcl_Obj *valuePtr; + OldMathFuncData *dataPtr = clientData; + Tcl_Value funcResult, *args; + int result; + int j, k; + double d; + + /* + * Check argument count. + */ + + if (objc != dataPtr->numArgs + 1) { + MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv); + return TCL_ERROR; + } + + /* + * Convert arguments from Tcl_Obj's to Tcl_Value's. + */ + + args = ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); + for (j = 1, k = 0; j < objc; ++j, ++k) { + /* TODO: Convert to TclGetNumberFromObj? */ + valuePtr = objv[j]; + result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); +#ifdef ACCEPT_NAN + if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) { + d = valuePtr->internalRep.doubleValue; + result = TCL_OK; + } +#endif + if (result != TCL_OK) { + /* + * We have a non-numeric argument. + */ + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "argument to math function didn't have numeric value", + -1)); + TclCheckBadOctal(interp, TclGetString(valuePtr)); + ckfree(args); + return TCL_ERROR; + } + + /* + * Copy the object's numeric value to the argument record, converting + * it if necessary. + * + * NOTE: no bignum support; use the new mathfunc interface for that. + */ + + args[k].type = dataPtr->argTypes[k]; + switch (args[k].type) { + case TCL_EITHER: + if (Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue) + == TCL_OK) { + args[k].type = TCL_INT; + break; + } + if (TclGetWideIntFromObj(interp, valuePtr, &args[k].wideValue) + == TCL_OK) { + args[k].type = TCL_WIDE_INT; + break; + } + args[k].type = TCL_DOUBLE; + /* FALLTHROUGH */ + + case TCL_DOUBLE: + args[k].doubleValue = d; + break; + case TCL_INT: + 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_ResetResult(interp); + break; + case TCL_WIDE_INT: + if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { + ckfree(args); + return TCL_ERROR; + } + valuePtr = Tcl_GetObjResult(interp); + TclGetWideIntFromObj(NULL, valuePtr, &args[k].wideValue); + Tcl_ResetResult(interp); + break; + } + } + + /* + * Call the function. + */ + + errno = 0; + result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult); + ckfree(args); + if (result != TCL_OK) { + return result; + } + + /* + * Return the result of the call. + */ + + if (funcResult.type == TCL_INT) { + TclNewLongObj(valuePtr, funcResult.intValue); + } else if (funcResult.type == TCL_WIDE_INT) { + valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); + } else { + return CheckDoubleResult(interp, funcResult.doubleValue); + } + Tcl_SetObjResult(interp, valuePtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * OldMathFuncDeleteProc -- + * + * Cleans up after deleting a math function registered with + * Tcl_CreateMathFunc + * + * Results: + * None. + * + * Side effects: + * Frees allocated memory. + * + *---------------------------------------------------------------------- + */ + +static void +OldMathFuncDeleteProc( + ClientData clientData) +{ + OldMathFuncData *dataPtr = clientData; + + ckfree(dataPtr->argTypes); + ckfree(dataPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetMathFuncInfo -- + * + * Discovers how a particular math function was created in a given + * interpreter. + * + * Results: + * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the + * interpreter result if that happens.) + * + * Side effects: + * If this function succeeds, the variables pointed to by the numArgsPtr + * and argTypePtr arguments will be updated to detail the arguments + * allowed by the function. The variable pointed to by the procPtr + * argument will be set to NULL if the function is a builtin function, + * and will be set to the address of the C function used to implement the + * math function otherwise (in which case the variable pointed to by the + * clientDataPtr argument will also be updated.) + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetMathFuncInfo( + Tcl_Interp *interp, + const char *name, + int *numArgsPtr, + Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, + ClientData *clientDataPtr) +{ + Tcl_Obj *cmdNameObj; + Command *cmdPtr; + + /* + * Get the command that implements the math function. + */ + + TclNewLiteralStringObj(cmdNameObj, "tcl::mathfunc::"); + Tcl_AppendToObj(cmdNameObj, name, -1); + Tcl_IncrRefCount(cmdNameObj); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdNameObj); + Tcl_DecrRefCount(cmdNameObj); + + /* + * Report unknown functions. + */ + + if (cmdPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown math function \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL); + *numArgsPtr = -1; + *argTypesPtr = NULL; + *procPtr = NULL; + *clientDataPtr = NULL; + return TCL_ERROR; + } + + /* + * Retrieve function info for user defined functions; return dummy + * information for builtins. + */ + + if (cmdPtr->objProc == &OldMathFuncProc) { + OldMathFuncData *dataPtr = cmdPtr->clientData; + + *procPtr = dataPtr->proc; + *numArgsPtr = dataPtr->numArgs; + *argTypesPtr = dataPtr->argTypes; + *clientDataPtr = dataPtr->clientData; + } else { + *procPtr = NULL; + *numArgsPtr = -1; + *argTypesPtr = NULL; + *procPtr = NULL; + *clientDataPtr = NULL; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListMathFuncs -- + * + * Produces a list of all the math functions defined in a given + * interpreter. + * + * Results: + * A pointer to a Tcl_Obj structure with a reference count of zero, or + * NULL in the case of an error (in which case a suitable error message + * will be left in the interpreter result.) + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ListMathFuncs( + Tcl_Interp *interp, + const char *pattern) +{ + Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1); + Tcl_Obj *result; + Tcl_InterpState state; + + if (pattern) { + Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); + Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj); + + Tcl_AppendObjToObj(script, arg); + Tcl_DecrRefCount(arg); /* Should tear down patternObj too */ + } + + state = Tcl_SaveInterpState(interp, TCL_OK); + Tcl_IncrRefCount(script); + if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { + result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } else { + result = Tcl_NewObj(); + } + Tcl_DecrRefCount(script); + Tcl_RestoreInterpState(interp, state); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclInterpReady -- + * + * Check if an interpreter is ready to eval commands or scripts, i.e., if + * it was not deleted and if the nesting level is not too high. + * + * Results: + * The return value is TCL_OK if it the interpreter is ready, TCL_ERROR + * otherwise. + * + * Side effects: + * The interpreters object and string results are cleared. + * + *---------------------------------------------------------------------- + */ + +int +TclInterpReady( + Tcl_Interp *interp) +{ + register Interp *iPtr = (Interp *) interp; + + /* + * Reset both the interpreter's string and object results and clear out + * any previous error information. + */ + + Tcl_ResetResult(interp); + + /* + * If the interpreter has been deleted, return an error. + */ + + if (iPtr->flags & DELETED) { + 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)) { + return TCL_OK; + } + + 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 = TclGetStringFromObj(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; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CancelEval -- + * + * 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. + * + * 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 = TclGetStringFromObj(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. + * + * Side effects: + * Always pushes a callback. Other side effects depend 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, 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. */ +{ + Interp *iPtr = (Interp *) interp; + + /* + * data[1] stores a marker for use by tailcalls; it will be set to 1 by + * command redirectors (imports, alias, ensembles) so that tailcall skips + * this callback (that marks the end of the target command) and goes back + * to the end of the source command. + */ + + if (iPtr->deferredCallbacks) { + iPtr->deferredCallbacks = NULL; + } else { + TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); + } + + iPtr->numLevels++; + TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), + INT2PTR(objc), objv); + return TCL_OK; +} + +static int +EvalObjvCore( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = NULL, *preCmdPtr = data[0]; + int flags = PTR2INT(data[1]); + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = NULL; + int enterTracesDone = 0; + + /* + * Push records for task to be done on return, in INVERSE order. First, if + * needed, the exception handlers (as they should happen last). + */ + + if (!(flags & TCL_EVAL_NOERR)) { + TEOV_PushExceptionHandlers(interp, objc, objv, flags); + } + + if (TCL_OK != TclInterpReady(interp)) { + return TCL_ERROR; + } + + if (objc == 0) { + return TCL_OK; + } + + if (TclLimitExceeded(iPtr->limit)) { + return TCL_ERROR; + } + + /* + * Configure evaluation context to match the requested flags. + */ + + if (iPtr->lookupNsPtr) { + + /* + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + * + * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. + * TODO: Is that a bug? + */ + + lookupNsPtr = iPtr->lookupNsPtr; + iPtr->lookupNsPtr = NULL; + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; + } else { + + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ + + TclResetRewriteEnsemble(interp, 1); + + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } + } + + /* + * Lookup the Command to dispatch. + */ + + reresolve: + assert(cmdPtr == NULL); + if (preCmdPtr) { + /* Caller gave it to us */ + if (!(preCmdPtr->flags & CMD_IS_DELETED)) { + /* So long as it exists, use it. */ + cmdPtr = preCmdPtr; + } else if (flags & TCL_EVAL_NORESOLVE) { + /* + * When it's been deleted, and we're told not to attempt + * resolving it ourselves, all we can do is raise an error. + */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to invoke a deleted command")); + Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); + return TCL_ERROR; + } + } + if (cmdPtr == NULL) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } + } + + if (enterTracesDone || iPtr->tracePtr + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); + Tcl_IncrRefCount(commandPtr); + + if (!enterTracesDone) { + + int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, + objc, objv); + + /* + * Send any exception from enter traces back as an exception + * raised by the traced command. + * TODO: Is this a bug? Letting an execution trace BREAK or + * CONTINUE or RETURN in the place of the traced command? + * Would either converting all exceptions to TCL_ERROR, or + * just swallowing them be better? (Swallowing them has the + * problem of permanently hiding program errors.) + */ + + if (code != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return code; + } + + /* + * If the enter traces made the resolved cmdPtr unusable, go + * back and resolve again, but next time don't run enter + * traces again. + */ + + if (cmdPtr == NULL) { + enterTracesDone = 1; + Tcl_DecrRefCount(commandPtr); + goto reresolve; + } + } + + /* + * Schedule leave traces. Raise the refCount on the resolved + * cmdPtr, so that when it passes to the leave traces we know + * it's still valid. + */ + + cmdPtr->refCount++; + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); + } + + TclNRAddCallback(interp, Dispatch, + cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, + cmdPtr->objClientData, INT2PTR(objc), objv); + return TCL_OK; +} + +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_ObjCmdProc *objProc = data[0]; + ClientData clientData = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; + +#ifdef USE_DTRACE + if (TCL_DTRACE_CMD_ARGS_ENABLED()) { + const char *a[10]; + int i = 0; + + 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() && iPtr->cmdFramePtr) { + Tcl_Obj *info = TclInfoFrame(interp, iPtr->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 */ + + iPtr->cmdCount++; + return objProc(clientData, interp, objc, objv); +} + +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); + } + + 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; +} + +static int +NRCommand( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + + iPtr->numLevels--; + + /* + * If there is a tailcall, schedule it next + */ + + if (data[1] && (data[1] != INT2PTR(1))) { + TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL); + } + + /* 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 result; +} + +/* + *---------------------------------------------------------------------- + * + * 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)) { + /* + * Error messages + */ + + TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc), + (ClientData) objv, NULL, NULL); + } + + if (iPtr->numLevels == 1) { + /* + * No CONTINUE or BREAK at level 0, manage RETURN + */ + + 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); + } + 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)){ + /* + * 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. + */ + + listPtr = Tcl_NewListObj(objc, objv); + cmdString = TclGetStringFromObj(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 + * call. + */ + + for (i = 0; i < handlerObjc; ++i) { + Tcl_DecrRefCount(newObjv[i]); + } + TclStackFree(interp, newObjv); + return TCL_ERROR; + } + + if (lookupNsPtr) { + savedNsPtr = varFramePtr->nsPtr; + varFramePtr->nsPtr = lookupNsPtr; + } + TclSkipTailcall(interp); + TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc), + newObjv, savedNsPtr, NULL); + return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL); +} + +static int +TEOV_NotFoundCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + int objc = PTR2INT(data[0]); + Tcl_Obj **objv = data[1]; + Namespace *savedNsPtr = data[2]; + + int i; + + 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, + Tcl_Obj *commandPtr, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr = *cmdPtrPtr; + size_t newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int length, traceCode = TCL_OK; + const char *command = TclGetStringFromObj(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 (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (enter trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + return traceCode; + } + if (cmdEpoch != newEpoch) { + *cmdPtrPtr = NULL; + } + return TCL_OK; +} + +static int +TEOV_RunLeaveTraces( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + int traceCode = TCL_OK; + int objc = PTR2INT(data[0]); + Tcl_Obj *commandPtr = data[1]; + Command *cmdPtr = data[2]; + Tcl_Obj **objv = data[3]; + int length; + const char *command = TclGetStringFromObj(commandPtr, &length); + + if (!(cmdPtr->flags & CMD_IS_DELETED)) { + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ + 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); + } + } + + /* + * 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) { + if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (leave trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + result = traceCode; + } + Tcl_DecrRefCount(commandPtr); + return result; +} + +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; + } + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); + iPtr->varFramePtr->nsPtr = savedNsPtr; + return cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalTokensStandard -- + * + * Given an array of tokens parsed from a Tcl command (e.g., the tokens + * that make up a word or the index for an array variable) this function + * evaluates the tokens and concatenates their values to form a single + * result value. + * + * 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 array of tokens being evaled. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalTokensStandard( + Tcl_Interp *interp, /* Interpreter in which to lookup variables, + * execute nested commands, and report + * errors. */ + Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to + * evaluate and concatenate. */ + int count) /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ +{ + return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, + NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalTokens -- + * + * Given an array of tokens parsed from a Tcl command (e.g., the tokens + * that make up a word or the index for an array variable) this function + * evaluates the tokens and concatenates their values to form a single + * result value. + * + * Results: + * The return value is a pointer to a newly allocated Tcl_Obj containing + * the value of the array of tokens. The reference count of the returned + * object has been incremented. If an error occurs in evaluating the + * tokens then a NULL value is returned and an error message is left in + * interp's result. + * + * Side effects: + * A new object is allocated to hold the result. + * + *---------------------------------------------------------------------- + * + * This uses a non-standard return convention; its use is now deprecated. It + * is a wrapper for the new function Tcl_EvalTokensStandard, and is not used + * in the core any longer. It is only kept for backward compatibility. + */ + +Tcl_Obj * +Tcl_EvalTokens( + Tcl_Interp *interp, /* Interpreter in which to lookup variables, + * execute nested commands, and report + * errors. */ + Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to + * evaluate and concatenate. */ + int count) /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ +{ + Tcl_Obj *resPtr; + + if (Tcl_EvalTokensStandard(interp, tokenPtr, count) != TCL_OK) { + return NULL; + } + resPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resPtr); + Tcl_ResetResult(interp); + return resPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalEx, TclEvalEx -- + * + * This function evaluates a Tcl script without using the compiler or + * byte-code interpreter. It just parses the script, creates values for + * each word of each command, then calls EvalObjv to execute each + * command. + * + * 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 script. + * + * TIP #280 : Keep public API, internally extended API. + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalEx( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * script. Also used for error reporting. */ + const char *script, /* First character of script to evaluate. */ + int numBytes, /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first null character. */ + int flags) /* Collection of OR-ed bits that control the + * evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently supported. */ +{ + return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script); +} + +int +TclEvalEx( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * script. Also used for error reporting. */ + const char *script, /* First character of script to evaluate. */ + int numBytes, /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first NUL character. */ + int flags, /* Collection of OR-ed bits that control the + * 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. */ +{ + Interp *iPtr = (Interp *) interp; + const char *p, *next; + const unsigned int minObjs = 20; + Tcl_Obj **objv, **objvSpace; + int *expand, *lines, *lineSpace; + Tcl_Token *tokenPtr; + int commandLength, bytesLeft, expandRequested, code = TCL_OK; + CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case + * TCL_EVAL_GLOBAL was set. */ + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + int gotParse = 0; + unsigned int i, objectsUsed = 0; + /* These variables keep track of how much + * state has been allocated while evaluating + * the script, so that it can be freed + * properly if an error occurs. */ + 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 = TclStackAlloc(interp, minObjs * sizeof(int)); + int *linesStack = TclStackAlloc(interp, minObjs * sizeof(int)); + /* TIP #280 Structures for tracking of command + * locations. */ + 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) { + clNext = clNextOuter; + } else { + clNext = &iPtr->scriptCLLocPtr->loc[0]; + } + } + + if (numBytes < 0) { + numBytes = strlen(script); + } + Tcl_ResetResult(interp); + + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = iPtr->rootFramePtr; + } + + /* + * Each iteration through the following loop parses the next command from + * the script and then executes it. + */ + + objv = objvSpace = stackObjArray; + lines = lineSpace = linesStack; + expand = expandStack; + p = script; + bytesLeft = numBytes; + + /* + * TIP #280 Initialize tracking. Do not push on the frame stack yet. + * + * We open a new context, either for a sourced script, or 'eval'. + * For sourced files we always have a path object, even if nothing was + * specified in the interp itself. That makes code using it simpler as + * NULL checks can be left out. Sourced file without path in the + * 'scriptFile' is possible during Tcl initialization. + */ + + eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; + eeFramePtr->framePtr = iPtr->framePtr; + eeFramePtr->nextPtr = iPtr->cmdFramePtr; + eeFramePtr->nline = 0; + eeFramePtr->line = NULL; + eeFramePtr->cmdObj = NULL; + + iPtr->cmdFramePtr = eeFramePtr; + if (iPtr->evalFlags & TCL_EVAL_FILE) { + /* + * Set up for a sourced file. + */ + + eeFramePtr->type = TCL_LOCATION_SOURCE; + + if (iPtr->scriptFile) { + /* + * Normalization here, to have the correct pwd. Should have + * negligible impact on performance, as the norm should have been + * done already by the 'source' invoking us, and it caches the + * result. + */ + + Tcl_Obj *norm = Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile); + + if (norm == NULL) { + /* + * Error message in the interp result. + */ + + code = TCL_ERROR; + goto error; + } + eeFramePtr->data.eval.path = norm; + } else { + TclNewLiteralStringObj(eeFramePtr->data.eval.path, ""); + } + Tcl_IncrRefCount(eeFramePtr->data.eval.path); + } else { + /* + * Set up for plain eval. + */ + + eeFramePtr->type = TCL_LOCATION_EVAL; + eeFramePtr->data.eval.path = NULL; + } + + iPtr->evalFlags = 0; + do { + if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { + code = TCL_ERROR; + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + parsePtr->term + 1 - parsePtr->commandStart); + goto posterror; + } + + /* + * TIP #280 Track lines. The parser may have skipped text till it + * found the command we are now at. We have to count the lines in this + * block, and do not forget invisible continuation lines. + */ + + TclAdvanceLines(&line, p, parsePtr->commandStart); + TclAdvanceContinuations(&line, &clNext, + parsePtr->commandStart - outerScript); + + gotParse = 1; + if (parsePtr->numWords > 0) { + /* + * TIP #280. Track lines within the words of the current + * command. We use a separate pointer into the table of + * continuation line locations to not lose our position for the + * per-command parsing. + */ + + int wordLine = line; + const char *wordStart = parsePtr->commandStart; + int *wordCLNext = clNext; + unsigned int objectsNeeded = 0; + unsigned int numWords = parsePtr->numWords; + + /* + * Generate an array of objects for the words of the command. + */ + + if (numWords > minObjs) { + 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) { + /* + * TIP #280. Track lines to current word. Save the information + * on a per-word basis, signaling dynamic words as needed. + * Make the information available to the recursively called + * evaluator as well, including the type of context (source + * vs. eval). + */ + + TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); + TclAdvanceContinuations(&wordLine, &wordCLNext, + tokenPtr->start - outerScript); + wordStart = tokenPtr->start; + + lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) + ? wordLine : -1; + + if (eeFramePtr->type == TCL_LOCATION_SOURCE) { + iPtr->evalFlags |= TCL_EVAL_FILE; + } + + code = TclSubstTokens(interp, tokenPtr+1, + tokenPtr->numComponents, NULL, wordLine, + wordCLNext, outerScript); + + iPtr->evalFlags = 0; + + if (code != TCL_OK) { + break; + } + objv[objectsUsed] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(objv[objectsUsed]); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + int numElements; + + code = TclListObjLength(interp, objv[objectsUsed], + &numElements); + if (code == TCL_ERROR) { + /* + * Attempt to expand a non-list. + */ + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (expanding word %d)", objectsUsed)); + Tcl_DecrRefCount(objv[objectsUsed]); + break; + } + expandRequested = 1; + expand[objectsUsed] = 1; + + objectsNeeded += (numElements ? numElements : 1); + } else { + expand[objectsUsed] = 0; + objectsNeeded++; + } + + if (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. + */ + + Tcl_Obj **copy = objvSpace; + int *lcopy = lineSpace; + int wordIdx = numWords; + int objIdx = objectsNeeded - 1; + + if ((numWords > minObjs) || (objectsNeeded > minObjs)) { + objv = objvSpace = + ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); + lines = lineSpace = ckalloc(objectsNeeded * sizeof(int)); + } + + objectsUsed = 0; + while (wordIdx--) { + if (expand[wordIdx]) { + int numElements; + Tcl_Obj **elements, *temp = copy[wordIdx]; + + Tcl_ListObjGetElements(NULL, temp, &numElements, + &elements); + objectsUsed += numElements; + while (numElements--) { + lines[objIdx] = -1; + objv[objIdx--] = elements[numElements]; + Tcl_IncrRefCount(elements[numElements]); + } + Tcl_DecrRefCount(temp); + } else { + lines[objIdx] = lcopy[wordIdx]; + objv[objIdx--] = copy[wordIdx]; + objectsUsed++; + } + } + objv += objIdx+1; + + if (copy != stackObjArray) { + ckfree(copy); + } + if (lcopy != linesStack) { + ckfree(lcopy); + } + } + + /* + * Execute the command and free the objects for its words. + * + * TIP #280: Remember the command itself for 'info frame'. We + * shorten the visible command by one char to exclude the + * termination character, if necessary. Here is where we put our + * frame on the stack of frames too. _After_ the nested commands + * have been executed. + */ + + eeFramePtr->cmd = parsePtr->commandStart; + eeFramePtr->len = parsePtr->commandSize; + + if (parsePtr->term == + parsePtr->commandStart + parsePtr->commandSize - 1) { + eeFramePtr->len--; + } + + eeFramePtr->nline = objectsUsed; + eeFramePtr->line = lines; + + TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); + code = Tcl_EvalObjv(interp, objectsUsed, objv, + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME); + TclArgumentRelease(interp, objv, objectsUsed); + + eeFramePtr->line = NULL; + eeFramePtr->nline = 0; + if (eeFramePtr->cmdObj) { + Tcl_DecrRefCount(eeFramePtr->cmdObj); + eeFramePtr->cmdObj = NULL; + } + + if (code != TCL_OK) { + goto error; + } + for (i = 0; i < objectsUsed; i++) { + Tcl_DecrRefCount(objv[i]); + } + objectsUsed = 0; + if (objvSpace != stackObjArray) { + ckfree(objvSpace); + objvSpace = stackObjArray; + ckfree(lineSpace); + lineSpace = linesStack; + } + + /* + * Free expand separately since objvSpace could have been + * reallocated above. + */ + + if (expand != expandStack) { + ckfree(expand); + expand = expandStack; + } + } + + /* + * Advance to the next command in the script. + * + * TIP #280 Track Lines. Now we track how many lines were in the + * executed command. + */ + + next = parsePtr->commandStart + parsePtr->commandSize; + bytesLeft -= next - p; + p = next; + TclAdvanceLines(&line, parsePtr->commandStart, p); + Tcl_FreeParse(parsePtr); + gotParse = 0; + } while (bytesLeft > 0); + iPtr->varFramePtr = savedVarFramePtr; + code = TCL_OK; + goto cleanup_return; + + error: + /* + * Generate and log various pieces of error information. + */ + + if (iPtr->numLevels == 0) { + if (code == TCL_RETURN) { + code = TclUpdateReturnInfo(iPtr); + } + if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { + ProcessUnexpectedResult(interp, code); + code = TCL_ERROR; + } + } + if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + commandLength = parsePtr->commandSize; + if (parsePtr->term == parsePtr->commandStart + commandLength - 1) { + /* + * The terminator character (such as ; or ]) of the command where + * the error occurred is the last character in the parsed command. + * Reduce the length by one so that the error message doesn't + * include the terminator character. + */ + + commandLength -= 1; + } + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + commandLength); + } + posterror: + iPtr->flags &= ~ERR_ALREADY_LOGGED; + + /* + * Then free resources that had been allocated to the command. + */ + + for (i = 0; i < objectsUsed; i++) { + Tcl_DecrRefCount(objv[i]); + } + if (gotParse) { + Tcl_FreeParse(parsePtr); + } + if (objvSpace != stackObjArray) { + ckfree(objvSpace); + ckfree(lineSpace); + } + if (expand != expandStack) { + ckfree(expand); + } + iPtr->varFramePtr = savedVarFramePtr; + + cleanup_return: + /* + * 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); + } + TclStackFree(interp, linesStack); + TclStackFree(interp, expandStack); + TclStackFree(interp, stackObjArray); + TclStackFree(interp, eeFramePtr); + TclStackFree(interp, parsePtr); + + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclAdvanceLines -- + * + * This function is a helper which counts the number of lines in a block + * of text and advances an external counter. + * + * Results: + * None. + * + * Side effects: + * The specified counter is advanced per the number of lines found. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclAdvanceLines( + int *line, + const char *start, + const char *end) +{ + register const char *p; + + for (p = start; p < end; p++) { + if (*p == '\n') { + (*line)++; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclAdvanceContinuations -- + * + * This procedure is a helper which counts the number of continuation + * lines (CL) in a block of text using a table of CL locations and + * advances an external counter, and the pointer into the table. + * + * Results: + * None. + * + * Side effects: + * The specified counter is advanced per the number of continuation lines + * found. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +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. + * + * *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)) { + /* + * 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)++; + } +} + +/* + *---------------------------------------------------------------------- + * Note: The whole data structure access for argument location tracking is + * hidden behind these three functions. The only parts open are the lineLAPtr + * field in the Interp structure. The CFWord definition is internal to here. + * Should make it easier to redo the data structures if we find something more + * space/time efficient. + */ + +/* + *---------------------------------------------------------------------- + * + * TclArgumentEnter -- + * + * 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. + * + * Results: + * None. + * + * Side effects: + * May allocate memory. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclArgumentEnter( + Tcl_Interp *interp, + Tcl_Obj **objv, + int objc, + CmdFrame *cfPtr) +{ + Interp *iPtr = (Interp *) interp; + int new, i; + Tcl_HashEntry *hPtr; + CFWord *cfwPtr; + + 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 + * literals in bytecode. Eitehr way there is no need to record + * something here. + */ + + 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 = 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 = Tcl_GetHashValue(hPtr); + cfwPtr->refCount++; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * Results: + * None. + * + * Side effects: + * May release memory. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclArgumentRelease( + Tcl_Interp *interp, + Tcl_Obj **objv, + int objc) +{ + Interp *iPtr = (Interp *) interp; + int i; + + for (i = 1; i < objc; i++) { + CFWord *cfwPtr; + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]); + + if (!hPtr) { + continue; + } + cfwPtr = Tcl_GetHashValue(hPtr); + + if (cfwPtr->refCount-- > 1) { + continue; + } + + ckfree(cfwPtr); + Tcl_DeleteHashEntry(hPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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 + * data, further entries simply count the usage up. + * + * Results: + * None. + * + * Side effects: + * May allocate memory. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclArgumentBCEnter( + Tcl_Interp *interp, + Tcl_Obj *objv[], + int objc, + void *codePtr, + CmdFrame *cfPtr, + int cmd, + int pc) +{ + ExtCmdLoc *eclPtr; + int word; + ECL *ePtr; + CFWordBC *lastPtr = NULL; + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hePtr = + Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); + + if (!hePtr) { + return; + } + eclPtr = Tcl_GetHashValue(hePtr); + ePtr = &eclPtr->loc[cmd]; + + /* + * ePtr->nline is the number of words originally parsed. + * + * objc is the number of elements getting invoked. + * + * If they are not the same, we arrived here by compiling an + * ensemble dispatch. Ensemble subcommands that lead to script + * evaluation are not supposed to get compiled, because a command + * such as [info level] in the script can expose some of the dispatch + * shenanigans. This means that we don't have to tend to the + * housekeeping, and can escape now. + */ + + if (ePtr->nline != objc) { + return; + } + + /* + * Having disposed of the ensemble cases, we can state... + * A few truths ... + * (1) ePtr->nline == objc + * (2) (ePtr->line[word] < 0) => !literal, for all words + * (3) (word == 0) => !literal + * + * Item (2) is why we can use objv to get the literals, and do not + * have to save them at compile time. + */ + + for (word = 1; word < objc; word++) { + if (ePtr->line[word] >= 0) { + int isnew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, + objv[word], &isnew); + CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); + + cfwPtr->framePtr = cfPtr; + cfwPtr->obj = objv[word]; + cfwPtr->pc = pc; + cfwPtr->word = word; + cfwPtr->nextPtr = lastPtr; + lastPtr = cfwPtr; + + if (isnew) { + /* + * The word is not on the stack yet, remember the current + * location and initialize references. + */ + + cfwPtr->prevPtr = NULL; + } else { + /* + * The object is already on the stack, however it may have + * a different location now (literal sharing may map + * multiple location to a single Tcl_Obj*. Save the old + * information in the new structure. + */ + + cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); + } + + Tcl_SetHashValue(hPtr, cfwPtr); + } + } /* for */ + + cfPtr->litarg = lastPtr; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * Results: + * None. + * + * Side effects: + * May release memory. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclArgumentBCRelease( + Tcl_Interp *interp, + CmdFrame *cfPtr) +{ + Interp *iPtr = (Interp *) interp; + CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg; + + while (cfwPtr) { + CFWordBC *nextPtr = cfwPtr->nextPtr; + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj); + CFWordBC *xPtr = Tcl_GetHashValue(hPtr); + + if (xPtr != cfwPtr) { + Tcl_Panic("TclArgumentBC Enter/Release Mismatch"); + } + + if (cfwPtr->prevPtr) { + Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); + } else { + Tcl_DeleteHashEntry(hPtr); + } + + ckfree(cfwPtr); + cfwPtr = nextPtr; + } + + cfPtr->litarg = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclArgumentGet -- + * + * This procedure is a helper for the TIP #280 uplevel extension. It + * finds the location references for a Tcl_Obj, if any. + * + * Results: + * None. + * + * Side effects: + * Writes found location information into the result arguments. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclArgumentGet( + Tcl_Interp *interp, + Tcl_Obj *obj, + CmdFrame **cfPtrPtr, + int *wordPtr) +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + CmdFrame *framePtr; + + /* + * An object which either has no string rep or else is a canonical list is + * guaranteed to have been generated dynamically: bail out, this cannot + * have a usable absolute location. _Do not touch_ the information the set + * up by the caller. It knows better than us. + */ + + if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { + return; + } + + /* + * First look for location information recorded in the argument + * stack. That is nearest. + */ + + hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj); + if (hPtr) { + CFWord *cfwPtr = Tcl_GetHashValue(hPtr); + + *wordPtr = cfwPtr->word; + *cfPtrPtr = cfwPtr->framePtr; + return; + } + + /* + * Check if the Tcl_Obj has location information as a bytecode literal, in + * that stack. + */ + + hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj); + if (hPtr) { + CFWordBC *cfwPtr = Tcl_GetHashValue(hPtr); + + framePtr = cfwPtr->framePtr; + framePtr->data.tebc.pc = (char *) (((ByteCode *) + framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc); + *cfPtrPtr = cfwPtr->framePtr; + *wordPtr = cfwPtr->word; + return; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Eval -- + * + * Execute a Tcl command in a string. This function executes the script + * directly, rather than compiling it to bytecodes. Before the arrival of + * the bytecode compiler in Tcl 8.0 Tcl_Eval was the main function used + * for executing Tcl commands, but nowadays it isn't used much. + * + * Results: + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and interp's result contains a value to supplement the return + * code. The value of the result will persist only until the next call to + * Tcl_Eval or Tcl_EvalObj: you must copy it or lose it! + * + * Side effects: + * Can be almost arbitrary, depending on the commands in the script. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_Eval +int +Tcl_Eval( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ + const char *script) /* Pointer to TCL command to execute. */ +{ + int code = Tcl_EvalEx(interp, script, -1, 0); + + /* + * For backwards compatibility with old C code that predates the object + * system in Tcl 8.0, we have to mirror the object result back into the + * string result (some callers may expect it there). + */ + + (void) Tcl_GetStringResult(interp); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObj, Tcl_GlobalEvalObj -- + * + * These functions are deprecated but we keep them around for backwards + * compatibility reasons. + * + * Results: + * See the functions they call. + * + * Side effects: + * See the functions they call. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_EvalObj +int +Tcl_EvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + return Tcl_EvalObjEx(interp, objPtr, 0); +} +#undef Tcl_GlobalEvalObj +int +Tcl_GlobalEvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObjEx, TclEvalObjEx -- + * + * Execute Tcl commands stored in a Tcl object. These commands are + * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is + * specified. + * + * If the flag TCL_EVAL_DIRECT is passed in, the value of invoker + * must be NULL. Support for non-NULL invokers in that mode has + * been removed since it was unused and untested. Failure to + * follow this limitation will lead to an assertion panic. + * + * Results: + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and the interpreter's result contains a value to supplement + * the return code. + * + * Side effects: + * The object is converted, if necessary, to a ByteCode object that holds + * the bytecode instructions for the commands. Executing the commands + * will almost certainly have side effects that depend on those commands. + * + * TIP #280 : Keep public API, internally extended API. + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalObjEx( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * a previous call to Tcl_CreateInterp). */ + register Tcl_Obj *objPtr, /* Pointer to object containing commands to + * 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. */ +{ + return TclEvalObjEx(interp, objPtr, flags, NULL, 0); +} + +int +TclEvalObjEx( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * a previous call to Tcl_CreateInterp). */ + register Tcl_Obj *objPtr, /* Pointer to object containing commands to + * 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. */ +{ + int result = TCL_OK; + NRE_callback *rootPtr = TOP_CB(interp); + + result = TclNREvalObjEx(interp, objPtr, flags, invoker, word); + return TclNRRunCallbacks(interp, result, rootPtr); +} + +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)) { + CmdFrame *eoFramePtr = NULL; + int objc; + Tcl_Obj *listPtr, **objv; + + /* + * Canonical List Optimization: In this case, we + * can safely use Tcl_EvalObjv instead and get an appreciable + * improvement in execution speed. This is because it allows us to + * avoid a setFromAny step that would just pack everything into a + * string and back out again. + * + * This also preserves any associations between list elements and + * location information for such elements. + */ + + /* + * 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. + * + * TODO: Create a test to demo this need, or eliminate it. + * FIXME OPT: preserve just the internal rep? + */ + + Tcl_IncrRefCount(objPtr); + listPtr = TclListObjCopy(interp, objPtr); + Tcl_IncrRefCount(listPtr); + + 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 = TclStackAlloc(interp, sizeof(CmdFrame)); + eoFramePtr->nline = 0; + eoFramePtr->line = NULL; + + eoFramePtr->type = TCL_LOCATION_EVAL; + eoFramePtr->level = (iPtr->cmdFramePtr == NULL? + 1 : iPtr->cmdFramePtr->level + 1); + eoFramePtr->framePtr = iPtr->framePtr; + eoFramePtr->nextPtr = iPtr->cmdFramePtr; + + eoFramePtr->cmdObj = objPtr; + eoFramePtr->cmd = NULL; + eoFramePtr->len = 0; + eoFramePtr->data.eval.path = NULL; + + iPtr->cmdFramePtr = eoFramePtr; + + flags |= TCL_EVAL_SOURCE_IN_FRAME; + } + + TclMarkTailcall(interp); + TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, + objPtr, NULL); + + TclListObjGetElements(NULL, listPtr, &objc, &objv); + return TclNREvalObjv(interp, objc, objv, flags, NULL); + } + + if (!(flags & TCL_EVAL_DIRECT)) { + /* + * 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). + */ + + 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 + * evaluator we are about to call, if so. + * + * It may be possible that the script Tcl_Obj* can be free'd while the + * 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" + * hashtable is managed in the file "tclObj.c". + * + * Another important action is to save (and later restore) the + * continuation line information of the caller, in case we are + * executing nested commands in the eval/direct path. + */ + + ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; + + assert(invoker == NULL); + + iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); + + Tcl_IncrRefCount(objPtr); + + script = TclGetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + + TclDecrRefCount(objPtr); + + iPtr->scriptCLLocPtr = saveCLLocPtr; + return result; + } +} + +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; + + ProcessUnexpectedResult(interp, result); + result = TCL_ERROR; + script = TclGetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, numSrcBytes); + } + + /* + * We are returning to level 0, so should call TclResetCancellation. + * Let us just unset the flags inline. + */ + + 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]; + Tcl_Obj *objPtr = data[2]; + + /* + * Remove the cmdFrame + */ + + if (eoFramePtr) { + iPtr->cmdFramePtr = eoFramePtr->nextPtr; + TclStackFree(interp, eoFramePtr); + } + TclDecrRefCount(objPtr); + TclDecrRefCount(listPtr); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ProcessUnexpectedResult -- + * + * Function called by Tcl_EvalObj to set the interpreter's result value + * to an appropriate error message when the code it evaluates returns an + * unexpected result code (not TCL_OK and not TCL_ERROR) to the topmost + * evaluation level. + * + * Results: + * None. + * + * Side effects: + * The interpreter result is set to an error message appropriate to the + * result code. + * + *---------------------------------------------------------------------- + */ + +static void +ProcessUnexpectedResult( + Tcl_Interp *interp, /* The interpreter in which the unexpected + * result code was returned. */ + int returnCode) /* The unexpected result code. */ +{ + char buf[TCL_INTEGER_SPACE]; + + Tcl_ResetResult(interp); + if (returnCode == TCL_BREAK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invoked \"break\" outside of a loop", -1)); + } else if (returnCode == TCL_CONTINUE) { + 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); +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- + * + * Functions to evaluate an expression and return its value in a + * particular form. + * + * Results: + * Each of the functions below returns a standard Tcl result. If an error + * occurs then an error message is left in the interp's result. Otherwise + * the value of the expression, in the appropriate form, is stored at + * *ptr. If the expression had a result that was incompatible with the + * desired form then an error is returned. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_ExprLong( + Tcl_Interp *interp, /* Context in which to evaluate the + * expression. */ + const char *exprstring, /* Expression to evaluate. */ + long *ptr) /* Where to store result. */ +{ + register Tcl_Obj *exprPtr; + int result = TCL_OK; + if (*exprstring == '\0') { + /* + * Legacy compatibility - return 0 for the zero-length string. + */ + + *ptr = 0; + } else { + exprPtr = Tcl_NewStringObj(exprstring, -1); + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprLongObj(interp, exprPtr, ptr); + Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } + } + return result; +} + +int +Tcl_ExprDouble( + Tcl_Interp *interp, /* Context in which to evaluate the + * expression. */ + const char *exprstring, /* Expression to evaluate. */ + double *ptr) /* Where to store result. */ +{ + register Tcl_Obj *exprPtr; + int result = TCL_OK; + + if (*exprstring == '\0') { + /* + * Legacy compatibility - return 0 for the zero-length string. + */ + + *ptr = 0.0; + } else { + exprPtr = Tcl_NewStringObj(exprstring, -1); + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); + Tcl_DecrRefCount(exprPtr); + /* Discard the expression object. */ + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } + } + return result; +} + +int +Tcl_ExprBoolean( + Tcl_Interp *interp, /* Context in which to evaluate the + * expression. */ + const char *exprstring, /* Expression to evaluate. */ + int *ptr) /* Where to store 0/1 result. */ +{ + if (*exprstring == '\0') { + /* + * An empty string. Just set the result boolean to 0 (false). + */ + + *ptr = 0; + return TCL_OK; + } else { + int result; + Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); + + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); + Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { + /* + * Move the interpreter's object result to the string result, then + * reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + } + return result; + } +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- + * + * Functions to evaluate an expression in an object and return its value + * in a particular form. + * + * Results: + * Each of the functions below returns a standard Tcl result object. If + * an error occurs then an error message is left in the interpreter's + * result. Otherwise the value of the expression, in the appropriate + * form, is stored at *ptr. If the expression had a result that was + * incompatible with the desired form then an error is returned. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprLongObj( + Tcl_Interp *interp, /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr, /* Expression to evaluate. */ + long *ptr) /* Where to store long result. */ +{ + Tcl_Obj *resultPtr; + int result, type; + double d; + ClientData internalPtr; + + result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result != TCL_OK) { + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) { + return TCL_ERROR; + } + + switch (type) { + case TCL_NUMBER_DOUBLE: { + mp_int big; + + d = *((const double *) internalPtr); + Tcl_DecrRefCount(resultPtr); + if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { + return TCL_ERROR; + } + resultPtr = Tcl_NewBignumObj(&big); + /* FALLTHROUGH */ + } + case TCL_NUMBER_LONG: + case TCL_NUMBER_WIDE: + case TCL_NUMBER_BIG: + result = TclGetLongFromObj(interp, resultPtr, ptr); + break; + + case TCL_NUMBER_NAN: + Tcl_GetDoubleFromObj(interp, resultPtr, &d); + result = TCL_ERROR; + } + + Tcl_DecrRefCount(resultPtr);/* Discard the result object. */ + return result; +} + +int +Tcl_ExprDoubleObj( + Tcl_Interp *interp, /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr, /* Expression to evaluate. */ + double *ptr) /* Where to store double result. */ +{ + Tcl_Obj *resultPtr; + int result, type; + ClientData internalPtr; + + result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result != TCL_OK) { + return TCL_ERROR; + } + + result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type); + if (result == TCL_OK) { + switch (type) { + case TCL_NUMBER_NAN: +#ifndef ACCEPT_NAN + result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); + break; +#endif + case TCL_NUMBER_DOUBLE: + *ptr = *((const double *) internalPtr); + result = TCL_OK; + break; + default: + result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); + } + } + Tcl_DecrRefCount(resultPtr);/* Discard the result object. */ + return result; +} + +int +Tcl_ExprBooleanObj( + Tcl_Interp *interp, /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr, /* Expression to evaluate. */ + int *ptr) /* Where to store 0/1 result. */ +{ + Tcl_Obj *resultPtr; + int result; + + result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result == TCL_OK) { + result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); + Tcl_DecrRefCount(resultPtr); + /* Discard the result object. */ + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclObjInvokeNamespace -- + * + * 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. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Whatever the command does. + * + *---------------------------------------------------------------------- + */ + +int +TclObjInvokeNamespace( + Tcl_Interp *interp, /* Interpreter in which command is to be + * invoked. */ + int objc, /* Count of arguments. */ + Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the + * name of the command to invoke. */ + Tcl_Namespace *nsPtr, /* The namespace to use. */ + int flags) /* Combination of flags controlling the call: + * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, + * or TCL_INVOKE_NO_TRACEBACK. */ +{ + int result; + Tcl_CallFrame *framePtr; + + /* + * Make the specified namespace the current namespace and invoke the + * command. + */ + + (void) TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0); + result = TclObjInvoke(interp, objc, objv, flags); + + TclPopStackFrame(interp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclObjInvoke -- + * + * Invokes a Tcl command, given an objv/objc, from either the exposed or + * the hidden sets of commands in the given interpreter. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * Whatever the command does. + * + *---------------------------------------------------------------------- + */ + +int +TclObjInvoke( + Tcl_Interp *interp, /* Interpreter in which command is to be + * invoked. */ + int objc, /* Count of arguments. */ + Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the + * name of the command to invoke. */ + int flags) /* Combination of flags controlling the call: + * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, + * or TCL_INVOKE_NO_TRACEBACK. */ +{ + if (interp == NULL) { + return TCL_ERROR; + } + if ((objc < 1) || (objv == NULL)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal argument vector", -1)); + return TCL_ERROR; + } + if ((flags & TCL_INVOKE_HIDDEN) == 0) { + Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); + } + return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); +} + +int +TclNRInvoke( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + const char *cmdName; /* Name of the command from objv[0]. */ + Tcl_HashEntry *hPtr = NULL; + Command *cmdPtr; + + cmdName = TclGetString(objv[0]); + hTblPtr = iPtr->hiddenCmdTablePtr; + if (hTblPtr != NULL) { + hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); + } + if (hPtr == 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); + + /* Avoid the exception-handling brain damage when numLevels == 0 . */ + iPtr->numLevels++; + Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); + + /* + * Normal command resolution of objv[0] isn't going to find cmdPtr. + * That's the whole point of **hidden** commands. So tell the + * Eval core machinery not to even try (and risk finding something wrong). + */ + + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); +} + +static int +NRPostInvoke( + ClientData clientData[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *)interp; + iPtr->numLevels--; + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_ExprString -- + * + * Evaluate an expression in a string and return its value in string + * form. + * + * Results: + * A standard Tcl result. If the result is TCL_OK, then the interp's + * result is set to the string value of the expression. If the result is + * TCL_ERROR, then the interp's result contains an error message. + * + * Side effects: + * A Tcl object is allocated to hold a copy of the expression string. + * This expression object is passed to Tcl_ExprObj and then deallocated. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_ExprString( + Tcl_Interp *interp, /* Context in which to evaluate the + * expression. */ + const char *expr) /* Expression to evaluate. */ +{ + int code = TCL_OK; + + if (expr[0] == '\0') { + /* + * An empty string. Just set the interpreter's result to 0. + */ + + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + } else { + Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); + + Tcl_IncrRefCount(exprObj); + code = Tcl_ExprObj(interp, exprObj, &resultPtr); + Tcl_DecrRefCount(exprObj); + if (code == TCL_OK) { + Tcl_SetObjResult(interp, resultPtr); + Tcl_DecrRefCount(resultPtr); + } + } + + /* + * Force the string rep of the interp result. + */ + + (void) Tcl_GetStringResult(interp); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendObjToErrorInfo -- + * + * Add a Tcl_Obj value to the errorInfo field that describes the current + * error. + * + * Results: + * None. + * + * Side effects: + * The value of the Tcl_obj is appended to the errorInfo field. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_AddObjErrorInfo +void +Tcl_AppendObjToErrorInfo( + Tcl_Interp *interp, /* Interpreter to which error information + * pertains. */ + Tcl_Obj *objPtr) /* Message to record. */ +{ + const char *message = TclGetString(objPtr); + + Tcl_IncrRefCount(objPtr); + Tcl_AddObjErrorInfo(interp, message, objPtr->length); + Tcl_DecrRefCount(objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddErrorInfo -- + * + * Add information to the errorInfo field that describes the current + * error. + * + * Results: + * None. + * + * Side effects: + * The contents of message are appended to the errorInfo field. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_AddErrorInfo +void +Tcl_AddErrorInfo( + Tcl_Interp *interp, /* Interpreter to which error information + * pertains. */ + const char *message) /* Message to record. */ +{ + Tcl_AddObjErrorInfo(interp, message, -1); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddObjErrorInfo -- + * + * Add information to the errorInfo field that describes the current + * error. This routine differs from Tcl_AddErrorInfo by taking a byte + * pointer and length. + * + * Results: + * None. + * + * Side effects: + * "length" bytes from "message" are appended to the errorInfo field. If + * "length" is negative, use bytes up to the first NULL byte. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddObjErrorInfo( + Tcl_Interp *interp, /* Interpreter to which error information + * pertains. */ + const char *message, /* Points to the first byte of an array of + * bytes of the message. */ + int length) /* The number of bytes in the message. If < 0, + * then append all bytes up to a NULL byte. */ +{ + register Interp *iPtr = (Interp *) interp; + + /* + * If we are just starting to log an error, errorInfo is initialized from + * the error message in the interpreter's result. + */ + + iPtr->flags |= ERR_LEGACY_COPY; + if (iPtr->errorInfo == NULL) { + if (iPtr->result[0] != 0) { + /* + * The interp's string result is set, apparently by some extension + * making a deprecated direct write to it. That extension may + * expect interp->result to continue to be set, so we'll take + * special pains to avoid clearing it, until we drop support for + * interp->result completely. + */ + + iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); + } else { + iPtr->errorInfo = iPtr->objResultPtr; + } + Tcl_IncrRefCount(iPtr->errorInfo); + if (!iPtr->errorCode) { + Tcl_SetErrorCode(interp, "NONE", NULL); + } + } + + /* + * Now append "message" to the end of errorInfo. + */ + + if (length != 0) { + if (Tcl_IsShared(iPtr->errorInfo)) { + Tcl_DecrRefCount(iPtr->errorInfo); + iPtr->errorInfo = Tcl_DuplicateObj(iPtr->errorInfo); + Tcl_IncrRefCount(iPtr->errorInfo); + } + Tcl_AppendToObj(iPtr->errorInfo, message, length); + } +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_VarEvalVA -- + * + * Given a variable number of string arguments, concatenate them all + * together and execute the result as a Tcl command. + * + * Results: + * A standard Tcl return result. An error message or other result may be + * left in the interp's result. + * + * Side effects: + * Depends on what was done by the command. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_VarEvalVA( + Tcl_Interp *interp, /* Interpreter in which to evaluate command */ + va_list argList) /* Variable argument list. */ +{ + Tcl_DString buf; + char *string; + int result; + + /* + * Copy the strings one after the other into a single larger string. Use + * stack-allocated space for small commands, but if the command gets too + * large than call ckalloc to create the space. + */ + + Tcl_DStringInit(&buf); + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + Tcl_DStringAppend(&buf, string, -1); + } + + result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0); + Tcl_DStringFree(&buf); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarEval -- + * + * Given a variable number of string arguments, concatenate them all + * together and execute the result as a Tcl command. + * + * Results: + * A standard Tcl return result. An error message or other result may be + * left in interp->result. + * + * Side effects: + * Depends on what was done by the command. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +Tcl_VarEval( + Tcl_Interp *interp, + ...) +{ + va_list argList; + int result; + + va_start(argList, interp); + result = Tcl_VarEvalVA(interp, argList); + va_end(argList); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalEval -- + * + * Evaluate a command at global level in an interpreter. + * + * Results: + * A standard Tcl result is returned, and the interp's result is modified + * accordingly. + * + * Side effects: + * The command string is executed in interp, and the execution is carried + * out in the variable context of global level (no functions active), + * just as if an "uplevel #0" command were being executed. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_GlobalEval +int +Tcl_GlobalEval( + Tcl_Interp *interp, /* Interpreter in which to evaluate + * command. */ + const char *command) /* Command to evaluate. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = iPtr->rootFramePtr; + result = Tcl_EvalEx(interp, command, -1, 0); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetRecursionLimit -- + * + * Set the maximum number of recursive calls that may be active for an + * interpreter at once. + * + * Results: + * The return value is the old limit on nesting for interp. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetRecursionLimit( + Tcl_Interp *interp, /* Interpreter whose nesting limit is to be + * set. */ + int depth) /* New value for maximimum depth. */ +{ + Interp *iPtr = (Interp *) interp; + int old; + + old = iPtr->maxNestingDepth; + if (depth > 0) { + iPtr->maxNestingDepth = depth; + } + return old; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AllowExceptions -- + * + * Sets a flag in an interpreter so that exceptions can occur in the next + * call to Tcl_Eval without them being turned into errors. + * + * Results: + * None. + * + * Side effects: + * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's evalFlags + * structure. See the reference documentation for more details. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AllowExceptions( + Tcl_Interp *interp) /* Interpreter in which to set flag. */ +{ + Interp *iPtr = (Interp *) interp; + + iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVersion -- + * + * Get the Tcl major, minor, and patchlevel version numbers and the + * release type. A patch is a release type TCL_FINAL_RELEASE with a + * patchLevel > 0. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_GetVersion( + int *majorV, + int *minorV, + int *patchLevelV, + int *type) +{ + if (majorV != NULL) { + *majorV = TCL_MAJOR_VERSION; + } + if (minorV != NULL) { + *minorV = TCL_MINOR_VERSION; + } + if (patchLevelV != NULL) { + *patchLevelV = TCL_RELEASE_SERIAL; + } + if (type != NULL) { + *type = TCL_RELEASE_LEVEL; + } +} + +/* + *---------------------------------------------------------------------- + * + * Math Functions -- + * + * This page contains the functions that implement all of the built-in + * math functions for expressions. + * + * Results: + * Each function returns TCL_OK if it succeeds and pushes an Tcl object + * holding the result. If it fails it returns TCL_ERROR and leaves an + * error message in the interpreter's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprCeilFunc( + ClientData clientData, /* Ignored */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter list. */ +{ + int code; + double d; + mp_int big; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +#endif + 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); + } else { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d))); + } + return TCL_OK; +} + +static int +ExprFloorFunc( + ClientData clientData, /* Ignored */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter list. */ +{ + int code; + double d; + mp_int big; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +#endif + 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); + } else { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d))); + } + return TCL_OK; +} + +static int +ExprIsqrtFunc( + ClientData clientData, /* Ignored */ + Tcl_Interp *interp, /* The interpreter in which to execute. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter list. */ +{ + ClientData ptr; + int type; + 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. */ + + /* + * Check syntax. + */ + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + /* + * Make sure that the arg is a number. + */ + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + + switch (type) { + case TCL_NUMBER_NAN: + Tcl_GetDoubleFromObj(interp, objv[1], &d); + return TCL_ERROR; + case TCL_NUMBER_DOUBLE: + d = *((const double *) ptr); + if (d < 0) { + goto negarg; + } +#ifdef IEEE_FLOATING_POINT + if (d <= MAX_EXACT) { + exact = 1; + } +#endif + if (!exact) { + if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { + return TCL_ERROR; + } + } + break; + case TCL_NUMBER_BIG: + if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { + return TCL_ERROR; + } + if (SIGN(&big) == MP_NEG) { + mp_clear(&big); + goto negarg; + } + break; + default: + if (TclGetWideIntFromObj(interp, objv[1], &w) != TCL_OK) { + return TCL_ERROR; + } + if (w < 0) { + goto negarg; + } + d = (double) w; +#ifdef IEEE_FLOATING_POINT + if (d < MAX_EXACT) { + exact = 1; + } +#endif + if (!exact) { + Tcl_GetBignumFromObj(interp, objv[1], &big); + } + break; + } + + if (exact) { + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d))); + } else { + mp_int root; + + mp_init(&root); + mp_sqrt(&big, &root); + 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_SetErrorCode(interp, "ARITH", "DOMAIN", + "domain error: argument not in valid range", NULL); + return TCL_ERROR; +} + +static int +ExprSqrtFunc( + ClientData clientData, /* Ignored */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter list. */ +{ + int code; + double d; + mp_int big; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + if ((d >= 0.0) && TclIsInfinite(d) + && (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) { + mp_int root; + + mp_init(&root); + mp_sqrt(&big, &root); + mp_clear(&big); + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root))); + mp_clear(&root); + } else { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d))); + } + return TCL_OK; +} + +static int +ExprUnaryFunc( + ClientData clientData, /* Contains the address of a function that + * takes one double argument and returns a + * double result. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + int code; + double d; + double (*func)(double) = (double (*)(double)) clientData; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + d = objv[1]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + errno = 0; + return CheckDoubleResult(interp, func(d)); +} + +static int +CheckDoubleResult( + Tcl_Interp *interp, + double dResult) +{ +#ifndef ACCEPT_NAN + if (TclIsNaN(dResult)) { + TclExprFloatError(interp, dResult); + return TCL_ERROR; + } +#endif + if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) { + /* + * When ERANGE signals under/overflow, just accept 0.0 or +/-Inf + */ + } else if (errno != 0) { + /* + * Report other errno values as errors. + */ + + TclExprFloatError(interp, dResult); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); + return TCL_OK; +} + +static int +ExprBinaryFunc( + ClientData clientData, /* Contains the address of a function that + * takes two double arguments and returns a + * double result. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Parameter vector. */ +{ + int code; + double d1, d2; + double (*func)(double, double) = (double (*)(double, double)) clientData; + + if (objc != 3) { + MathFuncWrongNumArgs(interp, 3, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + d1 = objv[1]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) { + d2 = objv[2]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + errno = 0; + return CheckDoubleResult(interp, func(d1, d2)); +} + +static int +ExprAbsFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Parameter vector. */ +{ + ClientData ptr; + int type; + mp_int big; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + + if (type == TCL_NUMBER_LONG) { + long l = *((const long *) ptr); + + if (l > (long)0) { + goto unChanged; + } else if (l == (long)0) { + const char *string = objv[1]->bytes; + if (string) { + while (*string != '0') { + if (*string == '-') { + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); + return TCL_OK; + } + string++; + } + } + goto unChanged; + } else if (l == LONG_MIN) { + TclBNInitBignumFromLong(&big, l); + goto tooLarge; + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); + return TCL_OK; + } + + if (type == TCL_NUMBER_DOUBLE) { + double d = *((const double *) ptr); + static const double poszero = 0.0; + + /* + * We need to distinguish here between positive 0.0 and negative -0.0. + * [Bug 2954959] + */ + + if (d == -0.0) { + if (!memcmp(&d, &poszero, sizeof(double))) { + goto unChanged; + } + } else if (d > -0.0) { + goto unChanged; + } + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); + return TCL_OK; + } + +#ifndef TCL_WIDE_INT_IS_LONG + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt w = *((const Tcl_WideInt *) ptr); + + if (w >= (Tcl_WideInt)0) { + goto unChanged; + } + if (w == LLONG_MIN) { + TclBNInitBignumFromWideInt(&big, w); + goto tooLarge; + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); + return TCL_OK; + } +#endif + + if (type == TCL_NUMBER_BIG) { + if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { + Tcl_GetBignumFromObj(NULL, objv[1], &big); + tooLarge: + mp_neg(&big, &big); + Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); + } else { + unChanged: + Tcl_SetObjResult(interp, objv[1]); + } + return TCL_OK; + } + + if (type == TCL_NUMBER_NAN) { +#ifdef ACCEPT_NAN + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; +#else + double d; + + Tcl_GetDoubleFromObj(interp, objv[1], &d); + return TCL_ERROR; +#endif + } + return TCL_OK; +} + +static int +ExprBoolFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + int value; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[1], &value) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +static int +ExprDoubleFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + double dResult; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { +#ifdef ACCEPT_NAN + if (objv[1]->typePtr == &tclDoubleType) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +#endif + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); + return TCL_OK; +} + +static int +ExprEntierFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + double d; + int type; + ClientData ptr; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + + if (type == TCL_NUMBER_DOUBLE) { + d = *((const double *) ptr); + if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) { + mp_int big; + + if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { + /* Infinity */ + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); + return TCL_OK; + } else { + long result = (long) d; + + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + return TCL_OK; + } + } + + if (type != TCL_NUMBER_NAN) { + /* + * All integers are already of integer type. + */ + + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + + /* + * Get the error message for NaN. + */ + + Tcl_GetDoubleFromObj(interp, objv[1], &d); + return TCL_ERROR; +} + +static int +ExprIntFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + long iResult; + Tcl_Obj *objPtr; + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { + return TCL_ERROR; + } + objPtr = Tcl_GetObjResult(interp); + if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) { + /* + * Truncate the bignum; keep only bits in long range. + */ + + mp_int big; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetLongFromObj(NULL, objPtr, &iResult); + Tcl_DecrRefCount(objPtr); + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); + return TCL_OK; +} + +static int +ExprWideFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + Tcl_WideInt wResult; + Tcl_Obj *objPtr; + + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { + return TCL_ERROR; + } + objPtr = Tcl_GetObjResult(interp); + if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { + /* + * Truncate the bignum; keep only bits in wide int range. + */ + + mp_int big; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetWideIntFromObj(NULL, objPtr, &wResult); + Tcl_DecrRefCount(objPtr); + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); + return TCL_OK; +} + +static int +ExprRandFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + Interp *iPtr = (Interp *) interp; + double dResult; + long tmp; /* Algorithm assumes at least 32 bits. Only + * long guarantees that. See below. */ + Tcl_Obj *oResult; + + if (objc != 1) { + MathFuncWrongNumArgs(interp, 1, objc, objv); + return TCL_ERROR; + } + + if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { + iPtr->flags |= RAND_SEED_INITIALIZED; + + /* + * Take into consideration the thread this interp is running in order + * to insure different seeds in different threads (bug #416643) + */ + + iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); + + /* + * Make sure 1 <= randSeed <= (2^31) - 2. See below. + */ + + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed ^= 123459876; + } + } + + /* + * Generate the random number using the linear congruential generator + * defined by the following recurrence: + * seed = ( IA * seed ) mod IM + * where IA is 16807 and IM is (2^31) - 1. The recurrence maps a seed in + * the range [1, IM - 1] to a new seed in that same range. The recurrence + * maps IM to 0, and maps 0 back to 0, so those two values must not be + * allowed as initial values of seed. + * + * In order to avoid potential problems with integer overflow, the + * recurrence is implemented in terms of additional constants IQ and IR + * such that + * IM = IA*IQ + IR + * None of the operations in the implementation overflows a 32-bit signed + * integer, and the C type long is guaranteed to be at least 32 bits wide. + * + * For more details on how this algorithm works, refer to the following + * papers: + * + * S.K. Park & K.W. Miller, "Random number generators: good ones are hard + * to find," Comm ACM 31(10):1192-1201, Oct 1988 + * + * W.H. Press & S.A. Teukolsky, "Portable random number generators," + * Computers in Physics 6(5):522-524, Sep/Oct 1992. + */ + +#define RAND_IA 16807 +#define RAND_IM 2147483647 +#define RAND_IQ 127773 +#define RAND_IR 2836 +#define RAND_MASK 123459876 + + tmp = iPtr->randSeed/RAND_IQ; + iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; + if (iPtr->randSeed < 0) { + iPtr->randSeed += RAND_IM; + } + + /* + * Since the recurrence keeps seed values in the range [1, RAND_IM - 1], + * dividing by RAND_IM yields a double in the range (0, 1). + */ + + dResult = iPtr->randSeed * (1.0/RAND_IM); + + /* + * Push a Tcl object with the result. + */ + + TclNewDoubleObj(oResult, dResult); + Tcl_SetObjResult(interp, oResult); + return TCL_OK; +} + +static int +ExprRoundFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Parameter vector. */ +{ + double d; + ClientData ptr; + int type; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + + if (type == TCL_NUMBER_DOUBLE) { + double fractPart, intPart; + long max = LONG_MAX, min = LONG_MIN; + + fractPart = modf(*((const double *) ptr), &intPart); + if (fractPart <= -0.5) { + min++; + } else if (fractPart >= 0.5) { + max--; + } + if ((intPart >= (double)max) || (intPart <= (double)min)) { + mp_int big; + + if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) { + /* Infinity */ + return TCL_ERROR; + } + if (fractPart <= -0.5) { + mp_sub_d(&big, 1, &big); + } else if (fractPart >= 0.5) { + mp_add_d(&big, 1, &big); + } + Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); + return TCL_OK; + } else { + long result = (long)intPart; + + if (fractPart <= -0.5) { + result--; + } else if (fractPart >= 0.5) { + result++; + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + return TCL_OK; + } + } + + if (type != TCL_NUMBER_NAN) { + /* + * All integers are already rounded + */ + + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + + /* + * Get the error message for NaN. + */ + + Tcl_GetDoubleFromObj(interp, objv[1], &d); + return TCL_ERROR; +} + +static int +ExprSrandFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Parameter vector. */ +{ + Interp *iPtr = (Interp *) interp; + long i = 0; /* Initialized to avoid compiler warning. */ + + /* + * Convert argument and use it to reset the seed. + */ + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) { + Tcl_Obj *objPtr; + mp_int big; + + if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { + /* TODO: more ::errorInfo here? or in caller? */ + return TCL_ERROR; + } + + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetLongFromObj(NULL, objPtr, &i); + Tcl_DecrRefCount(objPtr); + } + + /* + * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in + * ExprRandFunc for more details. + */ + + iPtr->flags |= RAND_SEED_INITIALIZED; + iPtr->randSeed = i; + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed ^= 123459876; + } + + /* + * To avoid duplicating the random number generation code we simply clean + * up our state and call the real random number function. That function + * will always succeed. + */ + + return ExprRandFunc(clientData, interp, 1, objv); +} + +/* + *---------------------------------------------------------------------- + * + * MathFuncWrongNumArgs -- + * + * Generate an error message when a math function presents the wrong + * number of arguments. + * + * Results: + * None. + * + * Side effects: + * An error message is stored in the interpreter result. + * + *---------------------------------------------------------------------- + */ + +static void +MathFuncWrongNumArgs( + Tcl_Interp *interp, /* Tcl interpreter */ + int expected, /* Formal parameter count. */ + int found, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + const char *name = TclGetString(objv[0]); + const char *tail = name + strlen(name); + + while (tail > name+1) { + tail--; + if (*tail == ':' && tail[-1] == ':') { + name = tail+1; + break; + } + } + 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 +/* + *---------------------------------------------------------------------- + * + * DTraceObjCmd -- + * + * This function is invoked to process the "::tcl::dtrace" Tcl command. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * The 'tcl-probe' DTrace probe is triggered (if it is enabled). + * + *---------------------------------------------------------------------- + */ + +static int +DTraceObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (TCL_DTRACE_TCL_PROBE_ENABLED()) { + char *a[10]; + int i = 0; + + while (i++ < 10) { + a[i-1] = i < objc ? TclGetString(objv[i]) : NULL; + } + TCL_DTRACE_TCL_PROBE(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], + a[8], a[9]); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclDTraceInfo -- + * + * Extract information from a TIP280 dict for use by DTrace probes. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclDTraceInfo( + Tcl_Obj *info, + const char **args, + int *argsi) +{ + static Tcl_Obj *keys[10] = { NULL }; + Tcl_Obj **k = keys, *val; + int i = 0; + + if (!*k) { +#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]); + } 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[]) +{ + NRE_callback *rootPtr = TOP_CB(interp); + + TclNRAddCallback(interp, Dispatch, objProc, clientData, + INT2PTR(objc), objv); + return TclNRRunCallbacks(interp, TCL_OK, 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|TCL_EVAL_NOERR, + (Command *) cmd); +} + +/***************************************************************************** + * Tailcall related code + ***************************************************************************** + * + * The steps of the tailcall dance are as follows: + * + * 1. when [tailcall] is invoked, it stores the corresponding callback in + * the current CallFrame and returns TCL_RETURN + * 2. when the CallFrame is popped, it calls TclSetTailcall to store the + * callback in the proper NRCommand callback - the spot where the command + * that pushed the CallFrame is completely cleaned up + * 3. when the NRCommand callback runs, it schedules the tailcall callback + * to run immediately after it returns + * + * One delicate point is to properly define the NRCommand where the tailcall + * will execute. There are functions whose purpose is to help define the + * precise spot: + * TclMarkTailcall: if the NEXT command to be pushed tailcalls, execution + * should continue right here + * TclSkipTailcall: if the NEXT command to be pushed tailcalls, execution + * should continue after the CURRENT command is fully returned ("skip + * the next command: we are redirecting to it, tailcalls should run + * after WE return") + * TclPushTailcallPoint: the search for a tailcalling spot cannot traverse + * this point. This is special for OO, as some of the oo constructs + * that behave like commands may not push an NRCommand callback. + */ + +void +TclMarkTailcall( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + if (iPtr->deferredCallbacks == NULL) { + TclNRAddCallback(interp, NRCommand, NULL, NULL, + NULL, NULL); + iPtr->deferredCallbacks = TOP_CB(interp); + } +} + +void +TclSkipTailcall( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + TclMarkTailcall(interp); + iPtr->deferredCallbacks->data[1] = INT2PTR(1); +} + +void +TclPushTailcallPoint( + Tcl_Interp *interp) +{ + TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); + ((Interp *) interp)->numLevels++; +} + + +/* + *---------------------------------------------------------------------- + * + * TclSetTailcall -- + * + * Splice a tailcall command in the proper spot of the NRE callback + * stack, so that it runs at the right time. + * + *---------------------------------------------------------------------- + */ + +void +TclSetTailcall( + Tcl_Interp *interp, + Tcl_Obj *listPtr) +{ + /* + * Find the splicing spot: right before the NRCommand of the thing + * being tailcalled. Note that we skip NRCommands marked by a 1 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!"); + } + runPtr->data[1] = listPtr; +} + + +/* + *---------------------------------------------------------------------- + * + * TclNRTailcallObjCmd -- + * + * Prepare the tailcall as a list and store it in the current + * varFrame. When the frame is later popped the tailcall will be spliced + * at the proper place. + * + * Results: + * The first NRCommand callback that is not marked to be skipped is + * updated so that its data[1] field contains the tailcall list. + * + *---------------------------------------------------------------------- + */ + +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)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tailcall can only be called from a proc, lambda or method", -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) { + Tcl_DecrRefCount(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. + */ + + if (objc > 1) { + Tcl_Obj *listPtr, *nsObjPtr; + Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + Tcl_Namespace *ns1Ptr; + + /* The tailcall data is in a Tcl list: the first element is the + * namespace, the rest the command to be tailcalled. */ + + listPtr = Tcl_NewListObj(objc, objv); + + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); + if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) + || (nsPtr != ns1Ptr)) { + Tcl_Panic("Tailcall failed to find the proper namespace"); + } + TclListObjSetElement(interp, listPtr, 0, nsObjPtr); + + iPtr->varFramePtr->tailcallPtr = listPtr; + } + return TCL_RETURN; +} + + +/* + *---------------------------------------------------------------------- + * + * TclNRTailcallEval -- + * + * This NREcallback actually causes the tailcall to be evaluated. + * + *---------------------------------------------------------------------- + */ + +int +TclNRTailcallEval( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *listPtr = data[0], *nsObjPtr; + Tcl_Namespace *nsPtr; + int objc; + Tcl_Obj **objv; + + Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); + nsObjPtr = objv[0]; + + 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. + */ + + Tcl_DecrRefCount(listPtr); + return result; + } + + /* + * Perform the tailcall + */ + + TclMarkTailcall(interp); + TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); + iPtr->lookupNsPtr = (Namespace *) nsPtr; + return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); +} + +int +TclNRReleaseValues( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + int i = 0; + while (i < 4) { + if (data[i]) { + Tcl_DecrRefCount((Tcl_Obj *) data[i]); + } else { + break; + } + i++; + } + return result; +} + + +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 = TclGetCurrentNamespace(interp); + + 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; + } + + if (((Namespace *) nsPtr)->flags & NS_DYING) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto called in deleted namespace", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", + NULL); + return TCL_ERROR; + } + + /* + * Add the tailcall in the caller env, then just yield. + * + * This is essentially code from TclNRTailcallObjCmd + */ + + listPtr = Tcl_NewListObj(objc, objv); + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); + TclListObjSetElement(interp, listPtr, 0, nsObjPtr); + + /* + * Add the callback in the caller's env, then instruct TEBC to yield. + */ + + iPtr->execEnvPtr = corPtr->callerEEPtr; + TclSetTailcall(interp, listPtr); + iPtr->execEnvPtr = corPtr->eePtr; + + return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); +} + +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; +} + +/* + *---------------------------------------------------------------------- + * + * TclNREvalList -- + * + * Callback to invoke command as list, used in order to delayed + * processing of canonical list command in sane environment. + * + *---------------------------------------------------------------------- + */ + +static int +TclNREvalList( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + int objc; + Tcl_Obj **objv; + Tcl_Obj *listPtr = data[0]; + + Tcl_IncrRefCount(listPtr); + + TclMarkTailcall(interp); + TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); + TclListObjGetElements(NULL, listPtr, &objc, &objv); + return TclNREvalObjv(interp, objc, objv, 0, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * 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; + TclNRAddCallback(interp, TclNREvalList, Tcl_NewListObj(objc-2, objv+2), + NULL, NULL, NULL); + 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", + TclGetString(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: + */ |