diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 10178 |
1 files changed, 3941 insertions, 6237 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e09ea1e..c738916 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1,435 +1,280 @@ -/* +/* * tclBasic.c -- * * Contains the basic facilities for TCL command interpretation, - * including interpreter creation and deletion, command creation and - * deletion, and command/script execution. + * 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. + * 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> - -#if NRE_ENABLE_ASSERTS -#include <assert.h> +#ifndef TCL_GENERIC_ONLY +# include "tclPort.h" #endif -#define INTERP_STACK_INITIAL_SIZE 2000 -#define CORO_STACK_INITIAL_SIZE 200 - /* - * Determine whether we're using IEEE floating point + * Static procedures in this file: */ -#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 +static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr, + Command *cmdPtr, CONST char *oldName, + CONST char* newName, int flags)); +static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); +static void ProcessUnexpectedResult _ANSI_ARGS_(( + Tcl_Interp *interp, int returnCode)); +static int StringTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp, + int level, + CONST char* command, + Tcl_Command commandInfo, + int objc, + Tcl_Obj *CONST objv[])); +static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); + +#ifdef TCL_TIP280 +/* TIP #280 - Modified token based evaluation, with line information */ +static int EvalEx _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, + int numBytes, int flags, int line, + int* clNextOuter, CONST char* outerScript)); + +static int EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *tokenPtr, + int count, int line, + int* clNextOuter, CONST char* outerScript)); #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. - */ - -static const CorContext NULL_CONTEXT = {NULL, NULL, NULL, NULL}; - -#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 Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, - Tcl_Obj *const objv[], int lookup); -static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, - int actual, Tcl_Obj *const *objv); -static Tcl_NRPostProc NRCoroutineActivateCallback; -static Tcl_NRPostProc NRCoroutineCallerCallback; -static Tcl_NRPostProc NRCoroutineExitCallback; -static Tcl_NRPostProc NRRunObjProc; -static Tcl_NRPostProc NRTailcallEval; -static Tcl_ObjCmdProc OldMathFuncProc; -static void OldMathFuncDeleteProc(ClientData clientData); -static void ProcessUnexpectedResult(Tcl_Interp *interp, - int returnCode); -static int RewindCoroutine(CoroutineData *corPtr, int result); -static void TEOV_SwitchVarFrame(Tcl_Interp *interp); -static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[], int flags); -static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, - Tcl_Obj *namePtr, Namespace *lookupNsPtr); -static int TEOV_NotFound(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); -static int TEOV_RunEnterTraces(Tcl_Interp *interp, - Command **cmdPtrPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); -static Tcl_NRPostProc RewindCoroutineCallback; -static Tcl_NRPostProc TailcallCleanup; -static Tcl_NRPostProc TEOEx_ByteCodeCallback; -static Tcl_NRPostProc TEOEx_ListCallback; -static Tcl_NRPostProc TEOV_Error; -static Tcl_NRPostProc TEOV_Exception; -static Tcl_NRPostProc TEOV_NotFoundCallback; -static Tcl_NRPostProc TEOV_RestoreVarFrame; -static Tcl_NRPostProc TEOV_RunLeaveTraces; -static Tcl_NRPostProc YieldToCallback; - -static void ClearTailcall(Tcl_Interp *interp, - struct NRE_callback *tailcallPtr); -static Tcl_ObjCmdProc NRCoroInjectObjCmd; - -MODULE_SCOPE const TclStubs tclStubs; - -/* - * Magical counts for the number of arguments accepted by a coroutine command - * after particular kinds of [yield]. - */ +static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +#endif -#define CORO_ACTIVATE_YIELD PTR2INT(NULL) -#define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1 +extern TclStubs tclStubs; -#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) -#define COROUTINE_ARGUMENTS_ARBITRARY (-2) - /* - * The following structure define the commands in the Tcl core. + * The following structure defines 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 isSafe; /* If non-zero, command will be present in - * safe interpreter. Otherwise it will be - * hidden. */ + CONST char *name; /* Name of object-based command. */ + Tcl_CmdProc *proc; /* String-based procedure for command. */ + Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */ + CompileProc *compileProc; /* Procedure called to compile command. */ + int isSafe; /* If non-zero, command will be present + * in safe interpreter. Otherwise it will + * be hidden. */ } CmdInfo; /* - * The built-in commands, and the functions that implement them: - */ - -static const CmdInfo builtInCmds[] = { - /* - * Commands in the generic core. - */ - - {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, 1}, - {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, 1}, - {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, 1}, -#ifndef EXCLUDE_OBSOLETE_COMMANDS - {"case", Tcl_CaseObjCmd, NULL, NULL, 1}, -#endif - {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, 1}, - {"concat", Tcl_ConcatObjCmd, NULL, NULL, 1}, - {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1}, - {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1}, - {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, 1}, - {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, 1}, - {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1}, - {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, - {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, - {"format", Tcl_FormatObjCmd, NULL, NULL, 1}, - {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, - {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, - {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1}, - {"join", Tcl_JoinObjCmd, NULL, NULL, 1}, - {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, 1}, - {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, 1}, - {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, 1}, - {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1}, - {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1}, - {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, - {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1}, - {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, - {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1}, - {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1}, - {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, - {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, - {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1}, - {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, - {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, - {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, - {"regsub", Tcl_RegsubObjCmd, NULL, NULL, 1}, - {"rename", Tcl_RenameObjCmd, NULL, NULL, 1}, - {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1}, - {"scan", Tcl_ScanObjCmd, NULL, NULL, 1}, - {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1}, - {"split", Tcl_SplitObjCmd, NULL, NULL, 1}, - {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1}, - {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1}, - {"tailcall", NULL, NULL, TclNRTailcallObjCmd, 1}, - {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1}, - {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, - {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1}, - {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, 1}, - {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1}, - {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1}, - {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, - {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1}, - {"yield", NULL, NULL, TclNRYieldObjCmd, 1}, - {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1}, - - /* - * Commands in the OS-interface. Note that many of these are unsafe. - */ - - {"after", Tcl_AfterObjCmd, NULL, NULL, 1}, - {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, - {"close", Tcl_CloseObjCmd, NULL, NULL, 1}, - {"eof", Tcl_EofObjCmd, NULL, NULL, 1}, - {"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0}, - {"exec", Tcl_ExecObjCmd, NULL, NULL, 0}, - {"exit", Tcl_ExitObjCmd, NULL, NULL, 0}, - {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1}, - {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, - {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1}, - {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1}, - {"flush", Tcl_FlushObjCmd, NULL, NULL, 1}, - {"gets", Tcl_GetsObjCmd, NULL, NULL, 1}, - {"glob", Tcl_GlobObjCmd, NULL, NULL, 0}, - {"load", Tcl_LoadObjCmd, NULL, NULL, 0}, - {"open", Tcl_OpenObjCmd, NULL, NULL, 0}, - {"pid", Tcl_PidObjCmd, NULL, NULL, 1}, - {"puts", Tcl_PutsObjCmd, NULL, NULL, 1}, - {"pwd", Tcl_PwdObjCmd, NULL, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, NULL, 1}, - {"seek", Tcl_SeekObjCmd, NULL, NULL, 1}, - {"socket", Tcl_SocketObjCmd, NULL, NULL, 0}, - {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, - {"tell", Tcl_TellObjCmd, NULL, NULL, 1}, - {"time", Tcl_TimeObjCmd, NULL, NULL, 1}, - {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, - {"update", Tcl_UpdateObjCmd, NULL, NULL, 1}, - {"vwait", Tcl_VwaitObjCmd, NULL, NULL, 1}, - {NULL, NULL, NULL, NULL, 0} -}; - -/* - * Math functions. All are safe. + * The built-in commands, and the procedures that implement them: */ -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 } +static CONST CmdInfo builtInCmds[] = { + /* + * Commands in the generic core. Note that at least one of the proc or + * objProc members should be non-NULL. This avoids infinitely recursive + * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a + * command name is computed at runtime and results in the name of a + * compiled command. + */ + + {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd, + TclCompileAppendCmd, 1}, + {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd, + (CompileProc *) NULL, 1}, + {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, + (CompileProc *) NULL, 1}, + {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd, + TclCompileBreakCmd, 1}, + {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, + (CompileProc *) NULL, 1}, + {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd, + TclCompileCatchCmd, 1}, + {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd, + (CompileProc *) NULL, 1}, + {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, + (CompileProc *) NULL, 1}, + {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd, + TclCompileContinueCmd, 1}, + {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd, + (CompileProc *) NULL, 0}, + {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, + (CompileProc *) NULL, 1}, + {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd, + (CompileProc *) NULL, 1}, + {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd, + (CompileProc *) NULL, 0}, + {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd, + TclCompileExprCmd, 1}, + {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, + (CompileProc *) NULL, 1}, + {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd, + (CompileProc *) NULL, 1}, + {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd, + TclCompileForCmd, 1}, + {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, + TclCompileForeachCmd, 1}, + {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd, + (CompileProc *) NULL, 1}, + {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, + (CompileProc *) NULL, 1}, + {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd, + TclCompileIfCmd, 1}, + {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd, + TclCompileIncrCmd, 1}, + {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, + (CompileProc *) NULL, 1}, + {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, + (CompileProc *) NULL, 1}, + {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, + TclCompileLappendCmd, 1}, + {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, + TclCompileLindexCmd, 1}, + {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, + (CompileProc *) NULL, 1}, + {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd, + TclCompileListCmd, 1}, + {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, + TclCompileLlengthCmd, 1}, + {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd, + (CompileProc *) NULL, 0}, + {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, + (CompileProc *) NULL, 1}, + {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd, + (CompileProc *) NULL, 1}, + {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd, + (CompileProc *) NULL, 1}, + {"lset", (Tcl_CmdProc *) NULL, Tcl_LsetObjCmd, + TclCompileLsetCmd, 1}, + {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd, + (CompileProc *) NULL, 1}, + {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, + (CompileProc *) NULL, 1}, + {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd, + (CompileProc *) NULL, 1}, + {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, + (CompileProc *) NULL, 1}, + {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd, + TclCompileRegexpCmd, 1}, + {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd, + (CompileProc *) NULL, 1}, + {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, + (CompileProc *) NULL, 1}, + {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, + TclCompileReturnCmd, 1}, + {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, + (CompileProc *) NULL, 1}, + {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, + TclCompileSetCmd, 1}, + {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, + (CompileProc *) NULL, 1}, + {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, + TclCompileStringCmd, 1}, + {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, + (CompileProc *) NULL, 1}, + {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, + (CompileProc *) NULL, 1}, + {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd, + (CompileProc *) NULL, 1}, + {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, + (CompileProc *) NULL, 1}, + {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd, + (CompileProc *) NULL, 1}, + {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd, + (CompileProc *) NULL, 1}, + {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, + (CompileProc *) NULL, 1}, + {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd, + TclCompileWhileCmd, 1}, + + /* + * Commands in the UNIX core: + */ + +#ifndef TCL_GENERIC_ONLY + {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd, + (CompileProc *) NULL, 1}, + {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd, + (CompileProc *) NULL, 0}, + {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd, + (CompileProc *) NULL, 1}, + {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd, + (CompileProc *) NULL, 1}, + {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, + (CompileProc *) NULL, 1}, + {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd, + (CompileProc *) NULL, 0}, + {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, + (CompileProc *) NULL, 0}, + {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd, + (CompileProc *) NULL, 1}, + {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, + (CompileProc *) NULL, 1}, + {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd, + (CompileProc *) NULL, 0}, + {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd, + (CompileProc *) NULL, 0}, + {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd, + (CompileProc *) NULL, 1}, + {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, + (CompileProc *) NULL, 1}, + {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd, + (CompileProc *) NULL, 0}, + {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, + (CompileProc *) NULL, 1}, + {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd, + (CompileProc *) NULL, 1}, + {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd, + (CompileProc *) NULL, 0}, + {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd, + (CompileProc *) NULL, 1}, + {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, + (CompileProc *) NULL, 1}, + {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd, + (CompileProc *) NULL, 1}, + {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd, + (CompileProc *) NULL, 1}, + +#ifdef MAC_TCL + {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd, + (CompileProc *) NULL, 0}, + {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd, + (CompileProc *) NULL, 0}, + {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd, + (CompileProc *) NULL, 1}, + {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd, + (CompileProc *) NULL, 0}, +#else + {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd, + (CompileProc *) NULL, 0}, + {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, + (CompileProc *) NULL, 0}, +#endif /* MAC_TCL */ + +#endif /* TCL_GENERIC_ONLY */ + {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0} }; /* - * 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. - * - *---------------------------------------------------------------------- + * The following structure holds the client data for string-based + * trace procs */ -void -TclFinalizeEvaluation(void) -{ - Tcl_MutexLock(&cancelLock); - if (cancelTableInitialized == 1) { - Tcl_DeleteHashTable(&cancelTable); - cancelTableInitialized = 0; - } - Tcl_MutexUnlock(&cancelLock); -} +typedef struct StringTraceData { + ClientData clientData; /* Client data from Tcl_CreateTrace */ + Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */ +} StringTraceData; /* *---------------------------------------------------------------------- @@ -439,29 +284,28 @@ TclFinalizeEvaluation(void) * 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. + * The return value is a token for the interpreter, which may be + * used in calls to procedures 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). + * The command interpreter is initialized with the built-in commands + * and with the variables documented in tclvars(n). * *---------------------------------------------------------------------- */ Tcl_Interp * -Tcl_CreateInterp(void) +Tcl_CreateInterp() { Interp *iPtr; Tcl_Interp *interp; Command *cmdPtr; - const BuiltinFuncDef *builtinFuncPtr; - const OpCmdInfo *opcmdInfoPtr; - const CmdInfo *cmdInfoPtr; - Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr; + BuiltinFunc *builtinFuncPtr; + MathFunc *mathFuncPtr; Tcl_HashEntry *hPtr; - int isNew; - CancelInfo *cancelInfo; + CONST CmdInfo *cmdInfoPtr; + int i; union { char c[sizeof(short)]; short s; @@ -469,96 +313,65 @@ Tcl_CreateInterp(void) #ifdef TCL_COMPILE_STATS ByteCodeStats *statsPtr; #endif /* TCL_COMPILE_STATS */ - char mathFuncName[32]; - CallFrame *framePtr; - int result; - TclInitSubsystems(); + TclInitSubsystems(NULL); /* - * Panic if someone updated the CallFrame structure without also updating - * the Tcl_CallFrame structure (or vice versa). - */ + * 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 (cancelTableInitialized == 0) { - Tcl_MutexLock(&cancelLock); - if (cancelTableInitialized == 0) { - Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS); - cancelTableInitialized = 1; - } - Tcl_MutexUnlock(&cancelLock); + panic("Tcl_CallFrame must not be smaller than CallFrame"); } /* * 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. + * (whose name is ""; an alias is "::"). This also initializes the + * Tcl object type table and other object management code. */ - iPtr = ckalloc(sizeof(Interp)); + iPtr = (Interp *) ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = NULL; - iPtr->errorLine = 0; - iPtr->objResultPtr = Tcl_NewObj(); + iPtr->result = iPtr->resultSpace; + 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; + iPtr->handle = TclHandleCreate(iPtr); + iPtr->globalNsPtr = NULL; + iPtr->hiddenCmdTablePtr = NULL; + iPtr->interpInfo = NULL; + Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); 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 */ + iPtr->framePtr = NULL; + iPtr->varFramePtr = NULL; +#ifdef TCL_TIP280 /* - * TIP #280 - Initialize the arrays used to extend the ByteCode and Proc - * structures. + * TIP #280 - Initialize the arrays used to extend the ByteCode and + * Proc structures. */ - - iPtr->cmdFramePtr = NULL; - iPtr->linePBodyPtr = ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineBCPtr = ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineLAPtr = ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable)); + iPtr->cmdFramePtr = NULL; + iPtr->linePBodyPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); + iPtr->lineBCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); + iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); + iPtr->lineLABCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); 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); + 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; +#endif iPtr->activeVarTracePtr = NULL; - - iPtr->returnOpts = NULL; + iPtr->returnCode = TCL_OK; 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; iPtr->appendResult = NULL; iPtr->appendAvl = 0; @@ -566,16 +379,15 @@ Tcl_CreateInterp(void) Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; - +#ifdef TCL_TIP268 /* TIP #268 */ - if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { - iPtr->packagePrefer = PKG_PREFER_STABLE; - } else { - iPtr->packagePrefer = PKG_PREFER_LATEST; - } - + iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ? + PKG_PREFER_STABLE : + PKG_PREFER_LATEST); +#endif iPtr->cmdCount = 0; - TclInitLiteralTable(&iPtr->literalTable); + iPtr->termOffset = 0; + TclInitLiteralTable(&(iPtr->literalTable)); iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; @@ -586,90 +398,28 @@ Tcl_CreateInterp(void) 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. */ + iPtr->assocData = (Tcl_HashTable *) NULL; + iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ + iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->resultSpace[0] = 0; iPtr->threadId = Tcl_GetCurrentThread(); - /* TIP #378 */ -#ifdef TCL_INTERP_DEBUG_FRAME - iPtr->flags |= INTERP_DEBUG_FRAME; -#else - if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) { - iPtr->flags |= INTERP_DEBUG_FRAME; - } -#endif - - /* - * Initialise the tables for variable traces and searches *before* - * creating the global ns - so that the trace on errorInfo can be - * 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 = NULL; /* force creation of global ns below */ iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", - NULL, NULL); + (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (iPtr->globalNsPtr == NULL) { - Tcl_Panic("Tcl_CreateInterp: can't create global namespace"); + 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)); - result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, - (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); - if (result != TCL_OK) { - Tcl_Panic("Tcl_CreateInterp: failed to push the root stack frame"); - } - 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); + iPtr->execEnvPtr = TclCreateExecEnv(interp); /* * Initialize the compilation and execution statistics kept for this @@ -677,32 +427,35 @@ Tcl_CreateInterp(void) */ #ifdef TCL_COMPILE_STATS - statsPtr = &iPtr->stats; + statsPtr = &(iPtr->stats); statsPtr->numExecutions = 0; statsPtr->numCompilations = 0; statsPtr->numByteCodesFreed = 0; - memset(statsPtr->instructionCount, 0, + (VOID *) 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; + (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); + (VOID *) memset(statsPtr->byteCodeCount, 0, + sizeof(statsPtr->byteCodeCount)); + (VOID *) memset(statsPtr->lifetimeCount, 0, + sizeof(statsPtr->lifetimeCount)); + + statsPtr->currentInstBytes = 0.0; + statsPtr->currentLitBytes = 0.0; statsPtr->currentExceptBytes = 0.0; - statsPtr->currentAuxBytes = 0.0; + statsPtr->currentAuxBytes = 0.0; statsPtr->currentCmdMapBytes = 0.0; - - statsPtr->numLiteralsCreated = 0; - statsPtr->totalLitStringBytes = 0.0; + + statsPtr->numLiteralsCreated = 0; + statsPtr->totalLitStringBytes = 0.0; statsPtr->currentLitStringBytes = 0.0; - memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); -#endif /* TCL_COMPILE_STATS */ + (VOID *) memset(statsPtr->literalCount, 0, + sizeof(statsPtr->literalCount)); +#endif /* TCL_COMPILE_STATS */ /* * Initialise the stub table pointer. @@ -710,130 +463,61 @@ Tcl_CreateInterp(void) iPtr->stubTable = &tclStubs; - /* - * Initialize the ensemble error message rewriting support. - */ - - iPtr->ensembleRewrite.sourceObjs = NULL; - iPtr->ensembleRewrite.numRemovedObjs = 0; - iPtr->ensembleRewrite.numInsertedObjs = 0; - - /* - * 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"); + * 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 procedure + * that extracts strings, calls the string procedure, 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++) { + int new; + Tcl_HashEntry *hPtr; + + if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) + && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) + && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { + panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n"); } - + hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, - cmdInfoPtr->name, &isNew); - if (isNew) { - cmdPtr = ckalloc(sizeof(Command)); + cmdInfoPtr->name, &new); + if (new) { + cmdPtr = (Command *) 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; + if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) { + cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->clientData = (ClientData) cmdPtr; + } else { + cmdPtr->proc = cmdInfoPtr->proc; + cmdPtr->clientData = (ClientData) NULL; + } + if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { + cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objClientData = (ClientData) cmdPtr; + } else { + cmdPtr->objProc = cmdInfoPtr->objProc; + cmdPtr->objClientData = (ClientData) NULL; + } cmdPtr->deleteProc = NULL; - cmdPtr->deleteData = NULL; + cmdPtr->deleteData = (ClientData) NULL; cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = cmdInfoPtr->nreProc; Tcl_SetHashValue(hPtr, cmdPtr); } } - /* - * Create the "array", "binary", "chan", "dict", "file", "info", - * "namespace" and "string" ensembles. Note that all these commands (and - * their subcommands that are not present in the global namespace) are - * wholly safe *except* for "file". - */ - - TclInitArrayCmd(interp); - TclInitBinaryCmd(interp); - TclInitChanCmd(interp); - TclInitDictCmd(interp); - TclInitFileCmd(interp); - TclInitInfoCmd(interp); - TclInitNamespaceCmd(interp); - TclInitStringCmd(interp); - TclInitPrefixCmd(interp); - - /* - * Register "clock" subcommands. These *do* go through - * 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, NULL, NULL); - Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", - Tcl_RepresentationCmd, NULL, NULL); - - /* Adding the bytecode assembler command */ - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, - "::tcl::unsupported::assemble", Tcl_AssembleObjCmd, - TclNRAssembleObjCmd, NULL, NULL); - cmdPtr->compileProc = &TclCompileAssembleCmd; - - Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, - NRCoroInjectObjCmd, NULL, NULL); - #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -846,60 +530,57 @@ Tcl_CreateInterp(void) * 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; + i = 0; + for (builtinFuncPtr = tclBuiltinFuncTable; 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; + Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name, + builtinFuncPtr->numArgs, builtinFuncPtr->argTypes, + (Tcl_MathProc *) NULL, (ClientData) 0); + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, + builtinFuncPtr->name); + if (hPtr == NULL) { + panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name); + return NULL; } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + mathFuncPtr->builtinFuncIndex = i; + i++; } + iPtr->flags |= EXPR_INITIALIZED; /* * Do Multiple/Safe Interps Tcl init stuff */ TclInterpInit(interp); - TclSetupEnv(interp); /* - * TIP #59: Make embedded configuration information available. + * We used to create the "errorInfo" and "errorCode" global vars at this + * point because so much of the Tcl implementation assumes they already + * exist. This is not quite enough, however, since they can be unset + * at any time. + * + * There are 2 choices: + * + Check every place where a GetVar of those is used + * and the NULL result is not checked (like in tclLoad.c) + * + Make SetVar,... NULL friendly + * We choose the second option because : + * + It is easy and low cost to check for NULL pointer before + * calling strlen() + * + It can be helpfull to other people using those API + * + Passing a NULL value to those closest 'meaning' is empty string + * (specially with the new objects where 0 bytes strings are ok) + * So the following init is commented out: -- dl + * + * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, + * "", TCL_GLOBAL_ONLY); + * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, + * "NONE", TCL_GLOBAL_ONLY); */ - TclInitEmbeddedConfigurationInformation(interp); +#ifndef TCL_GENERIC_ONLY + TclSetupEnv(interp); +#endif /* * Compute the byte order of this machine. @@ -913,77 +594,62 @@ Tcl_CreateInterp(void) 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_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, "tcl_precision", NULL, + Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - TclPrecTraceProc, NULL); + TclPrecTraceProc, (ClientData) 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. + * 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); + + 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 + * TIP#268: Expose information about its status, + * for runtime switches in the core library + * and tests. */ - Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); - - if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); - } - - if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); - } - - /* - * Only build in zlib support if we've successfully detected a library to - * compile and link against. - */ + Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); -#ifdef HAVE_ZLIB - if (TclZlibInit(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); - } +#ifdef TCL_TIP268 + Tcl_SetVar2(interp, "tcl_platform", "tip,268", "1", + TCL_GLOBAL_ONLY); +#endif +#ifdef TCL_TIP280 + Tcl_SetVar2(interp, "tcl_platform", "tip,280", "1", + TCL_GLOBAL_ONLY); #endif +#ifdef Tcl_InitStubs +#undef Tcl_InitStubs +#endif + Tcl_InitStubs(interp, TCL_VERSION, 1); - 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. + * Hides base commands that are not marked as safe from this + * interpreter. * * Results: * TCL_OK if it succeeds, TCL_ERROR else. @@ -995,20 +661,19 @@ DeleteOpCmdClientData( */ int -TclHideUnsafeCommands( - Tcl_Interp *interp) /* Hide commands in this interpreter. */ +TclHideUnsafeCommands(interp) + Tcl_Interp *interp; /* Hide commands in this interpreter. */ { - register const CmdInfo *cmdInfoPtr; + register CONST CmdInfo *cmdInfoPtr; - if (interp == NULL) { - return TCL_ERROR; + if (interp == (Tcl_Interp *) NULL) { + return TCL_ERROR; } for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { - if (!cmdInfoPtr->isSafe) { - Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); - } + if (!cmdInfoPtr->isSafe) { + Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); + } } - TclMakeFileCommandSafe(interp); /* Ugh! */ return TCL_OK; } @@ -1017,46 +682,48 @@ TclHideUnsafeCommands( * * 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 + * Arrange for a procedure to be called before a given + * interpreter is deleted. The procedure is called as soon + * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is + * called on an interpreter that has already been deleted, + * the procedure 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. + * 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. */ +Tcl_CallWhenDeleted(interp, proc, clientData) + Tcl_Interp *interp; /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc; /* Procedure 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, (int)sizeof(int)); - int isNew; + int new; char buffer[32 + TCL_INTEGER_SPACE]; - AssocData *dPtr = ckalloc(sizeof(AssocData)); + AssocData *dPtr = (AssocData *) 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); + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } - hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew); + hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); dPtr->proc = proc; dPtr->clientData = clientData; Tcl_SetHashValue(hPtr, dPtr); @@ -1067,26 +734,27 @@ Tcl_CallWhenDeleted( * * Tcl_DontCallWhenDeleted -- * - * Cancel the arrangement for a function to be called when a given - * interpreter is deleted. + * Cancel the arrangement for a procedure 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. + * 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. */ +Tcl_DontCallWhenDeleted(interp, proc, clientData) + Tcl_Interp *interp; /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc; /* Procedure 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; @@ -1095,17 +763,17 @@ Tcl_DontCallWhenDeleted( AssocData *dPtr; hTablePtr = iPtr->assocData; - if (hTablePtr == NULL) { - return; + if (hTablePtr == (Tcl_HashTable *) 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; - } + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); + return; + } } } @@ -1115,9 +783,9 @@ Tcl_DontCallWhenDeleted( * 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. + * 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. @@ -1129,27 +797,27 @@ Tcl_DontCallWhenDeleted( */ 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. */ +Tcl_SetAssocData(interp, name, proc, clientData) + 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; + int new; - if (iPtr->assocData == NULL) { - iPtr->assocData = ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + iPtr->assocData = (Tcl_HashTable *) 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); + hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); + if (new == 0) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); } else { - dPtr = ckalloc(sizeof(AssocData)); + dPtr = (AssocData *) ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; @@ -1162,8 +830,8 @@ Tcl_SetAssocData( * * Tcl_DeleteAssocData -- * - * Deletes a named association of user-specified data with the specified - * interpreter. + * Deletes a named association of user-specified data with + * the specified interpreter. * * Results: * None. @@ -1175,26 +843,26 @@ Tcl_SetAssocData( */ void -Tcl_DeleteAssocData( - Tcl_Interp *interp, /* Interpreter to associate with. */ - const char *name) /* Name of association. */ +Tcl_DeleteAssocData(interp, name) + 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; + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + return; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); - if (hPtr == NULL) { - return; + if (hPtr == (Tcl_HashEntry *) NULL) { + return; } - dPtr = Tcl_GetHashValue(hPtr); + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if (dPtr->proc != NULL) { - dPtr->proc(dPtr->clientData, interp); + (dPtr->proc) (dPtr->clientData, interp); } - ckfree(dPtr); + ckfree((char *) dPtr); Tcl_DeleteHashEntry(hPtr); } @@ -1203,8 +871,8 @@ Tcl_DeleteAssocData( * * Tcl_GetAssocData -- * - * Returns the client data associated with this name in the specified - * interpreter. + * Returns the client data associated with this name in the + * specified interpreter. * * Results: * The client data in the AssocData record denoted by the named @@ -1217,27 +885,26 @@ Tcl_DeleteAssocData( */ 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. */ +Tcl_GetAssocData(interp, name, procPtr) + 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; + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + return (ClientData) NULL; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); - if (hPtr == NULL) { - return NULL; + if (hPtr == (Tcl_HashEntry *) NULL) { + return (ClientData) NULL; } - dPtr = Tcl_GetHashValue(hPtr); - if (procPtr != NULL) { - *procPtr = dPtr->proc; + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if (procPtr != (Tcl_InterpDeleteProc **) NULL) { + *procPtr = dPtr->proc; } return dPtr->clientData; } @@ -1247,8 +914,8 @@ Tcl_GetAssocData( * * Tcl_InterpDeleted -- * - * Returns nonzero if the interpreter has been deleted with a call to - * Tcl_DeleteInterp. + * Returns nonzero if the interpreter has been deleted with a call + * to Tcl_DeleteInterp. * * Results: * Nonzero if the interpreter is deleted, zero otherwise. @@ -1260,8 +927,8 @@ Tcl_GetAssocData( */ int -Tcl_InterpDeleted( - Tcl_Interp *interp) +Tcl_InterpDeleted(interp) + Tcl_Interp *interp; { return (((Interp *) interp)->flags & DELETED) ? 1 : 0; } @@ -1271,11 +938,11 @@ Tcl_InterpDeleted( * * 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. + * 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 procedure runs the currently registered deletion callbacks. * * Results: * None. @@ -1290,9 +957,9 @@ Tcl_InterpDeleted( */ void -Tcl_DeleteInterp( - Tcl_Interp *interp) /* Token for command interpreter (returned by - * a previous call to Tcl_CreateInterp). */ +Tcl_DeleteInterp(interp) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ { Interp *iPtr = (Interp *) interp; @@ -1301,22 +968,21 @@ Tcl_DeleteInterp( */ if (iPtr->flags & DELETED) { - return; + 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); + Tcl_EventuallyFree((ClientData) interp, + (Tcl_FreeProc *) DeleteInterpProc); } /* @@ -1324,204 +990,149 @@ Tcl_DeleteInterp( * * 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. + * Helper procedure to delete an interpreter. This procedure is + * called when the last call to Tcl_Preserve on this interpreter + * is matched by a call to Tcl_Release. The procedure 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. + * Whatever the interpreter deletion callbacks do. Frees resources + * used by the interpreter. * *---------------------------------------------------------------------- */ static void -DeleteInterpProc( - Tcl_Interp *interp) /* Interpreter to delete. */ +DeleteInterpProc(interp) + 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. + * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. */ - - if ((iPtr->numLevels > 0) && !TclInExit()) { - Tcl_Panic("DeleteInterpProc called with active evals"); + + if (iPtr->numLevels > 0) { + panic("DeleteInterpProc called with active evals"); } /* - * The interpreter should already be marked deleted; otherwise how did we - * get here? + * 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; + panic("DeleteInterpProc called on interpreter not marked deleted"); } - 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); + TclHandleFree(iPtr->handle); /* + * Dismantle everything in the global namespace except for the + * "errorInfo" and "errorCode" variables. These remain until the + * namespace is actually destroyed, in case any errors occur. + * * 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 + * 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)); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_DeleteCommandFromToken(interp, + (Tcl_Command) Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); - ckfree(hTablePtr); + ckfree((char *) hTablePtr); } + /* + * Tear down the math function table. + */ + + for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&iPtr->mathFuncTable); /* * Invoke deletion callbacks; note that a callback can create new * callbacks, so we iterate. */ - while (iPtr->assocData != NULL) { + while (iPtr->assocData != (Tcl_HashTable *) 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); + + hTablePtr = iPtr->assocData; + iPtr->assocData = (Tcl_HashTable *) NULL; + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (dPtr->proc != NULL) { + (*dPtr->proc)(dPtr->clientData, interp); + } + ckfree((char *) dPtr); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree((char *) hTablePtr); } /* - * Pop the root frame pointer and finish deleting the global - * namespace. The order is important [Bug 1658572]. + * Finish deleting the global namespace. */ - - 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. + * 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; + interp->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); + if (iPtr->errorInfo != NULL) { + ckfree(iPtr->errorInfo); + iPtr->errorInfo = NULL; + } + if (iPtr->errorCode != NULL) { + ckfree(iPtr->errorCode); + iPtr->errorCode = NULL; } if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; + iPtr->appendResult = NULL; } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { - Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); + Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr); } if (iPtr->execEnvPtr != NULL) { TclDeleteExecEnv(iPtr->execEnvPtr); @@ -1537,108 +1148,108 @@ DeleteInterpProc( while (resPtr) { nextResPtr = resPtr->nextPtr; ckfree(resPtr->name); - ckfree(resPtr); - resPtr = nextResPtr; + ckfree((char *) resPtr); + resPtr = nextResPtr; } - + /* * Free up literal objects created for scripts compiled by the * interpreter. */ - TclDeleteLiteralTable(interp, &iPtr->literalTable); + TclDeleteLiteralTable(interp, &(iPtr->literalTable)); - /* - * TIP #280 - Release the arrays for ByteCode/Proc extension, and - * contents. +#ifdef TCL_TIP280 + /* TIP #280 - Release the arrays for ByteCode/Proc extension, and contents. */ + { + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + CmdFrame* cfPtr; + ExtCmdLoc* eclPtr; + int i; - for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - CmdFrame *cfPtr = Tcl_GetHashValue(hPtr); - - 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; + for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { - /* - * See also tclCompile.c, TclCleanupByteCode - */ + cfPtr = (CmdFrame*) Tcl_GetHashValue (hPtr); - for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &search); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - ExtCmdLoc *eclPtr = Tcl_GetHashValue(hPtr); + if (cfPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount (cfPtr->data.eval.path); + } + ckfree ((char*) cfPtr->line); + ckfree ((char*) cfPtr); + Tcl_DeleteHashEntry (hPtr); - if (eclPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(eclPtr->path); - } - for (i=0; i< eclPtr->nuloc; i++) { - ckfree(eclPtr->loc[i].line); } + Tcl_DeleteHashTable (iPtr->linePBodyPtr); + ckfree ((char*) iPtr->linePBodyPtr); + iPtr->linePBodyPtr = NULL; - if (eclPtr->loc != NULL) { - ckfree(eclPtr->loc); - } + /* See also tclCompile.c, TclCleanupByteCode */ - Tcl_DeleteHashTable(&eclPtr->litInfo); + for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { - ckfree(eclPtr); - Tcl_DeleteHashEntry(hPtr); - } - Tcl_DeleteHashTable(iPtr->lineBCPtr); - ckfree(iPtr->lineBCPtr); - iPtr->lineBCPtr = NULL; + eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hPtr); - /* - * 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 (eclPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount (eclPtr->path); + } + for (i=0; i< eclPtr->nuloc; i++) { + ckfree ((char*) eclPtr->loc[i].line); + } - 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. - */ + if (eclPtr->loc != NULL) { + ckfree ((char*) eclPtr->loc); + } - Tcl_Panic("Argument location tracking table not empty"); - } + Tcl_DeleteHashTable (&eclPtr->litInfo); - Tcl_DeleteHashTable(iPtr->lineLAPtr); - ckfree((char *) iPtr->lineLAPtr); - iPtr->lineLAPtr = NULL; + ckfree ((char*) eclPtr); + Tcl_DeleteHashEntry (hPtr); + } + Tcl_DeleteHashTable (iPtr->lineBCPtr); + ckfree((char*) iPtr->lineBCPtr); + iPtr->lineBCPtr = 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. + * Location stack for uplevel/eval/... scripts which were passed + * through proc arguments. Actually we track all arguments as we + * don't, cannot know which arguments will be used as scripts and + * which won't. */ - Tcl_Panic("Argument location tracking table not empty"); - } + if (iPtr->lineLAPtr->numEntries) { + /* + * When the interp goes away we have nothing on the stack, so + * there are no arguments, so this table has to be empty. + */ - Tcl_DeleteHashTable(iPtr->lineLABCPtr); - ckfree(iPtr->lineLABCPtr); - iPtr->lineLABCPtr = NULL; + Tcl_Panic ("Argument location tracking table not empty"); + } - /* - * Squelch the tables of traces on variables and searches over arrays in - * the in the interpreter. - */ + Tcl_DeleteHashTable (iPtr->lineLAPtr); + ckfree((char*) iPtr->lineLAPtr); + iPtr->lineLAPtr = NULL; - Tcl_DeleteHashTable(&iPtr->varTraces); - Tcl_DeleteHashTable(&iPtr->varSearches); + if (iPtr->lineLABCPtr->numEntries) { + /* + * When the interp goes away we have nothing on the stack, so + * there are no arguments, so this table has to be empty. + */ - ckfree(iPtr); + Tcl_Panic ("Argument location tracking table not empty"); + } + + Tcl_DeleteHashTable (iPtr->lineLABCPtr); + ckfree((char*) iPtr->lineLABCPtr); + iPtr->lineLABCPtr = NULL; + } +#endif + ckfree((char *) iPtr); } /* @@ -1646,78 +1257,79 @@ DeleteInterpProc( * * Tcl_HideCommand -- * - * Makes a command hidden so that it cannot be invoked from within an - * interpreter, only from within an ancestor. + * 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. + * 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. + * 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. */ +Tcl_HideCommand(interp, cmdName, hiddenCmdToken) + 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; + int new; 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; + /* + * 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). + * 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. + * 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 + * 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 + * 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_AppendResult(interp, - "cannot use namespace qualifiers in hidden command" - " token (rename)", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot use namespace qualifiers in hidden command", + " token (rename)", (char *) 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. + * 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, + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); if (cmd == (Tcl_Command) NULL) { return TCL_ERROR; @@ -1728,21 +1340,22 @@ Tcl_HideCommand( * Check that the command is really in global namespace */ - if (cmdPtr->nsPtr != iPtr->globalNsPtr) { - Tcl_AppendResult(interp, "can only hide global namespace commands" - " (use rename then hide)", NULL); - Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL); - return TCL_ERROR; + if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can only hide global namespace commands", + " (use rename then hide)", (char *) 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); + hiddenCmdTablePtr = (Tcl_HashTable *) + ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } @@ -1751,19 +1364,20 @@ Tcl_HideCommand( * hiddenCmdToken if a hidden command with the name hiddenCmdToken already * exists. */ - - hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew); - if (!isNew) { - Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken, - "\" already exists", NULL); - Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL); - return TCL_ERROR; + + hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new); + if (!new) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "hidden command named \"", hiddenCmdToken, "\" already exists", + (char *) 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. + * 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 untill the common parts are actually + * factorized out. */ /* @@ -1773,34 +1387,26 @@ Tcl_HideCommand( */ if (cmdPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = NULL; + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = (Tcl_HashEntry *) 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. + * Now link the hash table entry with the command structure. + * We ensured above that the nsPtr was right. */ - - 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); + Tcl_SetHashValue(hPtr, (ClientData) 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 the command being hidden has a compile procedure, 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) { @@ -1814,12 +1420,12 @@ Tcl_HideCommand( * * Tcl_ExposeCommand -- * - * Makes a previously hidden command callable from inside the interpreter - * instead of only by its ancestors. + * 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. + * 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. @@ -1828,39 +1434,40 @@ Tcl_HideCommand( */ 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. */ +Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) + 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; + int new; 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; + /* + * 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). + * 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_AppendResult(interp, "cannot expose to a namespace " - "(use expose to toplevel, then rename)", NULL); - Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can not expose to a namespace ", + "(use expose to toplevel, then rename)", + (char *) NULL); + return TCL_ERROR; } /* @@ -1872,104 +1479,82 @@ Tcl_ExposeCommand( if (hiddenCmdTablePtr != NULL) { hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); } - if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken, - "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", - hiddenCmdToken, NULL); - return TCL_ERROR; + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown hidden command \"", hiddenCmdToken, + "\"", (char *) NULL); + return TCL_ERROR; } - cmdPtr = Tcl_GetHashValue(hPtr); + cmdPtr = (Command *) 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). + * 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 ? + if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { + /* + * This case is theoritically impossible, + * we might rather panic() than 'nicely' erroring out ? */ - - Tcl_AppendResult(interp, - "trying to expose a non-global command namespace command", - NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "trying to expose a non global command name space command", + (char *) NULL); + return TCL_ERROR; } - - /* - * This is the global table. - */ - + + /* 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. + * 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_AppendResult(interp, "exposed command \"", cmdName, - "\" already exists", NULL); - Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL); - return TCL_ERROR; + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new); + if (!new) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "exposed command \"", cmdName, + "\" already exists", (char *) 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; + 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. + * 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); + Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); /* - * Not needed as we are only in the global namespace (but would be needed - * again if we supported namespace command hiding) + * 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 + * If the command being exposed has a compile procedure, 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. */ @@ -1987,125 +1572,104 @@ Tcl_ExposeCommand( * 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. + * 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. + * (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 +Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) + 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. */ + * specified namespace; otherwise it is put + * in the global namespace. */ + Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */ + ClientData clientData; /* Arbitrary value passed to string proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* If not NULL, gives a procedure 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; + CONST char *tail; + int new; 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. + * 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. + * 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)) { + TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, + 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) { + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { /* - * 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. + * 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 = (Command *) Tcl_GetHashValue(hPtr); oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - if (!isNew) { + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { /* - * 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). + * 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)); + ckfree((char*) 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)); + cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; - cmdPtr->compileProc = NULL; + cmdPtr->compileProc = (CompileProc *) NULL; cmdPtr->objProc = TclInvokeStringCommand; - cmdPtr->objClientData = cmdPtr; + cmdPtr->objClientData = (ClientData) cmdPtr; cmdPtr->proc = proc; cmdPtr->clientData = clientData; cmdPtr->deleteProc = deleteProc; @@ -2113,18 +1677,17 @@ Tcl_CreateCommand( cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = NULL; /* - * Plug in any existing import references found above. Be sure to update - * all of these references to point to the new command. + * 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 = (ImportedCmdData*)refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } @@ -2136,7 +1699,7 @@ Tcl_CreateCommand( * shadowed commands are found, invalidate all cached command references * in the affected namespaces. */ - + TclResetShadowedCmdRefs(interp, cmdPtr); return (Tcl_Command) cmdPtr; } @@ -2149,70 +1712,70 @@ Tcl_CreateCommand( * 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. + * 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. + * 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. + * 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 +Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) + 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 + * specified namespace; otherwise it is put + * in the global namespace. */ + Tcl_ObjCmdProc *proc; /* Object-based procedure 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. */ + ClientData clientData; /* Arbitrary value to pass to object + * procedure. */ + Tcl_CmdDeleteProc *deleteProc; + /* If not NULL, gives a procedure 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; + CONST char *tail; + int new; 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. + * 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. + * 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)) { + TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, + CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { @@ -2220,107 +1783,85 @@ Tcl_CreateObjCommand( tail = cmdName; } - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - TclInvalidateNsPath(nsPtr); - if (!isNew) { - cmdPtr = Tcl_GetHashValue(hPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); /* * Command already exists. If its object-based Tcl_ObjCmdProc is * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the - * argument "proc". Otherwise, we delete the old command. + * argument "proc". Otherwise, we delete the old command. */ if (cmdPtr->objProc == TclInvokeStringCommand) { cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; - cmdPtr->deleteProc = deleteProc; - cmdPtr->deleteData = clientData; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = 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. + * 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. */ oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - if (!isNew) { + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { /* - * 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). + * 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)); + ckfree((char *) 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)); + cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; - cmdPtr->compileProc = NULL; + cmdPtr->compileProc = (CompileProc *) NULL; cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; cmdPtr->proc = TclInvokeObjectCommand; - cmdPtr->clientData = cmdPtr; + cmdPtr->clientData = (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. + * 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 = (ImportedCmdData*)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; } @@ -2331,10 +1872,10 @@ Tcl_CreateObjCommand( * 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. + * Tcl_CmdProc if no object-based procedure exists for a command. A + * pointer to this procedure 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. @@ -2347,18 +1888,37 @@ Tcl_CreateObjCommand( */ 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 *)); +TclInvokeStringCommand(clientData, interp, objc, objv) + 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. */ +{ + register Command *cmdPtr = (Command *) clientData; + register int i; + int result; - for (i = 0; i < objc; i++) { + /* + * This procedure generates an argv array for the string arguments. It + * starts out with stack-allocated space but uses dynamically-allocated + * storage if needed. + */ + +#define NUM_ARGS 20 + CONST char *(argStorage[NUM_ARGS]); + CONST char **argv = argStorage; + + /* + * Create the string argument array "argv". Make sure argv is large + * enough to hold the objc arguments plus 1 extra for the zero + * end-of-argv word. + */ + + if ((objc + 1) > NUM_ARGS) { + argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); + } + + for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; @@ -2367,10 +1927,17 @@ TclInvokeStringCommand( * Invoke the command's string-based Tcl_CmdProc. */ - result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv); + result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); - TclStackFree(interp, (void *) argv); + /* + * Free the argv array if malloc'ed storage was used. + */ + + if (argv != argStorage) { + ckfree((char *) argv); + } return result; +#undef NUM_ARGS } /* @@ -2379,10 +1946,10 @@ TclInvokeStringCommand( * 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. + * Tcl_ObjCmdProc if no string-based procedure exists for a command. + * A pointer to this procedure 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. @@ -2395,21 +1962,42 @@ TclInvokeStringCommand( */ 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. */ +TclInvokeObjectCommand(clientData, interp, argc, argv) + 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 *))); + Command *cmdPtr = (Command *) clientData; + register Tcl_Obj *objPtr; + register int i; + int length, result; + + /* + * This procedure generates an objv array for object arguments that hold + * the argv strings. It starts out with stack-allocated space but uses + * dynamically-allocated storage if needed. + */ + +#define NUM_ARGS 20 + Tcl_Obj *(argStorage[NUM_ARGS]); + register Tcl_Obj **objv = argStorage; + + /* + * Create the object argument array "objv". Make sure objv is large + * enough to hold the objc arguments plus 1 extra for the zero + * end-of-objv word. + */ - for (i = 0; i < argc; i++) { + if (argc > NUM_ARGS) { + objv = (Tcl_Obj **) + ckalloc((unsigned)(argc * sizeof(Tcl_Obj *))); + } + + for (i = 0; i < argc; i++) { length = strlen(argv[i]); - TclNewStringObj(objPtr, argv[i], length); + TclNewObj(objPtr); + TclInitStringRep(objPtr, argv[i], length); Tcl_IncrRefCount(objPtr); objv[i] = objPtr; } @@ -2418,31 +2006,30 @@ TclInvokeObjectCommand( * 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); - } + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); /* - * Move the interpreter's object result to the string result, then reset - * the object result. + * Move the interpreter's object result to the string result, + * then reset the object result. */ - (void) Tcl_GetStringResult(interp); - + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); + /* - * Decrement the ref counts for the argument objects created above, then - * free the objv array if malloc'ed storage was used. + * 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++) { + for (i = 0; i < argc; i++) { objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } - TclStackFree(interp, objv); + if (objv != argStorage) { + ckfree((char *) objv); + } return result; +#undef NUM_ARGS } /* @@ -2450,65 +2037,65 @@ TclInvokeObjectCommand( * * 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. + * 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. + * 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. + * 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. + * 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. */ +TclRenameCommand(interp, oldName, newName) + Tcl_Interp *interp; /* Current interpreter. */ + char *oldName; /* Existing command name. */ + char *newName; /* New command name. */ { Interp *iPtr = (Interp *) interp; - const char *newTail; + CONST char *newTail; Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; Tcl_Command cmd; Command *cmdPtr; Tcl_HashEntry *hPtr, *oldHPtr; - int isNew, result; - Tcl_Obj *oldFullName; + int new, result; + Tcl_Obj* oldFullName; Tcl_DString newFullName; /* - * Find the existing command. An error is returned if cmdName can't be - * found. + * Find the existing command. An error is returned if cmdName can't + * be found. */ - cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0); + cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL, + /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "can't ", - ((newName == NULL)||(*newName == '\0'))? "delete":"rename", - " \"", oldName, "\": command doesn't exist", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ", + ((newName == NULL)||(*newName == '\0'))? "delete":"rename", + " \"", oldName, "\": command doesn't exist", (char *) NULL); return TCL_ERROR; } cmdNsPtr = cmdPtr->nsPtr; oldFullName = Tcl_NewObj(); - Tcl_IncrRefCount(oldFullName); - Tcl_GetCommandFullName(interp, cmd, oldFullName); + 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; @@ -2516,120 +2103,101 @@ TclRenameCommand( } /* - * 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. + * 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); + TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, + CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); if ((newNsPtr == NULL) || (newTail == NULL)) { - Tcl_AppendResult(interp, "can't rename to \"", newName, - "\": bad command name", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't rename to \"", newName, "\": bad command name", + (char *) NULL); result = TCL_ERROR; goto done; } if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { - Tcl_AppendResult(interp, "can't rename to \"", newName, - "\": command already exists", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME", - "TARGET_EXISTS", NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't rename to \"", newName, + "\": command already exists", (char *) 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 + * 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. + * 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); + hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new); + Tcl_SetHashValue(hPtr, (ClientData) 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. + * 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; + 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. + * 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! + * The trace procedure needs to get a fully qualified name for + * old and new commands [Tcl bug #651271], or else there's no way + * for the trace procedure 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) { - Tcl_DStringAppend(&newFullName, "::", 2); + Tcl_DStringInit( &newFullName ); + Tcl_DStringAppend( &newFullName, newNsPtr->fullName, -1 ); + if ( newNsPtr != iPtr->globalNsPtr ) { + Tcl_DStringAppend( &newFullName, "::", 2 ); } - Tcl_DStringAppend(&newFullName, newTail, -1); + Tcl_DStringAppend( &newFullName, newTail, -1 ); cmdPtr->refCount++; - CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), - Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); - Tcl_DStringFree(&newFullName); + CallCommandTraces( iPtr, cmdPtr, + Tcl_GetString( 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. + * 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 the command being renamed has a compile procedure, 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) { @@ -2637,15 +2205,14 @@ TclRenameCommand( } /* - * Now free the Command structure, if the "oldName" command has been - * deleted by invocation of rename traces. + * Now free the Command structure, if the "oldName" command has + * been deleted by invocation of rename traces. */ - - TclCleanupCommandMacro(cmdPtr); + TclCleanupCommand(cmdPtr); result = TCL_OK; - done: - TclDecrRefCount(oldFullName); + done: + TclDecrRefCount( oldFullName ); return result; } @@ -2654,15 +2221,16 @@ TclRenameCommand( * * 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. + * Modifies various information about a Tcl command. Note that + * this procedure will not change a command's namespace; use + * Tcl_RenameCommand 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. + * 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. @@ -2671,17 +2239,20 @@ TclRenameCommand( */ 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_SetCommandInfo(interp, cmdName, infoPtr) + 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); + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, + /*flags*/ 0); + + return Tcl_SetCommandInfoFromToken( cmd, infoPtr ); + } /* @@ -2689,15 +2260,16 @@ Tcl_SetCommandInfo( * * 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. + * Modifies various information about a Tcl command. Note that + * this procedure will not change a command's namespace; use + * Tcl_RenameCommand 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. + * 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. @@ -2706,32 +2278,28 @@ Tcl_SetCommandInfo( */ int -Tcl_SetCommandInfoFromToken( - Tcl_Command cmd, - const Tcl_CmdInfo *infoPtr) +Tcl_SetCommandInfoFromToken( cmd, infoPtr ) + Tcl_Command cmd; + CONST Tcl_CmdInfo* infoPtr; { - Command *cmdPtr; /* Internal representation of the command */ + Command* cmdPtr; /* Internal representation of the command */ - if (cmd == NULL) { + if (cmd == (Tcl_Command) 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) { + if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { cmdPtr->objProc = TclInvokeStringCommand; - cmdPtr->objClientData = cmdPtr; - cmdPtr->nreProc = NULL; + cmdPtr->objClientData = (ClientData) cmdPtr; } else { - if (infoPtr->objProc != cmdPtr->objProc) { - cmdPtr->nreProc = NULL; - cmdPtr->objProc = infoPtr->objProc; - } + cmdPtr->objProc = infoPtr->objProc; cmdPtr->objClientData = infoPtr->objClientData; } cmdPtr->deleteProc = infoPtr->deleteProc; @@ -2747,9 +2315,10 @@ Tcl_SetCommandInfoFromToken( * 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. + * 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. @@ -2758,17 +2327,20 @@ Tcl_SetCommandInfoFromToken( */ 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_GetCommandInfo(interp, cmdName, infoPtr) + 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); + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, + /*flags*/ 0); + + return Tcl_GetCommandInfoFromToken( cmd, infoPtr ); + } /* @@ -2779,9 +2351,9 @@ Tcl_GetCommandInfo( * 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. + * 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. @@ -2790,13 +2362,14 @@ Tcl_GetCommandInfo( */ int -Tcl_GetCommandInfoFromToken( - Tcl_Command cmd, - Tcl_CmdInfo *infoPtr) +Tcl_GetCommandInfoFromToken( cmd, infoPtr ) + Tcl_Command cmd; + Tcl_CmdInfo* infoPtr; { - Command *cmdPtr; /* Internal representation of the command */ - if (cmd == NULL) { + Command* cmdPtr; /* Internal representation of the command */ + + if ( cmd == (Tcl_Command) NULL ) { return 0; } @@ -2817,6 +2390,7 @@ Tcl_GetCommandInfoFromToken( infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; return 1; + } /* @@ -2824,8 +2398,9 @@ Tcl_GetCommandInfoFromToken( * * 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). + * Given a token returned by Tcl_CreateCommand, this procedure + * 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. @@ -2836,25 +2411,25 @@ Tcl_GetCommandInfoFromToken( *---------------------------------------------------------------------- */ -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. */ +CONST char * +Tcl_GetCommandName(interp, command) + 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. + * 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); } @@ -2863,28 +2438,28 @@ Tcl_GetCommandName( * * 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. + * Given a token returned by, e.g., Tcl_CreateCommand or + * Tcl_FindCommand, this procedure 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. + * 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 +Tcl_GetCommandFullName(interp, command, objPtr) + 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. */ { @@ -2907,7 +2482,7 @@ Tcl_GetCommandFullName( if (cmdPtr->hPtr != NULL) { name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); Tcl_AppendToObj(objPtr, name, -1); - } + } } } @@ -2919,29 +2494,31 @@ Tcl_GetCommandFullName( * 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. + * 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. + * 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_DeleteCommand(interp, cmdName) + 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. + * Find the desired command and delete it. */ - cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); - if (cmd == NULL) { + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, + /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { return -1; } return Tcl_DeleteCommandFromToken(interp, cmd); @@ -2952,26 +2529,26 @@ Tcl_DeleteCommand( * * 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. + * Removes the given command from the given interpreter. This procedure + * 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. + * 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". + * 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. */ +Tcl_DeleteCommandFromToken(interp, cmd) + 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; @@ -2979,91 +2556,73 @@ Tcl_DeleteCommandFromToken( Tcl_Command importCmd; /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. - */ - - cmdPtr->cmdEpoch++; - - /* - * The code here is tricky. We can't delete the hash table entry before - * invoking the deletion callback because there are cases where the - * deletion callback needs to invoke the command (e.g. object systems such - * 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. + * 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] + * Another deletion is already in progress. Remove the hash + * table entry now, but don't invoke a callback or free the + * command structure. */ - if (cmdPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = NULL; - } + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; 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. + /* + * 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. + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + + /* + * Call trace procedures 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. - */ - + /* Now delete these traces */ tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; - if ((--tracePtr->refCount) <= 0) { - ckfree(tracePtr); + ckfree((char*)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 the command being deleted has a compile procedure, 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++; + iPtr->compileEpoch++; } if (cmdPtr->deleteProc != NULL) { @@ -3072,17 +2631,19 @@ Tcl_DeleteCommandFromToken( * created when a command was imported into a namespace, this client * data will be a pointer to a ImportedCmdData structure describing * the "real" command that this imported command refers to. - * + */ + + /* * If you are getting a crash during the call to deleteProc and - * cmdPtr->deleteProc is a pointer to the function free(), the most - * likely cause is that your extension allocated memory for the - * clientData argument to Tcl_CreateObjCommand with the ckalloc() - * 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 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); + (*cmdPtr->deleteProc)(cmdPtr->deleteData); } /* @@ -3091,94 +2652,79 @@ Tcl_DeleteCommandFromToken( * imported commands now. */ - for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; - refPtr = nextRefPtr) { + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; + refPtr = nextRefPtr) { nextRefPtr = refPtr->nextPtr; importCmd = (Tcl_Command) refPtr->importedCmdPtr; - Tcl_DeleteCommandFromToken(interp, importCmd); + 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. + * 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; } /* - * 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. + * Mark the Command structure as no longer valid. This allows + * TclExecuteByteCode to recognize when a Command has logically been + * deleted and a pointer to this Command structure cached in a CmdName + * object is invalid. TclExecuteByteCode will look up the command again + * in the interpreter's command hashtable. */ 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). + * 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 + * TclExecuteByteCode looks up the command in the command hashtable). */ - - TclCleanupCommandMacro(cmdPtr); + + TclCleanupCommand(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. */ +CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) + 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; + int mask = (TCL_TRACE_DELETE | TCL_TRACE_RENAME); /* Safety */ + + flags &= mask; 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. + /* + * 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; } @@ -3188,7 +2734,7 @@ CallCommandTraces( } cmdPtr->flags |= CMD_TRACE_ACTIVE; cmdPtr->refCount++; - + result = NULL; active.nextPtr = iPtr->activeCmdTracePtr; active.reverseScan = 0; @@ -3198,41 +2744,37 @@ CallCommandTraces( flags |= TCL_TRACE_DESTROYED; } active.cmdPtr = cmdPtr; - - Tcl_Preserve(iPtr); - + + Tcl_Preserve((ClientData) iPtr); + for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { + tracePtr = active.nextTracePtr) { + int traceFlags = (tracePtr->flags & mask); + active.nextTracePtr = tracePtr->nextPtr; - if (!(tracePtr->flags & flags)) { + if (!(traceFlags & flags)) { continue; } - cmdPtr->flags |= tracePtr->flags; + cmdPtr->flags |= traceFlags; if (oldName == NULL) { TclNewObj(oldNamePtr); Tcl_IncrRefCount(oldNamePtr); - Tcl_GetCommandFullName((Tcl_Interp *) iPtr, - (Tcl_Command) cmdPtr, 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; + (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, oldName, newName, flags); + cmdPtr->flags &= ~traceFlags; if ((--tracePtr->refCount) <= 0) { - ckfree(tracePtr); + ckfree((char*)tracePtr); } } - if (state) { - Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state); - } - /* - * If a new object was created to hold the full oldName, free it now. + * If a new object was created to hold the full oldName, + * free it now. */ if (oldNamePtr != NULL) { @@ -3240,163 +2782,26 @@ CallCommandTraces( } /* - * Restore the variable's flags, remove the record of our active traces, - * and then return. + * 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); + Tcl_Release((ClientData) 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; -} - -/* - *---------------------------------------------------------------------- - * - * GetCommandSource -- - * - * This function returns a Tcl_Obj with the full source string for the - * command. This insures that traces get a correct NUL-terminated command - * string. The Tcl_Obj has refCount==1. - * - * *** MAINTAINER WARNING *** - * The returned Tcl_Obj is all wrong for any purpose but getting the - * source string for an objc/objv command line in the stringRep (no - * stringRep if no source is available) and the corresponding substituted - * version in the List intrep. - * This means that the intRep and stringRep DO NOT COINCIDE! Using these - * Tcl_Objs normally is likely to break things. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -GetCommandSource( - Interp *iPtr, - int objc, - Tcl_Obj *const objv[], - int lookup) -{ - Tcl_Obj *objPtr, *obj2Ptr; - CmdFrame *cfPtr = iPtr->cmdFramePtr; - const char *command = NULL; - int numChars; - - objPtr = Tcl_NewListObj(objc, objv); - if (lookup && cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) { - switch (cfPtr->type) { - case TCL_LOCATION_EVAL: - case TCL_LOCATION_SOURCE: - command = cfPtr->cmd.str.cmd; - numChars = cfPtr->cmd.str.len; - break; - case TCL_LOCATION_BC: - case TCL_LOCATION_PREBC: - command = TclGetSrcInfoForCmd(iPtr, &numChars); - break; - case TCL_LOCATION_EVAL_LIST: - /* Got it already */ - break; - } - if (command) { - obj2Ptr = Tcl_NewStringObj(command, numChars); - objPtr->bytes = obj2Ptr->bytes; - objPtr->length = numChars; - obj2Ptr->bytes = NULL; - Tcl_DecrRefCount(obj2Ptr); - } - } - Tcl_IncrRefCount(objPtr); - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * * TclCleanupCommand -- * - * This function frees up a Command structure unless it is still + * This procedure 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. + * instruction sequence. * * Results: * None. @@ -3410,13 +2815,13 @@ GetCommandSource( */ void -TclCleanupCommand( - register Command *cmdPtr) /* Points to the Command structure to +TclCleanupCommand(cmdPtr) + register Command *cmdPtr; /* Points to the Command structure to * be freed. */ { cmdPtr->refCount--; if (cmdPtr->refCount <= 0) { - ckfree(cmdPtr); + ckfree((char *) cmdPtr); } } @@ -3425,17 +2830,18 @@ TclCleanupCommand( * * Tcl_CreateMathFunc -- * - * Creates a new math function for expressions in a given interpreter. + * 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, + * The 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. * @@ -3443,203 +2849,65 @@ TclCleanupCommand( */ 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); - Tcl_DStringAppend(&bigName, "::tcl::mathfunc::", -1); - 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_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) + 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; /* Procedure that implements the + * math function. */ + ClientData clientData; /* Additional value to pass to the + * function. */ { - Tcl_Obj *valuePtr; - OldMathFuncData *dataPtr = clientData; - Tcl_Value funcResult, *args; - int result; - int j, k; - double d; - - /* - * Check argument count. - */ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; + int new, i; - if (objc != dataPtr->numArgs + 1) { - MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv); - return TCL_ERROR; + hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); + if (new) { + Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - /* - * 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) { + if (!new) { + if (mathFuncPtr->builtinFuncIndex >= 0) { /* - * We have a non-numeric argument. + * We are redefining a builtin math function. Invalidate the + * interpreter's existing code by incrementing its + * compileEpoch member. This field is checked in Tcl_EvalObj + * and ObjInterpProc, and code whose compilation epoch doesn't + * match is recompiled. Newly compiled code will no longer + * treat the function as builtin. */ - Tcl_SetResult(interp, - "argument to math function didn't have numeric value", - TCL_STATIC); - TclCheckBadOctal(interp, Tcl_GetString(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. - */ + iPtr->compileEpoch++; + } else { + /* + * A non-builtin function is being redefined. We must invalidate + * existing code if the number of arguments has changed. This + * is because existing code was compiled assuming that number. + */ - 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 (Tcl_GetWideIntFromObj(interp, valuePtr, &args[k].wideValue) - == TCL_OK) { - args[k].type = TCL_WIDE_INT; - break; + if (numArgs != mathFuncPtr->numArgs) { + iPtr->compileEpoch++; } - 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); - Tcl_GetWideIntFromObj(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; + + mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ + if (numArgs > MAX_MATH_ARGS) { + numArgs = MAX_MATH_ARGS; } - - /* - * 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); + mathFuncPtr->numArgs = numArgs; + for (i = 0; i < numArgs; i++) { + mathFuncPtr->argTypes[i] = argTypes[i]; } - 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); + mathFuncPtr->proc = proc; + mathFuncPtr->clientData = clientData; } /* @@ -3651,77 +2919,64 @@ OldMathFuncDeleteProc( * interpreter. * * Results: - * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the - * interpreter result if that happens.) + * 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.) + * 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_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, + clientDataPtr) + 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. - */ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; + Tcl_ValueType *argTypes; + int i,numArgs; - 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; + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "math function \"", name, "\" not known in this interpreter", + (char *) NULL); return TCL_ERROR; } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - /* - * Retrieve function info for user defined functions; return dummy - * information for builtins. - */ - - if (cmdPtr->objProc == &OldMathFuncProc) { - OldMathFuncData *dataPtr = cmdPtr->clientData; + *numArgsPtr = numArgs = mathFuncPtr->numArgs; + if (numArgs == 0) { + /* Avoid doing zero-sized allocs... */ + numArgs = 1; + } + *argTypesPtr = argTypes = + (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); + for (i = 0; i < mathFuncPtr->numArgs; i++) { + argTypes[i] = mathFuncPtr->argTypes[i]; + } - *procPtr = dataPtr->proc; - *numArgsPtr = dataPtr->numArgs; - *argTypesPtr = dataPtr->argTypes; - *clientDataPtr = dataPtr->clientData; + if (mathFuncPtr->builtinFuncIndex == -1) { + *procPtr = (Tcl_MathProc *) NULL; } else { - *procPtr = NULL; - *numArgsPtr = -1; - *argTypesPtr = NULL; - *procPtr = NULL; - *clientDataPtr = NULL; + *procPtr = mathFuncPtr->proc; + *clientDataPtr = mathFuncPtr->clientData; } + return TCL_OK; } @@ -3734,9 +2989,9 @@ Tcl_GetMathFuncInfo( * 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.) + * 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. @@ -3745,46 +3000,28 @@ Tcl_GetMathFuncInfo( */ Tcl_Obj * -Tcl_ListMathFuncs( - Tcl_Interp *interp, - const char *pattern) +Tcl_ListMathFuncs(interp, pattern) + Tcl_Interp *interp; + CONST char *pattern; { - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - Namespace *nsPtr; - Namespace *dummy1NsPtr; - Namespace *dummy2NsPtr; - const char *dummyNamePtr; - Tcl_Obj *result = Tcl_NewObj(); - - TclGetNamespaceForQualName(interp, "::tcl::mathfunc", - globalNsPtr, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY, - &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &dummyNamePtr); - if (nsPtr == NULL) { - return result; - } - - if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - if (Tcl_FindHashEntry(&nsPtr->cmdTable, pattern) != NULL) { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(pattern, -1)); - } - } else { - Tcl_HashSearch cmdHashSearch; - Tcl_HashEntry *cmdHashEntry = - Tcl_FirstHashEntry(&nsPtr->cmdTable,&cmdHashSearch); - - for (; cmdHashEntry != NULL; - cmdHashEntry = Tcl_NextHashEntry(&cmdHashSearch)) { - const char *cmdNamePtr = - Tcl_GetHashKey(&nsPtr->cmdTable, cmdHashEntry); - - if (pattern == NULL || Tcl_StringMatch(cmdNamePtr, pattern)) { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(cmdNamePtr, -1)); - } + Interp *iPtr = (Interp *) interp; + Tcl_Obj *resultList = Tcl_NewObj(); + register Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + CONST char *name; + + for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { + name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr); + if ((pattern == NULL || Tcl_StringMatch(name, pattern)) && + /* I don't expect this to fail, but... */ + Tcl_ListObjAppendElement(interp, resultList, + Tcl_NewStringObj(name,-1)) != TCL_OK) { + Tcl_DecrRefCount(resultList); + return NULL; } } - return result; + return resultList; } /* @@ -3792,12 +3029,13 @@ Tcl_ListMathFuncs( * * 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. + * 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. + * 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. @@ -3805,15 +3043,15 @@ Tcl_ListMathFuncs( *---------------------------------------------------------------------- */ -int -TclInterpReady( - Tcl_Interp *interp) +int +TclInterpReady(interp) + Tcl_Interp *interp; { register Interp *iPtr = (Interp *) interp; /* - * Reset both the interpreter's string and object results and clear out - * any previous error information. + * Reset both the interpreter's string and object results and clear + * out any previous error information. */ Tcl_ResetResult(interp); @@ -3821,1013 +3059,790 @@ TclInterpReady( /* * If the interpreter has been deleted, return an error. */ - + if (iPtr->flags & DELETED) { - /* JJM - Superfluous Tcl_ResetResult call removed. */ - Tcl_AppendResult(interp, - "attempt to call eval in deleted interpreter", NULL); - Tcl_SetErrorCode(interp, "TCL", "IDELETE", - "attempt to call eval in deleted interpreter", NULL); - return TCL_ERROR; - } - - if (iPtr->execEnvPtr->rewind) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "attempt to call eval in deleted interpreter", -1); + Tcl_SetErrorCode(interp, "CORE", "IDELETE", + "attempt to call eval in deleted interpreter", + (char *) NULL); return TCL_ERROR; } /* - * Make sure the script being evaluated (if any) has not been canceled. + * Check depth of nested calls to Tcl_Eval: if this gets too large, + * it's probably because of an infinite loop somewhere. */ - if (TclCanceled(iPtr) && - (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) { + if (((iPtr->numLevels) > iPtr->maxNestingDepth) + || (TclpCheckStackSpace() == 0)) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many nested evaluations (infinite loop?)", -1); 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_AppendResult(interp, - "too many nested evaluations (infinite loop?)", NULL); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL); - return TCL_ERROR; + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclResetCancellation -- + * TclEvalObjvInternal -- * - * Reset the script cancellation flags if the nesting level - * (iPtr->numLevels) for the interp is zero or argument force is - * non-zero. + * This procedure evaluates a Tcl command that has already been + * parsed into words, with one Tcl_Obj holding each word. The caller + * is responsible for managing the iPtr->numLevels. * * Results: - * A standard Tcl result. + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR. A result or error message is left in + * interp's result. If an error occurs, this procedure does + * NOT add any information to the errorInfo variable. * * Side effects: - * The script cancellation flags for the interp may be reset. + * Depends on the command. * *---------------------------------------------------------------------- */ int -TclResetCancellation( - Tcl_Interp *interp, - int force) +TclEvalObjvInternal(interp, objc, objv, command, length, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * command. Also used for error + * reporting. */ + int objc; /* Number of words in command. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are + * the words that make up the command. */ + CONST char *command; /* Points to the beginning of the string + * representation of the command; this + * is used for traces. If the string + * representation of the command is + * unknown, an empty string should be + * supplied. If it is NULL, no traces will + * be called. */ + int length; /* Number of bytes in command; if -1, all + * characters up to the first null byte are + * used. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are + * currently supported. */ + { - register Interp *iPtr = (Interp *) interp; + Command *cmdPtr; + Interp *iPtr = (Interp *) interp; + Tcl_Obj **newObjv; + int i; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ + int code = TCL_OK; + int traceCode = TCL_OK; + int checkTraces = 1; + Namespace *savedNsPtr = NULL; - if (iPtr == NULL) { + if (TclInterpReady(interp) == TCL_ERROR) { return TCL_ERROR; } - if (force || (iPtr->numLevels == 0)) { - TclUnsetCancelFlags(iPtr); + if (objc == 0) { + return TCL_OK; } - 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 any execution traces rename or delete the current command, + * we may need (at most) two passes here. */ - if (!TclCanceled(iPtr)) { - return TCL_OK; + savedVarFramePtr = iPtr->varFramePtr; + while (1) { + + /* Configure evaluation context to match the requested flags */ + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; + } else if ((flags & TCL_EVAL_INVOKE) && iPtr->varFramePtr) { + savedNsPtr = iPtr->varFramePtr->nsPtr; + iPtr->varFramePtr->nsPtr = iPtr->globalNsPtr; + } + + /* + * Find the procedure to execute this command. If there isn't one, + * then see if there is a command "unknown". If so, create a new + * word array with "unknown" as the first word and the original + * command words as arguments. Then call ourselves recursively + * to execute it. + */ + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + if (cmdPtr == NULL) { + newObjv = (Tcl_Obj **) ckalloc((unsigned) + ((objc + 1) * sizeof (Tcl_Obj *))); + for (i = objc-1; i >= 0; i--) { + newObjv[i+1] = objv[i]; + } + newObjv[0] = Tcl_NewStringObj("::unknown", -1); + Tcl_IncrRefCount(newObjv[0]); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); + if (cmdPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", Tcl_GetString(objv[0]), "\"", + (char *) NULL); + code = TCL_ERROR; + } else { + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objc+1, newObjv, + command, length, 0); + iPtr->numLevels--; + } + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *) newObjv); + if (savedNsPtr) { + iPtr->varFramePtr->nsPtr = savedNsPtr; + } + goto done; + } + if (savedNsPtr) { + iPtr->varFramePtr->nsPtr = savedNsPtr; + } + + /* + * Call trace procedures if needed. + */ + if ((checkTraces) && (command != NULL)) { + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + + cmdPtr->refCount++; + /* + * If the first set of traces modifies/deletes the command or + * any existing traces, then the set checkTraces to 0 and + * go through this while loop one more time. + */ + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) + && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + TclCleanupCommand(cmdPtr); + if (cmdEpoch != newEpoch) { + /* The command has been modified in some way */ + checkTraces = 0; + continue; + } + } + break; } - /* - * 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. - */ +#ifdef USE_DTRACE + if (TCL_DTRACE_CMD_ARGS_ENABLED()) { + char *a[10]; + int i = 0; - iPtr->flags &= ~CANCELED; + 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]); + } +#endif /* USE_DTRACE */ /* - * 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. + * Finally, invoke the command's Tcl_ObjCmdProc. */ - - if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) { - return TCL_OK; + cmdPtr->refCount++; + iPtr->cmdCount++; + if ( code == TCL_OK && traceCode == TCL_OK) { + if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { + TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, + (Tcl_Obj **)(objv + 1)); + } + code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + if (TCL_DTRACE_CMD_RETURN_ENABLED()) { + TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code); + } + } + if (Tcl_AsyncReady()) { + code = Tcl_AsyncInvoke(interp, code); } /* - * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the - * interp's result; otherwise, we leave it alone. + * Call 'leave' command traces */ - - if (flags & TCL_LEAVE_ERR_MSG) { - const char *id, *message = NULL; - int length; - - /* - * Setup errorCode variables so that we can differentiate between - * being canceled and unwound. - */ - - if (iPtr->asyncCancelMsg != NULL) { - message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); - } else { - length = 0; + if (!(cmdPtr->flags & CMD_IS_DELETED)) { + int saveErrFlags = iPtr->flags + & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET); + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces (interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); } - - if (iPtr->flags & TCL_CANCEL_UNWIND) { - id = "IUNWIND"; - if (length == 0) { - message = "eval unwound"; - } - } else { - id = "ICANCEL"; - if (length == 0) { - message = "eval canceled"; - } + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); } - - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, message, NULL); - Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL); + if (traceCode == TCL_OK) { + iPtr->flags |= saveErrFlags; + } } + TclCleanupCommand(cmdPtr); + + /* + * If one of the trace invocation resulted in error, then + * change the result code accordingly. Note, that the + * interp->result should already be set correctly by the + * call to TraceExecutionProc. + */ + if (traceCode != TCL_OK) { + code = traceCode; + } + /* - * Return TCL_ERROR to the caller (not necessarily just the Tcl core - * itself) that indicates further processing of the script or command in - * progress should halt gracefully and as soon as possible. + * If the interpreter has a non-empty string result, the result + * object is either empty or stale because some procedure set + * interp->result directly. If so, move the string result to the + * result object, then reset the string result. */ + + if (*(iPtr->result) != 0) { + (void) Tcl_GetObjResult(interp); + } + +#ifdef USE_DTRACE + if (TCL_DTRACE_CMD_RESULT_ENABLED()) { + Tcl_Obj *r; + + r = Tcl_GetObjResult(interp); + TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r), r); + } +#endif /* USE_DTRACE */ - return TCL_ERROR; + done: + iPtr->varFramePtr = savedVarFramePtr; + return code; } /* *---------------------------------------------------------------------- * - * Tcl_CancelEval -- + * Tcl_EvalObjv -- * - * This function schedules the cancellation of the current script in the - * given interpreter. + * This procedure 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. Since the interp may belong to a different thread, no error - * message can be left in the interp's result. + * 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: - * 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. + * Depends on the command. * *---------------------------------------------------------------------- */ 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; +Tcl_EvalObjv(interp, objc, objv, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * command. Also used for error + * reporting. */ + int objc; /* Number of words in command. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are + * the words that make up the command. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE + * are currently supported. */ +{ + Interp *iPtr = (Interp *)interp; + Trace *tracePtr; + Tcl_DString cmdBuf; + char *cmdString = ""; /* A command string is only necessary for + * command traces or error logs; it will be + * generated to replace this default value if + * necessary. */ + int cmdLen = 0; /* a non-zero value indicates that a command + * string was generated. */ + int code = TCL_OK; + int i; + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - if (interp == NULL) { - return TCL_ERROR; + for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { + if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) { + /* + * The command may be needed for an execution trace. Generate a + * command string. + */ + + Tcl_DStringInit(&cmdBuf); + for (i = 0; i < objc; i++) { + Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); + } + cmdString = Tcl_DStringValue(&cmdBuf); + cmdLen = Tcl_DStringLength(&cmdBuf); + break; + } } - Tcl_MutexLock(&cancelLock); - if (cancelTableInitialized != 1) { - /* - * No CancelInfo hash table (Tcl_CreateInterp has never been called?) - */ + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags); + iPtr->numLevels--; - goto done; + /* + * If we are again at the top level, process any unusual + * return code returned by the evaluated code. + */ + + 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; + } } - hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp); - if (hPtr == NULL) { - /* - * No CancelInfo record for this interpreter. + + if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { + + /* + * If there was an error, a command string will be needed for the + * error log: generate it now if it was not done previously. */ - goto done; + if (cmdLen == 0) { + Tcl_DStringInit(&cmdBuf); + for (i = 0; i < objc; i++) { + Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); + } + cmdString = Tcl_DStringValue(&cmdBuf); + cmdLen = Tcl_DStringLength(&cmdBuf); + } + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); } - cancelInfo = Tcl_GetHashValue(hPtr); - /* - * Populate information needed by the interpreter thread to fulfill the - * cancellation request. Currently, clientData is ignored. If the - * TCL_CANCEL_UNWIND flags bit is set, the script in progress is not - * allowed to catch the script cancellation because the evaluation stack - * for the interp is completely unwound. - */ - - if (resultObjPtr != NULL) { - result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); - cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length); - memcpy(cancelInfo->result, result, (size_t) cancelInfo->length); - TclDecrRefCount(resultObjPtr); /* Discard their result object. */ - } else { - cancelInfo->result = NULL; - cancelInfo->length = 0; + if (cmdLen != 0) { + Tcl_DStringFree(&cmdBuf); } - cancelInfo->clientData = clientData; - cancelInfo->flags = flags; - Tcl_AsyncMark(cancelInfo->async); - code = TCL_OK; - - done: - Tcl_MutexUnlock(&cancelLock); return code; } /* *---------------------------------------------------------------------- * - * Tcl_InterpActive -- + * Tcl_LogCommandInfo -- * - * Returns non-zero if the specified interpreter is in use, i.e. if there - * is an evaluation currently active in the interpreter. + * This procedure is invoked after an error occurs in an interpreter. + * It adds information to the "errorInfo" variable to describe the + * command that was being executed when the error occurred. * * 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. + * Information about the command is added to errorInfo and the + * line number stored internally in the interpreter is set. If this + * is the first call to this procedure or Tcl_AddObjErrorInfo since + * an error occurred, then old information in errorInfo is + * deleted. * *---------------------------------------------------------------------- */ -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. */ -{ +void +Tcl_LogCommandInfo(interp, script, command, length) + Tcl_Interp *interp; /* Interpreter in which to log information. */ + CONST char *script; /* First character in script containing + * command (must be <= command). */ + CONST char *command; /* First character in command that + * generated the error. */ + int length; /* Number of bytes in command (-1 means + * use all bytes up to first null byte). */ +{ + char buffer[200]; + register CONST char *p; + char *ellipsis = ""; Interp *iPtr = (Interp *) interp; - int result; - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Command **cmdPtrPtr; - - iPtr->lookupNsPtr = NULL; - - /* - * Push a callback with cleanup tasks for commands; the cmdPtr at data[0] - * will be filled later when the command is found: save its address at - * objProcPtr. - * - * data[1] stores a marker for use by tailcalls; it will be set to 1 by - * command redirectors (imports, alias, ensembles) so that tailcalls - * finishes the source command and not just the target. - */ - - if (iPtr->evalFlags & TCL_EVAL_REDIRECT) { - TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), INT2PTR(objc), objv); - iPtr->evalFlags &= ~TCL_EVAL_REDIRECT; - } else { - TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv); - } - cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]); - - TclNRSpliceDeferred(interp); - iPtr->numLevels++; - result = TclInterpReady(interp); - - if ((result != TCL_OK) || (objc == 0)) { - return result; - } - - if (cmdPtr) { - goto commandFound; - } - - /* - * Push records for task to be done on return, in INVERSE order. First, if - * needed, the exception handlers (as they should happen last). - */ + if (iPtr->flags & ERR_ALREADY_LOGGED) { + /* + * Someone else has already logged error information for this + * command; we shouldn't add anything more. + */ - if (!(flags & TCL_EVAL_NOERR)) { - TEOV_PushExceptionHandlers(interp, objc, objv, flags); + return; } /* - * Configure evaluation context to match the requested flags. + * Compute the line number where the error occurred. */ - if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { - if (!lookupNsPtr) { - lookupNsPtr = iPtr->globalNsPtr; - } - } else { - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; } - - /* - * TCL_EVAL_INVOKE was not set: clear rewrite rules - */ - - iPtr->ensembleRewrite.sourceObjs = NULL; } /* - * Lookup the command + * Create an error message to add to errorInfo, including up to a + * maximum number of characters of the command. */ - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + if (length < 0) { + length = strlen(command); } - - iPtr->cmdCount++; - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; + if (length > 150) { + length = 150; + ellipsis = "..."; } - - /* - * Found a command! The real work begins now ... - */ - - commandFound: - if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + while ( (command[length] & 0xC0) == 0x80 ) { /* - * Call enter traces. They will schedule a call to the leave traces if - * necessary. + * Back up truncation point so that we don't truncate in the + * middle of a multi-byte character (in UTF-8) */ - - result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); - } - if (result != TCL_OK) { - return result; - } - } - - -#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]); + length--; + ellipsis = "..."; } - 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()) { - TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); - } - if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } -#endif /* USE_DTRACE */ - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - - /* - * Find the objProc to call: nreProc if available, objProc otherwise. Push - * a callback to do the actual running. - */ - - if (cmdPtr->nreProc) { - TclNRAddCallback(interp, NRRunObjProc, cmdPtr, - INT2PTR(objc), (ClientData) objv, NULL); - return TCL_OK; + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(buffer, "\n while executing\n\"%.*s%s\"", + length, command, ellipsis); } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); + sprintf(buffer, "\n invoked from within\n\"%.*s%s\"", + length, command, ellipsis); } + Tcl_AddObjErrorInfo(interp, buffer, -1); + iPtr->flags &= ~ERR_ALREADY_LOGGED; } - -void -TclPushTailcallPoint( - Tcl_Interp *interp) -{ - TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - ((Interp *) interp)->numLevels++; -} - -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; -} - -int -NRCommand( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - Command *cmdPtr = data[0]; - /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */ - - if (cmdPtr) { - TclCleanupCommandMacro(cmdPtr); - } - ((Interp *)interp)->numLevels--; - - /* 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; -} - -static int -NRRunObjProc( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* OPT: do not call? */ - - Command* cmdPtr = data[0]; - int objc = PTR2INT(data[1]); - Tcl_Obj **objv = data[2]; - - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); -} - /* *---------------------------------------------------------------------- * - * TEOV_Exception - - * TEOV_LookupCmdFromObj - - * TEOV_RunEnterTraces - - * TEOV_RunLeaveTraces - - * TEOV_NotFound - + * Tcl_EvalTokensStandard, EvalTokensStandard -- * - * These are helper functions for Tcl_EvalObjv. + * 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 procedure 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. * + * TIP #280 : Keep public API, internally extended API. *---------------------------------------------------------------------- */ -static void -TEOV_PushExceptionHandlers( - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[], - int flags) +int +Tcl_EvalTokensStandard(interp, tokenPtr, count) + 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. */ { - 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); - } +#ifdef TCL_TIP280 + return EvalTokensStandard (interp, tokenPtr, count, 1, NULL, NULL); } -static void -TEOV_SwitchVarFrame( - Tcl_Interp *interp) +static int +EvalTokensStandard(interp, tokenPtr, count, line, clNextOuter, outerScript) + 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. */ + 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 by + * EvalEx() 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 + * words in the outer-most script/command. See + * Tcl_EvalEx() and TclEvalObjEx() for the places + * generating arguments for which this is true. + */ { - Interp *iPtr = (Interp *) interp; +#endif + Tcl_Obj *resultPtr, *indexPtr, *valuePtr; + char buffer[TCL_UTF_MAX]; +#ifdef TCL_MEM_DEBUG +# define MAX_VAR_CHARS 5 +#else +# define MAX_VAR_CHARS 30 +#endif + char nameBuffer[MAX_VAR_CHARS+1]; + char *varName, *index; + CONST char *p = NULL; /* Initialized to avoid compiler warning. */ + int length, code; +#ifdef TCL_TIP280 +#define NUM_STATIC_POS 20 + int isLiteral, maxNumCL, numCL, i, adjust; + int* clPosition = NULL; + Interp* iPtr = (Interp*) interp; + int inFile = iPtr->evalFlags & TCL_EVAL_FILE; +#endif /* - * Change the varFrame to be the rootVarFrame, and push a record to - * restore things at the end. + * The only tricky thing about this procedure is that it attempts to + * avoid object creation and string copying whenever possible. For + * example, if the value is just a nested command, then use the + * command's result object directly. */ - 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; + code = TCL_OK; + resultPtr = NULL; + Tcl_ResetResult(interp); +#ifdef TCL_TIP280 + /* + * For the handling of continuation lines in literals we first check if + * this is actually a literal. For if not we can forego the additional + * processing. Otherwise we pre-allocate a small table to store the + * locations of all continuation lines we find in this literal, if + * any. The table is extended if needed. + */ + + numCL = 0; + maxNumCL = 0; + isLiteral = 1; + for (i=0 ; i < count; i++) { + if ((tokenPtr[i].type != TCL_TOKEN_TEXT) && + (tokenPtr[i].type != TCL_TOKEN_BS)) { + isLiteral = 0; + break; } } - /* - * 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 (isLiteral) { + maxNumCL = NUM_STATIC_POS; + clPosition = (int*) ckalloc (maxNumCL*sizeof(int)); + } + adjust = 0; +#endif + for ( ; count > 0; count--, tokenPtr++) { + valuePtr = NULL; - 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. + * The switch statement below computes the next value to be + * concat to the result, as either a range of text or an + * object. */ - listPtr = Tcl_NewListObj(objc, objv); - cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); - Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); - Tcl_DecrRefCount(listPtr); - } - iPtr->flags &= ~ERR_ALREADY_LOGGED; - return result; -} - -static int -TEOV_NotFound( - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr) -{ - Command * cmdPtr; - Interp *iPtr = (Interp *) interp; - int i, newObjc, handlerObjc; - Tcl_Obj **newObjv, **handlerObjv; - CallFrame *varFramePtr = iPtr->varFramePtr; - Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered - * unknown command handler for the current - * namespace (TIP 181). */ - Namespace *savedNsPtr = NULL; + switch (tokenPtr->type) { + case TCL_TOKEN_TEXT: + p = tokenPtr->start; + length = tokenPtr->size; + break; - currNsPtr = varFramePtr->nsPtr; - if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) { - currNsPtr = iPtr->globalNsPtr; - if (currNsPtr == NULL) { - Tcl_Panic("Tcl_EvalObjv: NULL global namespace pointer"); - } - } + case TCL_TOKEN_BS: + length = TclParseBackslash(tokenPtr->start, tokenPtr->size, + (int *) NULL, buffer); + p = buffer; +#ifdef TCL_TIP280 + /* + * If the backslash sequence we found is in a literal, and + * represented a continuation line, we compute and store its + * location (as char offset to the beginning of the _result_ + * script). We may have to extend the table of locations. + * + * Note that the continuation line information is relevant + * even if the word we are processing is not a literal, as it + * can affect nested commands. See the branch for + * TCL_TOKEN_COMMAND below, where the adjustment we are + * tracking here is taken into account. The good thing is that + * we do not need a table of everything, just the number of + * lines we have to add as correction. + */ - /* - * Check to see if the resolution namespace has lost its unknown handler. - * If so, reset it to "::unknown". - */ + if ((length == 1) && (buffer[0] == ' ') && + (tokenPtr->start[1] == '\n')) { + if (isLiteral) { + int clPos; + if (resultPtr == 0) { + clPos = 0; + } else { + Tcl_GetStringFromObj(resultPtr, &clPos); + } - if (currNsPtr->unknownHandlerPtr == NULL) { - TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); - Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); - } + if (numCL >= maxNumCL) { + maxNumCL *= 2; + clPosition = (int*) ckrealloc ((char*)clPosition, + maxNumCL*sizeof(int)); + } + clPosition[numCL] = clPos; + numCL ++; + } + adjust ++; + } +#endif + break; - /* - * 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. - */ + case TCL_TOKEN_COMMAND: { + Interp *iPtr = (Interp *) interp; + iPtr->numLevels++; + code = TclInterpReady(interp); + if (code == TCL_OK) { +#ifndef TCL_TIP280 + code = Tcl_EvalEx(interp, + tokenPtr->start+1, tokenPtr->size-2, 0); +#else + /* TIP #280: Transfer line information to nested command */ + TclAdvanceContinuations (&line, &clNextOuter, + tokenPtr->start - outerScript); + code = EvalEx(interp, + tokenPtr->start+1, tokenPtr->size-2, 0, + line + adjust, clNextOuter, outerScript); - Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, - &handlerObjc, &handlerObjv); - newObjc = objc + handlerObjc; - newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc); + /* + * Restore flag reset by the nested eval for future + * bracketed commands and their CmdFrame setup + */ + if (inFile) { + iPtr->evalFlags |= TCL_EVAL_FILE; + } +#endif + } + iPtr->numLevels--; + if (code != TCL_OK) { + goto done; + } + valuePtr = Tcl_GetObjResult(interp); + break; + } - /* - * 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. - */ + case TCL_TOKEN_VARIABLE: + if (tokenPtr->numComponents == 1) { + indexPtr = NULL; + index = NULL; + } else { +#ifndef TCL_TIP280 + code = Tcl_EvalTokensStandard(interp, tokenPtr+2, + tokenPtr->numComponents - 1); +#else + /* TIP #280: Transfer line information to nested command */ + code = EvalTokensStandard(interp, tokenPtr+2, + tokenPtr->numComponents - 1, line, NULL, NULL); +#endif + if (code != TCL_OK) { + goto done; + } + indexPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(indexPtr); + index = Tcl_GetString(indexPtr); + } - for (i = 0; i < handlerObjc; ++i) { - newObjv[i] = handlerObjv[i]; - Tcl_IncrRefCount(newObjv[i]); - } - memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); + /* + * We have to make a copy of the variable name in order + * to have a null-terminated string. We can't make a + * temporary modification to the script to null-terminate + * the name, because a trace callback might potentially + * reuse the script and be affected by the null character. + */ - /* - * 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. - */ + if (tokenPtr[1].size <= MAX_VAR_CHARS) { + varName = nameBuffer; + } else { + varName = ckalloc((unsigned) (tokenPtr[1].size + 1)); + } + strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size); + varName[tokenPtr[1].size] = 0; + valuePtr = Tcl_GetVar2Ex(interp, varName, index, + TCL_LEAVE_ERR_MSG); + if (varName != nameBuffer) { + ckfree(varName); + } + if (indexPtr != NULL) { + Tcl_DecrRefCount(indexPtr); + } + if (valuePtr == NULL) { + code = TCL_ERROR; + goto done; + } + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; - cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr); - if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[0]), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(objv[0]), NULL); + default: + panic("unexpected token type in Tcl_EvalTokensStandard"); + } /* - * Release any resources we locked and allocated during the handler - * call. + * If valuePtr isn't NULL, the next piece of text comes from that + * object; otherwise, take length bytes starting at p. */ - for (i = 0; i < handlerObjc; ++i) { - Tcl_DecrRefCount(newObjv[i]); + if (resultPtr == NULL) { + if (valuePtr != NULL) { + resultPtr = valuePtr; + } else { + resultPtr = Tcl_NewStringObj(p, length); + } + Tcl_IncrRefCount(resultPtr); + } else { + if (Tcl_IsShared(resultPtr)) { + Tcl_DecrRefCount(resultPtr); + resultPtr = Tcl_DuplicateObj(resultPtr); + Tcl_IncrRefCount(resultPtr); + } + if (valuePtr != NULL) { + p = Tcl_GetStringFromObj(valuePtr, &length); + } + Tcl_AppendToObj(resultPtr, p, length); } - TclStackFree(interp, newObjv); - return TCL_ERROR; - } - - if (lookupNsPtr) { - savedNsPtr = varFramePtr->nsPtr; - varFramePtr->nsPtr = lookupNsPtr; - } - TclNRDeferCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc), - newObjv, savedNsPtr, NULL); - iPtr->evalFlags |= TCL_EVAL_REDIRECT; - return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL); -} - -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, - int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr) -{ - Interp *iPtr = (Interp *) interp; - Command *cmdPtr = *cmdPtrPtr; - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length; - Tcl_Obj *commandPtr; - - commandPtr = GetCommandSource(iPtr, objc, objv, 1); - command = Tcl_GetStringFromObj(commandPtr, &length); - - /* - * Call trace functions. - * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. - */ - - cmdPtr->refCount++; - if (iPtr->tracePtr) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - TclCleanupCommandMacro(cmdPtr); - - /* - * If the traces modified/deleted the command or any existing traces, they - * will update the command's epoch. We need to lookup again, but do not - * run enter traces on the newly found cmdPtr. - */ - - if (cmdEpoch != newEpoch) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - *cmdPtrPtr = cmdPtr; } - - if (cmdPtr) { + if (resultPtr != NULL) { + Tcl_SetObjResult(interp, resultPtr); +#ifdef TCL_TIP280 /* - * Command was found: push a record to schedule the leave traces. + * If the code found continuation lines (which implies that this word + * is a literal), then we store the accumulated table of locations in + * the thread-global data structure for the bytecode compiler to find + * later, assuming that the literal is a script which will be + * compiled. */ - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode), - commandPtr, cmdPtr, NULL); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); - } - return traceCode; -} - -static int -TEOV_RunLeaveTraces( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - const char *command; - int length, objc; - Tcl_Obj **objv; - int traceCode = PTR2INT(data[0]); - Tcl_Obj *commandPtr = data[1]; - Command *cmdPtr = data[2]; - - command = Tcl_GetStringFromObj(commandPtr, &length); - if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) { - Tcl_Panic("Who messed with commandPtr?"); - } - - if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); + if (numCL) { + TclContinuationsEnter(resultPtr, numCL, clPosition); } - if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); - } - } - Tcl_DecrRefCount(commandPtr); - /* - * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. - * Prevent that by resetting the cmdPtr field and dealing right here with - * cmdPtr->refCount. - */ - - TclCleanupCommandMacro(cmdPtr); + /* + * Release the temp table we used to collect the locations of + * continuation lines, if any. + */ - if (traceCode != TCL_OK) { - return traceCode; + if (maxNumCL) { + ckfree ((char*) clPosition); + } +#endif + } else { + code = TCL_ERROR; } - 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; - iPtr->lookupNsPtr = NULL; + done: + if (resultPtr != NULL) { + Tcl_DecrRefCount(resultPtr); } - 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); + return code; } /* @@ -4835,62 +3850,67 @@ Tcl_EvalTokensStandard( * * 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. + * 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 procedure 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. + * 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. + * 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. +Tcl_EvalTokens(interp, tokenPtr, count) + 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. */ { + int code; Tcl_Obj *resPtr; - - if (Tcl_EvalTokensStandard(interp, tokenPtr, count) != TCL_OK) { + + code = Tcl_EvalTokensStandard(interp, tokenPtr, count); + if (code == TCL_OK) { + resPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resPtr); + Tcl_ResetResult(interp); + return resPtr; + } else { return NULL; } - resPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resPtr); - Tcl_ResetResult(interp); - return resPtr; } + /* *---------------------------------------------------------------------- * - * Tcl_EvalEx, TclEvalEx -- + * Tcl_EvalEx, EvalEx -- * - * 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. + * This procedure 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. + * 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. @@ -4900,81 +3920,87 @@ Tcl_EvalTokens( */ 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 +Tcl_EvalEx(interp, script, numBytes, flags) + 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. */ + 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); +#ifdef TCL_TIP280 + return EvalEx (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 +static int +EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript) + 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. */ + * first null 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 + * EvalTokensStandard(), 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. + */ { +#endif Interp *iPtr = (Interp *) interp; - const char *p, *next; - const unsigned int minObjs = 20; - Tcl_Obj **objv, **objvSpace; - int *expand, *lines, *lineSpace; + CONST char *p, *next; + Tcl_Parse parse; +#define NUM_STATIC_OBJS 20 + Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; 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 code = TCL_OK; + int i, commandLength, bytesLeft, nested; + 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. */ + + /* + * The variables below keep track of how much state has been + * allocated while evaluating the script, so that it can be freed + * properly if an error occurs. + */ + + int gotParse = 0, objectsUsed = 0; + +#ifdef TCL_TIP280 + /* TIP #280 Structures for tracking of command locations. */ + CmdFrame eeFrame; + + /* + * Pointer for the tracking of invisible continuation lines. Initialized + * only if the caller gave us a table of locations to track, via + * scriptCLLocPtr. It always refers to the table entry holding the + * location of the next invisible continuation line to look for, while + * parsing the script. + */ + + int* clNext = NULL; if (iPtr->scriptCLLocPtr) { if (clNextOuter) { @@ -4983,6 +4009,7 @@ TclEvalEx( clNext = &iPtr->scriptCLLocPtr->loc[0]; } } +#endif if (numBytes < 0) { numBytes = strlen(script); @@ -4991,105 +4018,112 @@ TclEvalEx( savedVarFramePtr = iPtr->varFramePtr; if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = iPtr->rootFramePtr; + iPtr->varFramePtr = NULL; } /* - * Each iteration through the following loop parses the next command from - * the script and then executes it. + * 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; + objv = staticObjArray; p = script; bytesLeft = numBytes; + if (iPtr->evalFlags & TCL_BRACKET_TERM) { + nested = 1; + } else { + nested = 0; + } +#ifdef TCL_TIP280 + /* TIP #280 Initialize tracking. Do not push on the frame stack yet. */ /* - * TIP #280 Initialize tracking. Do not push on the frame stack yet. - * - * We may continue counting based on a specific context (CTX), or open a - * new context, either for a sourced script, or 'eval'. For sourced files - * we always have a path object, even if nothing was specified in the - * interp itself. That makes code using it simpler as NULL checks can be - * left out. Sourced file without path in the 'scriptFile' is possible - * during Tcl initialization. - */ - - eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; - eeFramePtr->numLevels = iPtr->numLevels; - eeFramePtr->framePtr = iPtr->framePtr; - eeFramePtr->nextPtr = iPtr->cmdFramePtr; - eeFramePtr->nline = 0; - eeFramePtr->line = NULL; - - iPtr->cmdFramePtr = eeFramePtr; + * We may cont. counting based on a specific context (CTX), or open a new + * context, either for a sourced script, or 'eval'. For sourced files we + * always have a path object, even if nothing was specified in the interp + * itself. That makes code using it simpler as NULL checks can be left + * out. Sourced file without path in the 'scriptFile' is possible during + * Tcl initialization. + */ + if (iPtr->evalFlags & TCL_EVAL_CTX) { - /* - * Path information comes out of the context. - */ + /* Path information comes out of the context. */ - eeFramePtr->type = TCL_LOCATION_SOURCE; - eeFramePtr->data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; - Tcl_IncrRefCount(eeFramePtr->data.eval.path); + eeFrame.type = TCL_LOCATION_SOURCE; + eeFrame.data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; + Tcl_IncrRefCount (eeFrame.data.eval.path); } else if (iPtr->evalFlags & TCL_EVAL_FILE) { - /* - * Set up for a sourced file. - */ + /* Set up for a sourced file */ - eeFramePtr->type = TCL_LOCATION_SOURCE; + eeFrame.type = TCL_LOCATION_SOURCE; if (iPtr->scriptFile) { - /* - * Normalization here, to have the correct pwd. Should have + /* 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. + * result */ - Tcl_Obj *norm = Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile); - - if (norm == NULL) { - /* - * Error message in the interp result. - */ - - code = TCL_ERROR; - goto error; + Tcl_Obj* norm = Tcl_FSGetNormalizedPath (interp, iPtr->scriptFile); + if (!norm) { + /* Error message in the interp result */ + return TCL_ERROR; } - eeFramePtr->data.eval.path = norm; + eeFrame.data.eval.path = norm; } else { - TclNewLiteralStringObj(eeFramePtr->data.eval.path, ""); + eeFrame.data.eval.path = Tcl_NewStringObj ("",-1); } - Tcl_IncrRefCount(eeFramePtr->data.eval.path); + Tcl_IncrRefCount (eeFrame.data.eval.path); } else { - /* - * Set up for plain eval. - */ + /* Set up for plain eval */ - eeFramePtr->type = TCL_LOCATION_EVAL; - eeFramePtr->data.eval.path = NULL; + eeFrame.type = TCL_LOCATION_EVAL; + eeFrame.data.eval.path = NULL; } + eeFrame.level = (iPtr->cmdFramePtr == NULL + ? 1 + : iPtr->cmdFramePtr->level + 1); + eeFrame.framePtr = iPtr->framePtr; + eeFrame.nextPtr = iPtr->cmdFramePtr; + eeFrame.nline = 0; + eeFrame.line = NULL; +#endif + iPtr->evalFlags = 0; do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { + if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) + != TCL_OK) { code = TCL_ERROR; goto error; } + gotParse = 1; + if (nested && parse.term == (script + numBytes)) { + /* + * A nested script can only terminate in ']'. If + * the parsing got terminated at the end of the script, + * there was no closing ']'. Report the syntax error. + */ + + code = TCL_ERROR; + goto error; + } + +#ifdef TCL_TIP280 /* * 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 + * found the command we are now at. We have count the lines in this * block, and do not forget invisible continuation lines. */ - TclAdvanceLines(&line, p, parsePtr->commandStart); - TclAdvanceContinuations(&line, &clNext, - parsePtr->commandStart - outerScript); + TclAdvanceLines (&line, p, parse.commandStart); + TclAdvanceContinuations (&line, &clNext, + parse.commandStart - outerScript); +#endif - gotParse = 1; - if (parsePtr->numWords > 0) { + if (parse.numWords > 0) { +#ifdef TCL_TIP280 /* * TIP #280. Track lines within the words of the current * command. We use a separate pointer into the table of @@ -5097,140 +4131,77 @@ TclEvalEx( * per-command parsing. */ - int wordLine = line; - const char *wordStart = parsePtr->commandStart; - int *wordCLNext = clNext; - unsigned int objectsNeeded = 0; - unsigned int numWords = parsePtr->numWords; + int wordLine = line; + CONST char* wordStart = parse.commandStart; + int* wordCLNext = clNext; +#endif /* * 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)); + + if (parse.numWords <= NUM_STATIC_OBJS) { + objv = staticObjArray; + } else { + objv = (Tcl_Obj **) ckalloc((unsigned) + (parse.numWords * sizeof (Tcl_Obj *))); } - 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). + +#ifdef TCL_TIP280 + eeFrame.nline = parse.numWords; + eeFrame.line = (int*) ckalloc((unsigned) + (parse.numWords * sizeof (int))); +#endif + + for (objectsUsed = 0, tokenPtr = parse.tokenPtr; + objectsUsed < parse.numWords; + objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { +#ifndef TCL_TIP280 + code = Tcl_EvalTokensStandard(interp, tokenPtr+1, + tokenPtr->numComponents); +#else + /* + * 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); + TclAdvanceLines (&wordLine, wordStart, tokenPtr->start); + TclAdvanceContinuations (&wordLine, &wordCLNext, + tokenPtr->start - outerScript); wordStart = tokenPtr->start; - lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) - ? wordLine : -1; + eeFrame.line [objectsUsed] = (TclWordKnownAtCompileTime (tokenPtr) + ? wordLine + : -1); - if (eeFramePtr->type == TCL_LOCATION_SOURCE) { + if (eeFrame.type == TCL_LOCATION_SOURCE) { iPtr->evalFlags |= TCL_EVAL_FILE; } - code = TclSubstTokens(interp, tokenPtr+1, - tokenPtr->numComponents, NULL, wordLine, - wordCLNext, outerScript); + code = EvalTokensStandard(interp, tokenPtr+1, + tokenPtr->numComponents, wordLine, + wordCLNext, outerScript); iPtr->evalFlags = 0; +#endif - 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; + if (code == TCL_OK) { + objv[objectsUsed] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(objv[objectsUsed]); +#ifdef TCL_TIP280 + if (wordCLNext) { + TclContinuationsEnterDerived (objv[objectsUsed], + wordStart - outerScript, wordCLNext); } - expandRequested = 1; - expand[objectsUsed] = 1; - - objectsNeeded += (numElements ? numElements : 1); +#endif } 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); + goto error; } } - + /* * Execute the command and free the objects for its words. * @@ -5241,23 +4212,29 @@ TclEvalEx( * have been executed. */ - eeFramePtr->cmd.str.cmd = parsePtr->commandStart; - eeFramePtr->cmd.str.len = parsePtr->commandSize; +#ifdef TCL_TIP280 + eeFrame.cmd.str.cmd = parse.commandStart; + eeFrame.cmd.str.len = parse.commandSize; - if (parsePtr->term == - parsePtr->commandStart + parsePtr->commandSize - 1) { - eeFramePtr->cmd.str.len--; + if (parse.term == parse.commandStart + parse.commandSize - 1) { + eeFrame.cmd.str.len --; } - eeFramePtr->nline = objectsUsed; - eeFramePtr->line = lines; - - TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); - code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR); - TclArgumentRelease(interp, objv, objectsUsed); - - eeFramePtr->line = NULL; - eeFramePtr->nline = 0; + TclArgumentEnter (interp, objv, objectsUsed, &eeFrame); + iPtr->cmdFramePtr = &eeFrame; +#endif + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objectsUsed, objv, + parse.commandStart, parse.commandSize, 0); + iPtr->numLevels--; +#ifdef TCL_TIP280 + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + TclArgumentRelease (interp, objv, objectsUsed); + + ckfree ((char*) eeFrame.line); + eeFrame.line = NULL; + eeFrame.nline = 0; +#endif if (code != TCL_OK) { goto error; @@ -5266,21 +4243,9 @@ TclEvalEx( 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; + if (objv != staticObjArray) { + ckfree((char *) objv); + objv = staticObjArray; } } @@ -5291,92 +4256,214 @@ TclEvalEx( * executed command. */ - next = parsePtr->commandStart + parsePtr->commandSize; + next = parse.commandStart + parse.commandSize; bytesLeft -= next - p; p = next; - TclAdvanceLines(&line, parsePtr->commandStart, p); - Tcl_FreeParse(parsePtr); +#ifdef TCL_TIP280 + TclAdvanceLines (&line, parse.commandStart, p); +#endif + Tcl_FreeParse(&parse); gotParse = 0; + if (nested && (*parse.term == ']')) { + /* + * We get here in the special case where the TCL_BRACKET_TERM + * flag was set in the interpreter and the latest parsed command + * was terminated by the matching close-bracket we seek. + * Return immediately. + */ + + iPtr->termOffset = (p - 1) - script; + iPtr->varFramePtr = savedVarFramePtr; +#ifndef TCL_TIP280 + return TCL_OK; +#else + code = TCL_OK; + goto cleanup_return; +#endif + } } while (bytesLeft > 0); + + if (nested) { + /* + * This nested script did not terminate in ']', it is an error. + */ + + code = TCL_ERROR; + goto error; + } + + iPtr->termOffset = p - script; iPtr->varFramePtr = savedVarFramePtr; +#ifndef TCL_TIP280 + return TCL_OK; +#else code = TCL_OK; goto cleanup_return; +#endif - error: + error: /* - * Generate and log various pieces of error information. + * Generate various pieces of error information, such as the line + * number where the error occurred and information to add to the + * errorInfo variable. Then free resources that had been allocated + * to the command. */ if (iPtr->numLevels == 0) { if (code == TCL_RETURN) { code = TclUpdateReturnInfo(iPtr); } - if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { + 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) { + if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + commandLength = parse.commandSize; + if (parse.term == parse.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); + Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); } - 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); + Tcl_FreeParse(&parse); } - if (expand != expandStack) { - ckfree(expand); + if (objv != staticObjArray) { + ckfree((char *) objv); } iPtr->varFramePtr = savedVarFramePtr; - cleanup_return: /* - * TIP #280. Release the local CmdFrame, and its contents. + * All that's left to do before returning is to set iPtr->termOffset + * to point past the end of the script we just evaluated. + */ + + next = parse.commandStart + parse.commandSize; + bytesLeft -= next - p; + p = next; + + if (!nested) { + iPtr->termOffset = p - script; +#ifndef TCL_TIP280 + return code; +#else + goto cleanup_return; +#endif + } + + /* + * When we are nested (the TCL_BRACKET_TERM flag was set in the + * interpreter), we must find the matching close-bracket to + * end the script we are evaluating. + * + * When our return code is TCL_CONTINUE or TCL_RETURN, we want + * to correctly set iPtr->termOffset to point to that matching + * close-bracket so our caller can move to the part of the + * string beyond the script we were asked to evaluate. + * So we try to parse past the rest of the commands. */ - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; - if (eeFramePtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(eeFramePtr->data.eval.path); + next = NULL; + while (bytesLeft && (*parse.term != ']')) { + if (TCL_OK != Tcl_ParseCommand(NULL, p, bytesLeft, 1, &parse)) { + /* + * Syntax error. Set the termOffset to the beginning of + * the last command parsed. + */ + + if (next == NULL) { + iPtr->termOffset = (parse.commandStart - 1) - script; + } else { + iPtr->termOffset = (next - 1) - script; + } +#ifndef TCL_TIP280 + return code; +#else + goto cleanup_return; +#endif + } + next = parse.commandStart + parse.commandSize; + bytesLeft -= next - p; + p = next; + next = parse.commandStart; + Tcl_FreeParse(&parse); + } + + if (bytesLeft) { + /* + * parse.term points to the close-bracket. + */ + + iPtr->termOffset = parse.term - script; + } else if (parse.term == script + numBytes) { + /* + * There was no close-bracket. Syntax error. + */ + + iPtr->termOffset = parse.term - script; + Tcl_SetObjResult(interp, + Tcl_NewStringObj("missing close-bracket", -1)); +#ifndef TCL_TIP280 + return TCL_ERROR; +#else + code = TCL_ERROR; + goto cleanup_return; +#endif + } else if (*parse.term != ']') { + /* + * There was no close-bracket. Syntax error. + */ + + iPtr->termOffset = (parse.term + 1) - script; + Tcl_SetObjResult(interp, + Tcl_NewStringObj("missing close-bracket", -1)); +#ifndef TCL_TIP280 + return TCL_ERROR; +#else + code = TCL_ERROR; + goto cleanup_return; +#endif + } else { + /* + * parse.term points to the close-bracket. + */ + iPtr->termOffset = parse.term - script; } - TclStackFree(interp, linesStack); - TclStackFree(interp, expandStack); - TclStackFree(interp, stackObjArray); - TclStackFree(interp, eeFramePtr); - TclStackFree(interp, parsePtr); +#ifdef TCL_TIP280 + cleanup_return: + /* TIP #280. Release the local CmdFrame, and its contents. */ + + if (eeFrame.line != NULL) { + ckfree ((char*) eeFrame.line); + } + if (eeFrame.type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount (eeFrame.data.eval.path); + } +#endif return code; } +#ifdef TCL_TIP280 /* *---------------------------------------------------------------------- * * TclAdvanceLines -- * - * This function is a helper which counts the number of lines in a block - * of text and advances an external counter. + * This procedure is a helper which counts the number of lines + * in a block of text and advances an external counter. * * Results: * None. @@ -5389,16 +4476,15 @@ TclEvalEx( */ void -TclAdvanceLines( - int *line, - const char *start, - const char *end) +TclAdvanceLines (line,start,end) + int* line; + CONST char* start; + CONST char* end; { - register const char *p; - + CONST char* p; for (p = start; p < end; p++) { - if (*p == '\n') { - (*line)++; + if (*p == '\n') { + (*line) ++; } } } @@ -5424,31 +4510,29 @@ TclAdvanceLines( */ void -TclAdvanceContinuations( - int *line, - int **clNextPtrPtr, - int loc) +TclAdvanceContinuations (line,clNextPtrPtr,loc) + int* line; + int** clNextPtrPtr; + int loc; { /* - * Track the invisible continuation lines embedded in a script, if any. - * Here they are just spaces (already). They were removed by - * TclSubstTokens via TclParseBackslash. + * Track the invisible continuation lines embedded in a script, if + * any. Here they are just spaces (already). They were removed by + * EvalTokensStandard() 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. + * *clNextPtrPtr <=> We have continuation lines to track. + * **clNextPtrPtr >= 0 <=> We are not beyond the last possible location. + * loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line. */ - while (*clNextPtrPtr && (**clNextPtrPtr >= 0) - && (loc >= **clNextPtrPtr)) { + while (*clNextPtrPtr && (**clNextPtrPtr >= 0) && (loc >= **clNextPtrPtr)) { /* * We just stepped over an invisible continuation line. Adjust the * line counter and step to the table entry holding the location of * the next continuation line to track. */ - - (*line)++; - (*clNextPtrPtr)++; + (*line) ++; + (*clNextPtrPtr) ++; } } @@ -5466,8 +4550,8 @@ TclAdvanceContinuations( * * TclArgumentEnter -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * enters location references for the arguments of a command to be + * This procedure is a helper for the TIP #280 uplevel extension. + * It enters location references for the arguments of a command to be * invoked. Only the first entry has the actual data, further entries * simply count the usage up. * @@ -5482,49 +4566,45 @@ TclAdvanceContinuations( */ void -TclArgumentEnter( - Tcl_Interp *interp, - Tcl_Obj **objv, - int objc, - CmdFrame *cfPtr) +TclArgumentEnter(interp,objv,objc,cfPtr) + Tcl_Interp* interp; + Tcl_Obj** objv; + int objc; + CmdFrame* cfPtr; { - Interp *iPtr = (Interp *) interp; + Interp* iPtr = (Interp*) interp; int new, i; - Tcl_HashEntry *hPtr; - CFWord *cfwPtr; + Tcl_HashEntry* hPtr; + CFWord* cfwPtr; - for (i = 1; i < objc; i++) { + for (i=1; i < objc; i++) { /* - * Ignore argument words without line information (= dynamic). If they - * are variables they may have location information associated with - * that, either through globally recorded 'set' invokations, or + * Ignore argument words without line information (= dynamic). If + * they are variables they may have location information associated + * with that, either through globally recorded 'set' invokations, or * literals in bytecode. Eitehr way there is no need to record * something here. */ - if (cfPtr->line[i] < 0) { - continue; - } - hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &new); + if (cfPtr->line [i] < 0) continue; + hPtr = Tcl_CreateHashEntry (iPtr->lineLAPtr, (char*) 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); + /* + * The word is not on the stack yet, remember the current location + * and initialize references. + */ + cfwPtr = (CFWord*) ckalloc (sizeof (CFWord)); + cfwPtr->framePtr = cfPtr; + cfwPtr->word = i; + cfwPtr->refCount = 1; + Tcl_SetHashValue (hPtr, cfwPtr); } 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++; + /* + * The word is already on the stack, its current location is not + * relevant. Just remember the reference to prevent early removal. + */ + cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); + cfwPtr->refCount ++; } } } @@ -5534,10 +4614,10 @@ TclArgumentEnter( * * TclArgumentRelease -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * removes the location references for the arguments of a command just - * done. Usage is counted down, the data is removed only when no user is - * left over. + * This procedure is a helper for the TIP #280 uplevel extension. + * It removes the location references for the arguments of a command + * just done. Usage is counted down, the data is removed only when + * no user is left over. * * Results: * None. @@ -5550,31 +4630,27 @@ TclArgumentEnter( */ void -TclArgumentRelease( - Tcl_Interp *interp, - Tcl_Obj **objv, - int objc) -{ - Interp *iPtr = (Interp *) interp; +TclArgumentRelease(interp,objv,objc) + Tcl_Interp* interp; + Tcl_Obj** objv; + int objc; +{ + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hPtr; + CFWord* cfwPtr; int i; - for (i = 1; i < objc; i++) { - CFWord *cfwPtr; - Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]); + for (i=1; i < objc; i++) { + hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) objv[i]); - if (!hPtr) { - continue; - } - cfwPtr = Tcl_GetHashValue(hPtr); + if (!hPtr) { continue; } + cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); - cfwPtr->refCount--; - if (cfwPtr->refCount > 0) { - continue; - } + cfwPtr->refCount --; + if (cfwPtr->refCount > 0) { continue; } - ckfree(cfwPtr); - Tcl_DeleteHashEntry(hPtr); + ckfree ((char*) cfwPtr); + Tcl_DeleteHashEntry (hPtr); } } @@ -5583,9 +4659,9 @@ TclArgumentRelease( * * TclArgumentBCEnter -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * enters location references for the literal arguments of commands in - * bytecode about to be invoked. Only the first entry has the actual + * This procedure is a helper for the TIP #280 uplevel extension. + * It enters location references for the literal arguments of commands + * in bytecode about to be executed. Only the first entry has the actual * data, further entries simply count the usage up. * * Results: @@ -5599,81 +4675,68 @@ TclArgumentRelease( */ void -TclArgumentBCEnter( - Tcl_Interp *interp, - Tcl_Obj *objv[], - int objc, - void *codePtr, - CmdFrame *cfPtr, - int pc) +TclArgumentBCEnter(interp, objv, objc, codePtr, cfPtr, pc) + Tcl_Interp* interp; + Tcl_Obj* objv[]; + int objc; + void* codePtr; + CmdFrame* cfPtr; + int pc; { - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); - ExtCmdLoc *eclPtr; + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); - if (!hePtr) { - return; - } - eclPtr = Tcl_GetHashValue(hePtr); - hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); if (hePtr) { - int word; - int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); - ECL *ePtr = &eclPtr->loc[cmd]; - CFWordBC *lastPtr = NULL; + ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); + hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc); - /* - * A few truths ... - * (1) ePtr->nline == objc - * (2) (ePtr->line[word] < 0) => !literal, for all words - * (3) (word == 0) => !literal - * - * Item (2) is why we can use objv to get the literals, and do not - * have to save them at compile time. - */ + if (hePtr) { + int word; + int cmd = (int) Tcl_GetHashValue(hePtr); + ECL* ePtr = &eclPtr->loc[cmd]; - if (ePtr->nline != objc) { - Tcl_Panic ("TIP 280 data structure inconsistency"); - } - - for (word = 1; word < objc; word++) { - if (ePtr->line[word] >= 0) { - int isnew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, - objv[word], &isnew); - CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); - - cfwPtr->framePtr = cfPtr; - cfwPtr->obj = objv[word]; - cfwPtr->pc = pc; - cfwPtr->word = word; - cfwPtr->nextPtr = lastPtr; - lastPtr = cfwPtr; - - if (isnew) { - /* - * The word is not on the stack yet, remember the current - * location and initialize references. - */ + /* + * 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. + */ - 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. - */ + for (word = 1; word < objc; word++) { + if (ePtr->line[word] >= 0) { + int isnew; + Tcl_HashEntry* hPtr = + Tcl_CreateHashEntry (iPtr->lineLABCPtr, + (char*) objv[word], &isnew); + CFWordBC* cfwPtr = (CFWordBC*) ckalloc (sizeof (CFWordBC)); - cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); - } + cfwPtr->framePtr = cfPtr; + cfwPtr->pc = pc; + cfwPtr->word = word; - Tcl_SetHashValue(hPtr, cfwPtr); - } - } /* for */ + if (isnew) { + /* + * The word is not on the stack yet, remember the + * current location and initialize references. + */ + cfwPtr->prevPtr = NULL; + } else { + /* + * The object is already on the stack, however it may + * have a different location now (literal sharing may + * map multiple location to a single Tcl_Obj*. Save + * the old information in the new structure. + */ + cfwPtr->prevPtr = (CFWordBC*) Tcl_GetHashValue(hPtr); + } - cfPtr->litarg = lastPtr; + Tcl_SetHashValue (hPtr, cfwPtr); + } + } /* for */ + } /* if */ } /* if */ } @@ -5682,10 +4745,10 @@ TclArgumentBCEnter( * * TclArgumentBCRelease -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * removes the location references for the literal arguments of commands - * in bytecode just done. Usage is counted down, the data is removed only - * when no user is left over. + * This procedure is a helper for the TIP #280 uplevel extension. + * It removes the location references for the literal arguments of + * commands in bytecode just done. Usage is counted down, the data + * is removed only when no user is left over. * * Results: * None. @@ -5698,34 +4761,48 @@ TclArgumentBCEnter( */ void -TclArgumentBCRelease( - Tcl_Interp *interp, - CmdFrame *cfPtr) +TclArgumentBCRelease(interp, objv, objc, codePtr, pc) + Tcl_Interp* interp; + Tcl_Obj* objv[]; + int objc; + void* codePtr; + int pc; { - Interp *iPtr = (Interp *) interp; - CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg; + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); - while (cfwPtr) { - CFWordBC *nextPtr = cfwPtr->nextPtr; - Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj); - CFWordBC *xPtr = Tcl_GetHashValue(hPtr); + if (hePtr) { + ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); + hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc); - if (xPtr != cfwPtr) { - Tcl_Panic("TclArgumentBC Enter/Release Mismatch"); - } + if (hePtr) { + int cmd = (int) Tcl_GetHashValue(hePtr); + ECL* ePtr = &eclPtr->loc[cmd]; + int word; - if (cfwPtr->prevPtr) { - Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); - } else { - Tcl_DeleteHashEntry(hPtr); - } + /* + * Iterate in reverse order, to properly match our pop to the push + * in TclArgumentBCEnter(). + */ + for (word = objc-1; word >= 1; word--) { + if (ePtr->line[word] >= 0) { + Tcl_HashEntry* hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, + (char *) objv[word]); + if (hPtr) { + CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); + + if (cfwPtr->prevPtr) { + Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); + } else { + Tcl_DeleteHashEntry(hPtr); + } - ckfree(cfwPtr); - cfwPtr = nextPtr; + ckfree((char *) cfwPtr); + } + } + } + } } - - cfPtr->litarg = NULL; } /* @@ -5733,8 +4810,8 @@ TclArgumentBCRelease( * * TclArgumentGet -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * finds the location references for a Tcl_Obj, if any. + * This procedure is a helper for the TIP #280 uplevel extension. + * It find the location references for a Tcl_Obj, if any. * * Results: * None. @@ -5747,37 +4824,36 @@ TclArgumentBCRelease( */ void -TclArgumentGet( - Tcl_Interp *interp, - Tcl_Obj *obj, - CmdFrame **cfPtrPtr, - int *wordPtr) +TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) + Tcl_Interp* interp; + Tcl_Obj* obj; + CmdFrame** cfPtrPtr; + int* wordPtr; { - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - CmdFrame *framePtr; + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hPtr; + CmdFrame* framePtr; /* - * An object which either has no string rep or else is a canonical list is - * 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. + * An object which either has no string rep 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)) { + if (!obj->bytes) { return; } - + /* * First look for location information recorded in the argument * stack. That is nearest. */ - hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj); + hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) obj); if (hPtr) { - CFWord *cfwPtr = Tcl_GetHashValue(hPtr); - - *wordPtr = cfwPtr->word; + CFWord* cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); + *wordPtr = cfwPtr->word; *cfPtrPtr = cfwPtr->framePtr; return; } @@ -5787,34 +4863,37 @@ TclArgumentGet( * that stack. */ - hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj); + hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj); if (hPtr) { - CFWordBC *cfwPtr = Tcl_GetHashValue(hPtr); + CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); framePtr = cfwPtr->framePtr; - framePtr->data.tebc.pc = (char *) (((ByteCode *) - framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc); + framePtr->data.tebc.pc = (char*) ((ByteCode*) + framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc; *cfPtrPtr = cfwPtr->framePtr; - *wordPtr = cfwPtr->word; + *wordPtr = cfwPtr->word; return; } } +#endif /* *---------------------------------------------------------------------- * * 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. + * Execute a Tcl command in a string. This procedure 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 procedure 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! + * 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. @@ -5823,20 +4902,21 @@ TclArgumentGet( */ 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. */ +Tcl_Eval(interp, string) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by previous call to Tcl_CreateInterp). */ + CONST char *string; /* Pointer to TCL command to execute. */ { - int code = Tcl_EvalEx(interp, script, -1, 0); + int code = Tcl_EvalEx(interp, string, -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). + * 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); + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); return code; } @@ -5859,17 +4939,18 @@ Tcl_Eval( #undef Tcl_EvalObj int -Tcl_EvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) +Tcl_EvalObj(interp, objPtr) + Tcl_Interp * interp; + Tcl_Obj * objPtr; { return Tcl_EvalObjEx(interp, objPtr, 0); } + #undef Tcl_GlobalEvalObj int -Tcl_GlobalEvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) +Tcl_GlobalEvalObj(interp, objPtr) + Tcl_Interp * interp; + Tcl_Obj * objPtr; { return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); } @@ -5880,418 +4961,367 @@ Tcl_GlobalEvalObj( * 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. + * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT + * is specified. * * 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. + * 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. + * 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. + * + * Just as in Tcl_Eval, interp->termOffset is set to the offset of the + * last character executed in the objPtr's string. * * 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); +Tcl_EvalObjEx(interp, objPtr, flags) + 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. */ +{ +#ifdef TCL_TIP280 + 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. */ +TclEvalObjEx(interp, objPtr, flags, invoker, word) + 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; +#endif + register Interp *iPtr = (Interp *) interp; + char *script; + int numSrcBytes; int result; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - /* - * This function consists of three independent blocks for: direct - * evaluation of canonical lists, compilation and bytecode execution and - * finally direct evaluation. Precisely one of these blocks will be run. - */ - - if (TclListObjIsCanonical(objPtr)) { - Tcl_Obj *listPtr = objPtr; - CmdFrame *eoFramePtr = NULL; - int objc; - Tcl_Obj **objv; + Tcl_IncrRefCount(objPtr); + if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) { /* - * Pure List Optimization (no string representation). In this case, we - * can safely use Tcl_EvalObjv instead and get an appreciable - * improvement in execution speed. This is because it allows us to - * avoid a setFromAny step that would just pack everything into a - * string and back out again. + * We're not supposed to use the compiler or byte-code interpreter. + * Let Tcl_EvalEx evaluate the command directly (and probably + * more slowly). * - * This also preserves any associations between list elements and - * location information for such elements. + * Pure List Optimization (no string representation). In this + * case, we can safely use Tcl_EvalObjv instead and get an + * appreciable improvement in execution speed. This is because it + * allows us to avoid a setFromAny step that would just pack + * everything into a string and back out again. * - * This restriction has been relaxed a bit by storing in lists whether - * they are "canonical" or not (a canonical list being one that is - * either pure or that has its string rep derived by - * UpdateStringOfList from the internal rep). + * USE_EVAL_DIRECT is a special flag used for testing purpose only + * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt) */ + if (!(iPtr->flags & USE_EVAL_DIRECT) && + (objPtr->typePtr == &tclListType) && /* is a list... */ + (objPtr->bytes == NULL) /* ...without a string rep */) { + register List *listRepPtr = + (List *) objPtr->internalRep.twoPtrValue.ptr1; + int i, objc = listRepPtr->elemCount; + +#define TEOE_PREALLOC 10 + Tcl_Obj *staticObjv[TEOE_PREALLOC], **objv = staticObjv; + +#ifdef TCL_TIP280 + /* TIP #280 Structures for tracking lines. + * As we know that this is dynamic execution we ignore the + * invoker, even if known. + */ + CmdFrame eoFrame; + + eoFrame.type = TCL_LOCATION_EVAL_LIST; + eoFrame.level = (iPtr->cmdFramePtr == NULL ? + 1 : + iPtr->cmdFramePtr->level + 1); + eoFrame.framePtr = iPtr->framePtr; + eoFrame.nextPtr = iPtr->cmdFramePtr; + eoFrame.nline = 0; + eoFrame.line = NULL; + + /* NOTE: Getting the string rep of the list to eval to fill the + * command information required by 'info frame' implies that + * further calls for the same list would not be optimized, as it + * would not be 'pure' anymore. It would also be a waste of time + * as most of the time this information is not needed at all. What + * we do instead is to keep the list obj itself around and have + * 'info frame' sort it out. + */ - /* - * Shimmer protection! Always pass an unshared obj. The caller could - * incr the refCount of objPtr AFTER calling us! To be completely safe - * we always make a copy. The callback takes care od the refCounts for - * both listPtr and objPtr. - * - * FIXME OPT: preserve just the internal rep? - */ - - Tcl_IncrRefCount(objPtr); - listPtr = TclListObjCopy(interp, objPtr); - Tcl_IncrRefCount(listPtr); - TclDecrRefCount(objPtr); - - if (word != INT_MIN) { + eoFrame.cmd.listPtr = objPtr; + Tcl_IncrRefCount (eoFrame.cmd.listPtr); + eoFrame.data.eval.path = NULL; +#endif + if (objc > TEOE_PREALLOC) { + objv = (Tcl_Obj **) ckalloc(objc*sizeof(Tcl_Obj *)); + } +#undef TEOE_PREALLOC /* - * 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. + * Copy the list elements here, to avoid a segfault if + * objPtr loses its List internal rep [Bug 1119369]. * - * Note that we use (word==INTMIN) to signal that no command frame - * should be pushed, as needed by alias and ensemble redirections. + * TIP #280 We do _not_ compute all the line numbers for the words + * in the command. For the eval of a pure list the most sensible + * choice is to put all words on line 1. Given that we neither + * need memory for them nor compute anything. 'line' is left + * NULL. The two places using this information (TclInfoFrame, and + * TclInitCompileEnv), are special-cased to use the proper line + * number directly instead of accessing the 'line' array. */ - eoFramePtr = TclStackAlloc(interp, sizeof(CmdFrame)); - eoFramePtr->nline = 0; - eoFramePtr->line = NULL; - - eoFramePtr->type = TCL_LOCATION_EVAL_LIST; - eoFramePtr->level = (iPtr->cmdFramePtr == NULL? - 1 : iPtr->cmdFramePtr->level + 1); - eoFramePtr->numLevels = iPtr->numLevels; - eoFramePtr->framePtr = iPtr->framePtr; - eoFramePtr->nextPtr = iPtr->cmdFramePtr; - - eoFramePtr->cmd.listPtr = listPtr; - eoFramePtr->data.eval.path = NULL; - - iPtr->cmdFramePtr = eoFramePtr; - } - - TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, - NULL, NULL); - - ListObjGetElements(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). - * - * TIP #280. Propagate context as much as we can. Especially if the - * script to evaluate is a single literal it makes sense to look if - * our context is one with absolute line numbers we can then track - * into the literal itself too. - * - * See also tclCompile.c, TclInitCompileEnv, for the equivalent code - * in the bytecode compiler. - */ - - const char *script; - 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. - */ + for (i=0; i < objc; i++) { + objv[i] = listRepPtr->elements[i]; + Tcl_IncrRefCount(objv[i]); + } - ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; - ContLineLoc *clLocPtr = TclContinuationsGet(objPtr); +#ifdef TCL_TIP280 + iPtr->cmdFramePtr = &eoFrame; +#endif + result = Tcl_EvalObjv(interp, objc, objv, flags); +#ifdef TCL_TIP280 + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + Tcl_DecrRefCount (eoFrame.cmd.listPtr); +#endif - if (clLocPtr) { - iPtr->scriptCLLocPtr = clLocPtr; - Tcl_Preserve(iPtr->scriptCLLocPtr); + for (i=0; i < objc; i++) { + TclDecrRefCount(objv[i]); + } + if (objv != staticObjv) { + ckfree((char *) objv); + } +#ifdef TCL_TIP280 + ckfree ((char*) eoFrame.line); + eoFrame.line = NULL; + eoFrame.nline = 0; +#endif } else { - iPtr->scriptCLLocPtr = NULL; - } - - Tcl_IncrRefCount(objPtr); - if (invoker == NULL) { - /* - * No context, force opening of our own. - */ - +#ifndef TCL_TIP280 script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } else { +#else /* - * We have an invoker, describing the command asking for the - * evaluation of a subordinate script. This script may originate - * in a literal word, or from a variable, etc. Using the line - * array we now check if we have good line information for the - * relevant word. The type of context is relevant as well. In a - * non-'source' context we don't have to try tracking lines. + * TIP #280. Propagate context as much as we can. Especially if + * the script to evaluate is a single literal it makes sense to + * look if our context is one with absolute line numbers we can + * then track into the literal itself too. * - * First see if the word exists and is a literal. If not we go - * through the easy dynamic branch. No need to perform more - * complex invokations. + * See also tclCompile.c, TclInitCompileEnv, for the equivalent + * code in the bytecode compiler. */ - int pc = 0; - CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + /* + * 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. + */ - *ctxPtr = *invoker; - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctxPtr->data.eval.path is not used. - * ctxPtr->data.tebc.codePtr is used instead. - */ + ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr; + ContLineLoc* clLocPtr = TclContinuationsGet (objPtr); - TclGetSrcInfoForPc(ctxPtr); - pc = 1; + if (clLocPtr) { + iPtr->scriptCLLocPtr = clLocPtr; + Tcl_Preserve (iPtr->scriptCLLocPtr); + } else { + iPtr->scriptCLLocPtr = NULL; } - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - - if ((invoker->nline <= word) || - (invoker->line[word] < 0) || - (ctxPtr->type != TCL_LOCATION_SOURCE)) { - /* - * Dynamic script, or dynamic context, force our own context. - */ - + if (invoker == NULL) { + /* No context, force opening of our own */ + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); } else { - /* - * Absolute context to reuse. + /* We have an invoker, describing the command asking for the + * evaluation of a subordinate script. This script may + * originate in a literal word, or from a variable, etc. Using + * the line array we now check if we have good line + * information for the relevant word. The type of context is + * relevant as well. In a non-'source' context we don't have + * to try tracking lines. + * + * First see if the word exists and is a literal. If not we go + * through the easy dynamic branch. No need to perform more + * complex invokations. */ - iPtr->invokeCmdFramePtr = ctxPtr; - iPtr->evalFlags |= TCL_EVAL_CTX; + CmdFrame ctx = *invoker; + int pc = 0; + + if (invoker->type == TCL_LOCATION_BC) { + /* Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr is used instead. + */ + TclGetSrcInfoForPc (&ctx); + pc = 1; + } + + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = TclEvalEx(interp, script, numSrcBytes, flags, - ctxPtr->line[word], NULL, script); + if ((ctx.nline <= word) || + (ctx.line[word] < 0) || + (ctx.type != TCL_LOCATION_SOURCE)) { + /* Dynamic script, or dynamic context, force our own + * context */ + + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + } else { + /* Absolute context available to reuse. */ + + iPtr->invokeCmdFramePtr = &ctx; + iPtr->evalFlags |= TCL_EVAL_CTX; + + result = EvalEx(interp, script, numSrcBytes, flags, + ctx.line [word], NULL, script); + } + if (pc && (ctx.type == TCL_LOCATION_SOURCE)) { + /* Death of SrcInfo reference. */ + Tcl_DecrRefCount(ctx.data.eval.path); + } } - if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { - /* - * Death of SrcInfo reference. - */ - Tcl_DecrRefCount(ctxPtr->data.eval.path); + /* + * Now release the lock on the continuation line information, if + * any, and restore the caller's settings. + */ + + if (iPtr->scriptCLLocPtr) { + Tcl_Release (iPtr->scriptCLLocPtr); } - TclStackFree(interp, ctxPtr); + iPtr->scriptCLLocPtr = saveCLLocPtr; +#endif } - + } else { /* - * Now release the lock on the continuation line information, if any, - * and restore the caller's settings. + * 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. */ - if (iPtr->scriptCLLocPtr) { - Tcl_Release(iPtr->scriptCLLocPtr); - } - iPtr->scriptCLLocPtr = saveCLLocPtr; - TclDecrRefCount(objPtr); - 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); + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; } - if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { - const char *script; - int numSrcBytes; - ProcessUnexpectedResult(interp, result); - result = TCL_ERROR; - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - Tcl_LogCommandInfo(interp, script, script, numSrcBytes); - } +#ifndef TCL_TIP280 + result = TclCompEvalObj(interp, objPtr); +#else + result = TclCompEvalObj(interp, objPtr, invoker, word); +#endif /* - * We are returning to level 0, so should call TclResetCancellation. - * Let us just unset the flags inline. + * If we are again at the top level, process any unusual + * return code returned by the evaluated code. */ + + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR) + && !allowExceptions) { + ProcessUnexpectedResult(interp, result); + result = TCL_ERROR; - TclUnsetCancelFlags(iPtr); - } - iPtr->evalFlags = 0; - - /* - * Restore the callFrame if this was a TCL_EVAL_GLOBAL. - */ + /* + * If an error was created here, record information about + * what was being executed when the error occurred. Remove + * the extra \n added by tclMain.c in the command sent to + * Tcl_LogCommandInfo [Bug 833150]. + */ - if (savedVarFramePtr) { - iPtr->varFramePtr = savedVarFramePtr; + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, --numSrcBytes); + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } + } + } + iPtr->evalFlags = 0; + iPtr->varFramePtr = savedVarFramePtr; } TclDecrRefCount(objPtr); return result; } - -static int -TEOEx_ListCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr = data[0]; - CmdFrame *eoFramePtr = data[1]; - - /* - * Remove the cmdFrame - */ - - if (eoFramePtr) { - iPtr->cmdFramePtr = eoFramePtr->nextPtr; - TclStackFree(interp, eoFramePtr); - } - TclDecrRefCount(listPtr); - - return result; -} /* *---------------------------------------------------------------------- * * 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. + * Procedure 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. + * 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 +ProcessUnexpectedResult(interp, returnCode) + Tcl_Interp *interp; /* The interpreter in which the unexpected * result code was returned. */ - int returnCode) /* The unexpected result code. */ + int returnCode; /* The unexpected result code. */ { - char buf[TCL_INTEGER_SPACE]; - Tcl_ResetResult(interp); if (returnCode == TCL_BREAK) { - Tcl_AppendResult(interp, - "invoked \"break\" outside of a loop", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"break\" outside of a loop", -1); } else if (returnCode == TCL_CONTINUE) { - Tcl_AppendResult(interp, - "invoked \"continue\" outside of a loop", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"continue\" outside of a loop", -1); } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "command returned bad code: %d", returnCode)); + char buf[30 + TCL_INTEGER_SPACE]; + + sprintf(buf, "command returned bad code: %d", returnCode); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } - sprintf(buf, "%d", returnCode); - Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, NULL); } /* @@ -6299,15 +5329,15 @@ ProcessUnexpectedResult( * * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- * - * Functions to evaluate an expression and return its value in a + * Procedures 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. + * Each of the procedures 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. @@ -6316,92 +5346,197 @@ ProcessUnexpectedResult( */ int -Tcl_ExprLong( - Tcl_Interp *interp, /* Context in which to evaluate the +Tcl_ExprLong(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ - const char *exprstring, /* Expression to evaluate. */ - long *ptr) /* Where to store result. */ + CONST char *string; /* Expression to evaluate. */ + long *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); int result = TCL_OK; - if (*exprstring == '\0') { - /* - * Legacy compatibility - return 0 for the zero-length string. - */ - *ptr = 0; - } else { - exprPtr = Tcl_NewStringObj(exprstring, -1); + if (length > 0) { + exprPtr = Tcl_NewStringObj(string, length); Tcl_IncrRefCount(exprPtr); - result = Tcl_ExprLongObj(interp, exprPtr, ptr); - Tcl_DecrRefCount(exprPtr); - if (result != TCL_OK) { - (void) Tcl_GetStringResult(interp); + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Store an integer based on the expression result. + */ + + if (resultPtr->typePtr == &tclIntType) { + *ptr = resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (long) resultPtr->internalRep.doubleValue; + } else if (resultPtr->typePtr == &tclWideIntType) { +#ifndef TCL_WIDE_INT_IS_LONG + /* + * See Tcl_GetIntFromObj for conversion comments. + */ + Tcl_WideInt w = resultPtr->internalRep.wideValue; + if ((w >= -(Tcl_WideInt)(ULONG_MAX)) + && (w <= (Tcl_WideInt)(ULONG_MAX))) { + *ptr = Tcl_WideAsLong(w); + } else { + Tcl_SetResult(interp, + "integer value too large to represent as non-long integer", + TCL_STATIC); + result = TCL_ERROR; + } +#else + *ptr = resultPtr->internalRep.longValue; +#endif + } else { + Tcl_SetResult(interp, + "expression didn't have numeric value", TCL_STATIC); + result = TCL_ERROR; + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } else { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + */ + + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); } + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { + /* + * An empty string. Just set the result integer to 0. + */ + + *ptr = 0; } return result; } int -Tcl_ExprDouble( - Tcl_Interp *interp, /* Context in which to evaluate the +Tcl_ExprDouble(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ - const char *exprstring, /* Expression to evaluate. */ - double *ptr) /* Where to store result. */ + CONST char *string; /* Expression to evaluate. */ + double *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); int result = TCL_OK; - if (*exprstring == '\0') { + if (length > 0) { + exprPtr = Tcl_NewStringObj(string, length); + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Store a double based on the expression result. + */ + + if (resultPtr->typePtr == &tclIntType) { + *ptr = (double) resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = resultPtr->internalRep.doubleValue; + } else if (resultPtr->typePtr == &tclWideIntType) { +#ifndef TCL_WIDE_INT_IS_LONG + /* + * See Tcl_GetIntFromObj for conversion comments. + */ + Tcl_WideInt w = resultPtr->internalRep.wideValue; + if ((w >= -(Tcl_WideInt)(ULONG_MAX)) + && (w <= (Tcl_WideInt)(ULONG_MAX))) { + *ptr = (double) Tcl_WideAsLong(w); + } else { + Tcl_SetResult(interp, + "integer value too large to represent as non-long integer", + TCL_STATIC); + result = TCL_ERROR; + } +#else + *ptr = (double) resultPtr->internalRep.longValue; +#endif + } else { + Tcl_SetResult(interp, + "expression didn't have numeric value", TCL_STATIC); + result = TCL_ERROR; + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } else { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + */ + + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); + } + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { /* - * Legacy compatibility - return 0 for the zero-length string. + * An empty string. Just set the result double to 0.0. */ - + *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. */ +Tcl_ExprBoolean(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + CONST char *string; /* 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); + register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); + int result = TCL_OK; + if (length > 0) { + exprPtr = Tcl_NewStringObj(string, length); Tcl_IncrRefCount(exprPtr); - result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); - Tcl_DecrRefCount(exprPtr); + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Store a boolean based on the expression result. + */ + + if (resultPtr->typePtr == &tclIntType) { + *ptr = (resultPtr->internalRep.longValue != 0); + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (resultPtr->internalRep.doubleValue != 0.0); + } else if (resultPtr->typePtr == &tclWideIntType) { +#ifndef TCL_WIDE_INT_IS_LONG + *ptr = (resultPtr->internalRep.wideValue != 0); +#else + *ptr = (resultPtr->internalRep.longValue != 0); +#endif + } else { + result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } if (result != TCL_OK) { /* - * Move the interpreter's object result to the string result, then - * reset the object result. + * Move the interpreter's object result to the string result, + * then reset the object result. */ - (void) Tcl_GetStringResult(interp); + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); } - return result; + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { + /* + * An empty string. Just set the result boolean to 0 (false). + */ + + *ptr = 0; } + return result; } /* @@ -6409,15 +5544,16 @@ Tcl_ExprBoolean( * * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- * - * Functions to evaluate an expression in an object and return its value - * in a particular form. + * Procedures 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. + * Each of the procedures 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. @@ -6426,104 +5562,79 @@ Tcl_ExprBoolean( */ 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_ExprLongObj(interp, objPtr, ptr) + 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; + int result; 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; + if (result == TCL_OK) { + if (resultPtr->typePtr == &tclIntType) { + *ptr = resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (long) resultPtr->internalRep.doubleValue; + } else { + result = Tcl_GetLongFromObj(interp, resultPtr, ptr); + if (result != TCL_OK) { + return result; + } } - resultPtr = Tcl_NewBignumObj(&big); - /* FALLTHROUGH */ + Tcl_DecrRefCount(resultPtr); /* discard the result object */ } - 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_ExprDoubleObj(interp, objPtr, ptr) + 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; + int result; 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: + if (resultPtr->typePtr == &tclIntType) { + *ptr = (double) resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = resultPtr->internalRep.doubleValue; + } else { result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); + if (result != TCL_OK) { + return result; + } } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ } - 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_ExprBooleanObj(interp, objPtr, ptr) + 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. */ + if (resultPtr->typePtr == &tclIntType) { + *ptr = (resultPtr->internalRep.longValue != 0); + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (resultPtr->internalRep.doubleValue != 0.0); + } else { + result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ } return result; } @@ -6531,14 +5642,12 @@ Tcl_ExprBooleanObj( /* *---------------------------------------------------------------------- * - * TclObjInvokeNamespace -- + * TclInvoke -- * - * 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. + * Invokes a Tcl command, given an argv/argc, from either the + * exposed or the hidden sets of commands in the given interpreter. + * NOTE: The command is invoked in the current stack frame of + * the interpreter, thus it can modify local variables. * * Results: * A standard Tcl result. @@ -6550,2546 +5659,1141 @@ Tcl_ExprBooleanObj( */ 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. */ +TclInvoke(interp, argc, argv, flags) + Tcl_Interp *interp; /* Where to invoke the command. */ + int argc; /* Count of args. */ + register CONST char **argv; /* The arg strings; argv[0] is the name of + * the command to invoke. */ + int flags; /* Combination of flags controlling the + * call: TCL_INVOKE_HIDDEN and + * TCL_INVOKE_NO_UNKNOWN. */ { - int result; - Tcl_CallFrame *framePtr; + register Tcl_Obj *objPtr; + register int i; + int length, result; /* - * Make the specified namespace the current namespace and invoke the - * command. + * This procedure generates an objv array for object arguments that hold + * the argv strings. It starts out with stack-allocated space but uses + * dynamically-allocated storage if needed. */ - result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0); - if (result != TCL_OK) { - return TCL_ERROR; - } - - 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. */ -{ - register Interp *iPtr = (Interp *) interp; - Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ - const char *cmdName; /* Name of the command from objv[0]. */ - Tcl_HashEntry *hPtr = NULL; - Command *cmdPtr; - int result; - - if (interp == NULL) { - return TCL_ERROR; - } +#define NUM_ARGS 20 + Tcl_Obj *(objStorage[NUM_ARGS]); + register Tcl_Obj **objv = objStorage; - if ((objc < 1) || (objv == NULL)) { - Tcl_AppendResult(interp, "illegal argument vector", NULL); - return TCL_ERROR; - } - - if ((flags & TCL_INVOKE_HIDDEN) == 0) { - Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); - } + /* + * Create the object argument array "objv". Make sure objv is large + * enough to hold the objc arguments plus 1 extra for the zero + * end-of-objv word. + */ - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; + if ((argc + 1) > NUM_ARGS) { + objv = (Tcl_Obj **) + ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); } - cmdName = TclGetString(objv[0]); - hTblPtr = iPtr->hiddenCmdTablePtr; - if (hTblPtr != NULL) { - hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); - } - if (hPtr == NULL) { - Tcl_AppendResult(interp, "invalid hidden command name \"", - cmdName, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName, - NULL); - return TCL_ERROR; + for (i = 0; i < argc; i++) { + length = strlen(argv[i]); + objv[i] = Tcl_NewStringObj(argv[i], length); + Tcl_IncrRefCount(objv[i]); } - cmdPtr = Tcl_GetHashValue(hPtr); + objv[argc] = 0; /* - * Invoke the command function. + * Use TclObjInterpProc to actually invoke the command. */ - iPtr->cmdCount++; - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, objc, objv); - } + result = TclObjInvoke(interp, argc, objv, flags); /* - * If an error occurred, record information about what was being executed - * when the error occurred. + * Move the interpreter's object result to the string result, + * then reset the object result. */ + + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); - if ((result == TCL_ERROR) - && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) - && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { - int length; - Tcl_Obj *command = Tcl_NewListObj(objc, objv); - const char *cmdString; - - Tcl_IncrRefCount(command); - cmdString = Tcl_GetStringFromObj(command, &length); - Tcl_LogCommandInfo(interp, cmdString, cmdString, length); - Tcl_DecrRefCount(command); - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } - 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. - */ + /* + * Decrement the ref counts on the objv elements since we are done + * with them. + */ - 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); - } + for (i = 0; i < argc; i++) { + objPtr = objv[i]; + Tcl_DecrRefCount(objPtr); } - + /* - * Force the string rep of the interp result. + * Free the objv array if malloc'ed storage was used. */ - (void) Tcl_GetStringResult(interp); - return code; + if (objv != objStorage) { + ckfree((char *) objv); + } + return result; +#undef NUM_ARGS } /* *---------------------------------------------------------------------- * - * Tcl_AppendObjToErrorInfo -- + * TclGlobalInvoke -- * - * Add a Tcl_Obj value to the errorInfo field that describes the current - * error. + * Invokes a Tcl command, given an argv/argc, from either the + * exposed or hidden sets of commands in the given interpreter. + * NOTE: The command is invoked in the global stack frame of + * the interpreter, thus it cannot see any current state on + * the stack for that interpreter. * * Results: - * None. + * A standard Tcl result. * * 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. + * Whatever the command does. * *---------------------------------------------------------------------- */ -void -Tcl_AppendObjToErrorInfo( - Tcl_Interp *interp, /* Interpreter to which error information - * pertains. */ - Tcl_Obj *objPtr) /* Message to record. */ +int +TclGlobalInvoke(interp, argc, argv, flags) + Tcl_Interp *interp; /* Where to invoke the command. */ + int argc; /* Count of args. */ + register CONST char **argv; /* The arg strings; argv[0] is the name of + * the command to invoke. */ + int flags; /* Combination of flags controlling the + * call: TCL_INVOKE_HIDDEN and + * TCL_INVOKE_NO_UNKNOWN. */ { - int length; - const char *message = TclGetStringFromObj(objPtr, &length); + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; - Tcl_IncrRefCount(objPtr); - Tcl_AddObjErrorInfo(interp, message, length); - Tcl_DecrRefCount(objPtr); + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = TclInvoke(interp, argc, argv, flags); + iPtr->varFramePtr = savedVarFramePtr; + return result; } /* *---------------------------------------------------------------------- * - * Tcl_AddErrorInfo -- + * TclObjInvokeGlobal -- * - * Add information to the errorInfo field that describes the current - * error. + * 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, thus it cannot see any current state on the + * stack of that interpreter. * * Results: - * None. + * A standard Tcl result. * * 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. + * Whatever the command does. * *---------------------------------------------------------------------- */ -void -Tcl_AddErrorInfo( - Tcl_Interp *interp, /* Interpreter to which error information - * pertains. */ - const char *message) /* Message to record. */ +int +TclObjInvokeGlobal(interp, objc, objv, flags) + 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. */ { - Tcl_AddObjErrorInfo(interp, message, -1); + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = TclObjInvoke(interp, objc, objv, flags); + iPtr->varFramePtr = savedVarFramePtr; + return result; } /* *---------------------------------------------------------------------- * - * Tcl_AddObjErrorInfo -- + * TclObjInvoke -- * - * Add information to the errorInfo field that describes the current - * error. This routine differs from Tcl_AddErrorInfo by taking a byte - * pointer and length. + * Invokes a Tcl command, given an objv/objc, from either the + * exposed or the hidden sets of commands in the given interpreter. * * Results: - * None. + * A standard Tcl object result. * * 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. + * Whatever the command does. * *---------------------------------------------------------------------- */ -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. */ +int +TclObjInvoke(interp, objc, objv, flags) + 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. */ { register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + char *cmdName; /* Name of the command from objv[0]. */ + register Tcl_HashEntry *hPtr; + Tcl_Command cmd; + Command *cmdPtr; + int localObjc; /* Used to invoke "unknown" if the */ + Tcl_Obj **localObjv = NULL; /* command is not found. */ + register int i; + int result; + + if (interp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + + if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "illegal argument vector", -1); + return TCL_ERROR; + } + + cmdName = Tcl_GetString(objv[0]); + if (flags & TCL_INVOKE_HIDDEN) { + /* + * We never invoke "unknown" for hidden commands. + */ + + hPtr = NULL; + hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr; + if (hTblPtr != NULL) { + hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); + } + if (hPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid hidden command name \"", cmdName, "\"", + (char *) NULL); + return TCL_ERROR; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + } else { + cmdPtr = NULL; + cmd = Tcl_FindCommand(interp, cmdName, + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + if (cmd != (Tcl_Command) NULL) { + cmdPtr = (Command *) cmd; + } + if (cmdPtr == NULL) { + if (!(flags & TCL_INVOKE_NO_UNKNOWN)) { + cmd = Tcl_FindCommand(interp, "unknown", + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + if (cmd != (Tcl_Command) NULL) { + cmdPtr = (Command *) cmd; + } + if (cmdPtr != NULL) { + localObjc = (objc + 1); + localObjv = (Tcl_Obj **) + ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc)); + localObjv[0] = Tcl_NewStringObj("unknown", -1); + Tcl_IncrRefCount(localObjv[0]); + for (i = 0; i < objc; i++) { + localObjv[i+1] = objv[i]; + } + objc = localObjc; + objv = localObjv; + } + } + + /* + * Check again if we found the command. If not, "unknown" is + * not present and we cannot help, or the caller said not to + * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN). + */ + + if (cmdPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", cmdName, "\"", + (char *) NULL); + return TCL_ERROR; + } + } + } /* - * If we are just starting to log an error, errorInfo is initialized from - * the error message in the interpreter's result. + * Invoke the command procedure. First reset the interpreter's string + * and object results to their default empty values since they could + * have gotten changed by earlier invocations. */ - 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. - */ + Tcl_ResetResult(interp); + iPtr->cmdCount++; + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); - iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); - } else { - iPtr->errorInfo = iPtr->objResultPtr; - } - Tcl_IncrRefCount(iPtr->errorInfo); - if (!iPtr->errorCode) { - Tcl_SetErrorCode(interp, "NONE", NULL); - } + /* + * If an error occurred, record information about what was being + * executed when the error occurred. + */ + + if ((result == TCL_ERROR) + && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) + && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { + Tcl_Obj *msg; + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + msg = Tcl_NewStringObj("\n while invoking\n\"", -1); + } else { + msg = Tcl_NewStringObj("\n invoked from within\n\"", -1); + } + Tcl_IncrRefCount(msg); + for (i = 0; i < objc; i++) { + CONST char *bytes; + int length; + + Tcl_AppendObjToObj(msg, objv[i]); + bytes = Tcl_GetStringFromObj(msg, &length); + if (length > 100) { + /* + * Back up truncation point so that we don't truncate + * in the middle of a multi-byte character. + */ + length = 100; + while ( (bytes[length] & 0xC0) == 0x80 ) { + length--; + } + Tcl_SetObjLength(msg, length); + Tcl_AppendToObj(msg, "...", -1); + break; + } + if (i != (objc - 1)) { + Tcl_AppendToObj(msg, " ", -1); + } + } + + Tcl_AppendToObj(msg, "\"", -1); + Tcl_AddObjErrorInfo(interp, Tcl_GetString(msg), -1); + Tcl_DecrRefCount(msg); + iPtr->flags &= ~ERR_ALREADY_LOGGED; } /* - * Now append "message" to the end of errorInfo. + * Free any locally allocated storage used to call "unknown". */ - 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); + if (localObjv != (Tcl_Obj **) NULL) { + Tcl_DecrRefCount(localObjv[0]); + ckfree((char *) localObjv); } + return result; } /* *--------------------------------------------------------------------------- * - * Tcl_VarEvalVA -- + * Tcl_ExprString -- * - * Given a variable number of string arguments, concatenate them all - * together and execute the result as a Tcl command. + * Evaluate an expression in a string and return its value in string + * form. * * Results: - * A standard Tcl return result. An error message or other result may be - * left in the interp's result. + * 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: - * Depends on what was done by the command. + * 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_VarEvalVA( - Tcl_Interp *interp, /* Interpreter in which to evaluate command */ - va_list argList) /* Variable argument list. */ +Tcl_ExprString(interp, string) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + CONST char *string; /* Expression to evaluate. */ { - Tcl_DString buf; - char *string; - int result; + register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); + char buf[TCL_DOUBLE_SPACE]; + int result = TCL_OK; - /* - * 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. - */ + if (length > 0) { + TclNewObj(exprPtr); + TclInitStringRep(exprPtr, string, length); + Tcl_IncrRefCount(exprPtr); - Tcl_DStringInit(&buf); - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Set the interpreter's string result from the result object. + */ + + if (resultPtr->typePtr == &tclIntType) { + sprintf(buf, "%ld", resultPtr->internalRep.longValue); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else if (resultPtr->typePtr == &tclDoubleType) { + Tcl_PrintDouble((Tcl_Interp *) NULL, + resultPtr->internalRep.doubleValue, buf); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else { + /* + * Set interpreter's string result from the result object. + */ + + Tcl_SetResult(interp, TclGetString(resultPtr), + TCL_VOLATILE); + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } else { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + */ + + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); } - Tcl_DStringAppend(&buf, string, -1); + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { + /* + * An empty string. Just set the interpreter's result to 0. + */ + + Tcl_SetResult(interp, "0", TCL_VOLATILE); } - - result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); - Tcl_DStringFree(&buf); return result; } /* *---------------------------------------------------------------------- * - * Tcl_VarEval -- + * Tcl_CreateObjTrace -- * - * Given a variable number of string arguments, concatenate them all - * together and execute the result as a Tcl command. + * Arrange for a procedure to be called to trace command execution. * * Results: - * A standard Tcl return result. An error message or other result may be - * left in interp->result. + * The return value is a token for the trace, which may be passed + * to Tcl_DeleteTrace to eliminate the trace. * * Side effects: - * Depends on what was done by the command. + * From now on, proc will be called just before a command procedure + * is called to execute a Tcl command. Calls to proc will have the + * following form: + * + * void proc( ClientData clientData, + * Tcl_Interp* interp, + * int level, + * CONST char* command, + * Tcl_Command commandInfo, + * int objc, + * Tcl_Obj *CONST objv[] ); + * + * The 'clientData' and 'interp' arguments to 'proc' will be the + * same as the arguments to Tcl_CreateObjTrace. The 'level' + * argument gives the nesting depth of command interpretation within + * the interpreter. The 'command' argument is the ASCII text of + * the command being evaluated -- before any substitutions are + * performed. The 'commandInfo' argument gives a handle to the + * command procedure that will be evaluated. The 'objc' and 'objv' + * parameters give the parameter vector that will be passed to the + * command procedure. proc does not return a value. + * + * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo + * to change the command procedure or client data for the command + * being evaluated, and these changes will take effect with the + * current evaluation. + * + * The 'level' argument specifies the maximum nesting level of calls + * to be traced. If the execution depth of the interpreter exceeds + * 'level', the trace callback is not executed. + * + * The 'flags' argument is either zero or the value, + * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION + * flag is not present, the bytecode compiler will not generate inline + * code for Tcl's built-in commands. This behavior will have a significant + * impact on performance, but will ensure that all command evaluations are + * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the + * bytecode compiler will have its normal behavior of compiling in-line + * code for some of Tcl's built-in commands. In this case, the tracing + * will be imprecise -- in-line code will not be traced -- but run-time + * performance will be improved. The latter behavior is desired for + * many applications such as profiling of run time. + * + * When the trace is deleted, the 'delProc' procedure will be invoked, + * passing it the original client data. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -int -Tcl_VarEval( - Tcl_Interp *interp, - ...) -{ - va_list argList; - int result; - va_start(argList, interp); - result = Tcl_VarEvalVA(interp, argList); - va_end(argList); +Tcl_Trace +Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc ) + Tcl_Interp* interp; /* Tcl interpreter */ + int level; /* Maximum nesting level */ + int flags; /* Flags, see above */ + Tcl_CmdObjTraceProc* proc; /* Trace callback */ + ClientData clientData; /* Client data for the callback */ + Tcl_CmdObjTraceDeleteProc* delProc; + /* Procedure to call when trace is deleted */ +{ + register Trace *tracePtr; + register Interp *iPtr = (Interp *) interp; - return result; + /* Test if this trace allows inline compilation of commands */ + + if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) { + if (iPtr->tracesForbiddingInline == 0) { + + /* + * When the first trace forbidding inline compilation is + * created, invalidate existing compiled code for this + * interpreter and arrange (by setting the + * DONT_COMPILE_CMDS_INLINE flag) that when compiling new + * code, no commands will be compiled inline (i.e., into + * an inline sequence of instructions). We do this because + * commands that were compiled inline will never result in + * a command trace being called. + */ + + iPtr->compileEpoch++; + iPtr->flags |= DONT_COMPILE_CMDS_INLINE; + } + iPtr->tracesForbiddingInline++; + } + + tracePtr = (Trace *) ckalloc(sizeof(Trace)); + tracePtr->level = level; + tracePtr->proc = proc; + tracePtr->clientData = clientData; + tracePtr->delProc = delProc; + tracePtr->nextPtr = iPtr->tracePtr; + tracePtr->flags = flags; + iPtr->tracePtr = tracePtr; + + return (Tcl_Trace) tracePtr; } /* *---------------------------------------------------------------------- * - * Tcl_GlobalEval -- + * Tcl_CreateTrace -- * - * Evaluate a command at global level in an interpreter. + * Arrange for a procedure to be called to trace command execution. * * Results: - * A standard Tcl result is returned, and the interp's result is modified - * accordingly. + * The return value is a token for the trace, which may be passed + * to Tcl_DeleteTrace to eliminate the trace. * * 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. + * From now on, proc will be called just before a command procedure + * is called to execute a Tcl command. Calls to proc will have the + * following form: + * + * void + * proc(clientData, interp, level, command, cmdProc, cmdClientData, + * argc, argv) + * ClientData clientData; + * Tcl_Interp *interp; + * int level; + * char *command; + * int (*cmdProc)(); + * ClientData cmdClientData; + * int argc; + * char **argv; + * { + * } + * + * The clientData and interp arguments to proc will be the same + * as the corresponding arguments to this procedure. Level gives + * the nesting level of command interpretation for this interpreter + * (0 corresponds to top level). Command gives the ASCII text of + * the raw command, cmdProc and cmdClientData give the procedure that + * will be called to process the command and the ClientData value it + * will receive, and argc and argv give the arguments to the + * command, after any argument parsing and substitution. Proc + * does not return a value. * *---------------------------------------------------------------------- */ -int -Tcl_GlobalEval( - Tcl_Interp *interp, /* Interpreter in which to evaluate +Tcl_Trace +Tcl_CreateTrace(interp, level, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which to create trace. */ + int level; /* Only call proc for commands at nesting + * level<=argument level (1=>top level). */ + Tcl_CmdTraceProc *proc; /* Procedure to call before executing each * command. */ - const char *command) /* Command to evaluate. */ + ClientData clientData; /* Arbitrary value word to pass to proc. */ { - register Interp *iPtr = (Interp *) interp; - int result; - CallFrame *savedVarFramePtr; - - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = iPtr->rootFramePtr; - result = Tcl_Eval(interp, command); - iPtr->varFramePtr = savedVarFramePtr; - return result; + StringTraceData* data; + data = (StringTraceData*) ckalloc( sizeof( *data )); + data->clientData = clientData; + data->proc = proc; + return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc, + (ClientData) data, StringTraceDeleteProc ); } /* *---------------------------------------------------------------------- * - * Tcl_SetRecursionLimit -- + * StringTraceProc -- * - * Set the maximum number of recursive calls that may be active for an - * interpreter at once. + * Invoke a string-based trace procedure from an object-based + * callback. * * Results: - * The return value is the old limit on nesting for interp. + * None. * * Side effects: - * None. + * Whatever the string-based trace procedure does. * *---------------------------------------------------------------------- */ -int -Tcl_SetRecursionLimit( - Tcl_Interp *interp, /* Interpreter whose nesting limit is to be - * set. */ - int depth) /* New value for maximimum depth. */ +static int +StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv ) + ClientData clientData; + Tcl_Interp* interp; + int level; + CONST char* command; + Tcl_Command commandInfo; + int objc; + Tcl_Obj *CONST *objv; { - Interp *iPtr = (Interp *) interp; - int old; + StringTraceData* data = (StringTraceData*) clientData; + Command* cmdPtr = (Command*) commandInfo; - old = iPtr->maxNestingDepth; - if (depth > 0) { - iPtr->maxNestingDepth = depth; + CONST char** argv; /* Args to pass to string trace proc */ + + int i; + + /* + * This is a bit messy because we have to emulate the old trace + * interface, which uses strings for everything. + */ + + argv = (CONST char **) ckalloc((unsigned) ( (objc + 1) + * sizeof(CONST char *) )); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); } - 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. - * - *---------------------------------------------------------------------- - */ + argv[objc] = 0; -void -Tcl_AllowExceptions( - Tcl_Interp *interp) /* Interpreter in which to set flag. */ -{ - Interp *iPtr = (Interp *) interp; + /* + * Invoke the command procedure. Note that we cast away const-ness + * on two parameters for compatibility with legacy code; the code + * MUST NOT modify either command or argv. + */ + + ( data->proc )( data->clientData, interp, level, + (char*) command, cmdPtr->proc, cmdPtr->clientData, + objc, argv ); + ckfree( (char*) argv ); - iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; + return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_GetVersion -- + * StringTraceDeleteProc -- * - * 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. + * Clean up memory when a string-based trace is deleted. * * Results: * None. * * Side effects: - * None. + * Allocated memory is returned to the system. * *---------------------------------------------------------------------- */ -void -Tcl_GetVersion( - int *majorV, - int *minorV, - int *patchLevelV, - int *type) +static void +StringTraceDeleteProc( clientData ) + ClientData clientData; { - 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; - } + ckfree( (char*) clientData ); } /* *---------------------------------------------------------------------- * - * Math Functions -- + * Tcl_DeleteTrace -- * - * This page contains the functions that implement all of the built-in - * math functions for expressions. + * Remove a trace. * * 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. + * None. * * Side effects: - * None. + * From now on there will be no more calls to the procedure given + * in trace. * *---------------------------------------------------------------------- */ -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 (Tcl_GetWideIntFromObj(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_SetResult(interp, "square root of negative argument", TCL_STATIC); - 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 NO_WIDE_TYPE - 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 (Tcl_GetWideIntFromObj(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); - Tcl_GetWideIntFromObj(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. */ +void +Tcl_DeleteTrace(interp, trace) + Tcl_Interp *interp; /* Interpreter that contains trace. */ + Tcl_Trace trace; /* Token for trace (returned previously by + * Tcl_CreateTrace). */ { 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; - } - } + Trace *prevPtr, *tracePtr = (Trace *) trace; + register Trace **tracePtr2 = &(iPtr->tracePtr); + ActiveInterpTrace *activePtr; /* - * 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. + * Locate the trace entry in the interpreter's trace list, + * and remove it from the list. */ -#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; + prevPtr = NULL; + while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { + prevPtr = *tracePtr2; + tracePtr2 = &((*tracePtr2)->nextPtr); } + if (*tracePtr2 == NULL) { + return; + } + (*tracePtr2) = (*tracePtr2)->nextPtr; /* - * 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. + * The code below makes it possible to delete traces while traces + * are active: it makes sure that the deleted trace won't be + * processed by TclCheckInterpTraces. */ - 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++; + for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + if (activePtr->reverseScan) { + activePtr->nextTracePtr = prevPtr; + } else { + activePtr->nextTracePtr = tracePtr->nextPtr; } - 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 the trace forbids bytecode compilation, change the interpreter's + * state. If bytecode compilation is now permitted, flag the fact and + * advance the compilation epoch so that procs will be recompiled to + * take advantage of it. */ - 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; + if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) { + iPtr->tracesForbiddingInline--; + if (iPtr->tracesForbiddingInline == 0) { + iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; + iPtr->compileEpoch++; } - - 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. + * Execute any delete callback. */ - iPtr->flags |= RAND_SEED_INITIALIZED; - iPtr->randSeed = i; - iPtr->randSeed &= (unsigned long) 0x7fffffff; - if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { - iPtr->randSeed ^= 123459876; + if (tracePtr->delProc != NULL) { + (tracePtr->delProc)(tracePtr->clientData); } - /* - * 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. - */ + /* Delete the trace object */ - return ExprRandFunc(clientData, interp, 1, objv); + Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC); } /* *---------------------------------------------------------------------- * - * MathFuncWrongNumArgs -- + * Tcl_AddErrorInfo -- * - * Generate an error message when a math function presents the wrong - * number of arguments. + * Add information to the "errorInfo" variable that describes the + * current error. * * Results: * None. * * Side effects: - * An error message is stored in the interpreter result. + * The contents of message are added to the "errorInfo" variable. + * If Tcl_Eval has been called since the current value of errorInfo + * was set, errorInfo is cleared before adding the new message. + * If we are just starting to log an error, errorInfo is initialized + * from the error message in the interpreter's 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. */ +void +Tcl_AddErrorInfo(interp, message) + Tcl_Interp *interp; /* Interpreter to which error information + * pertains. */ + CONST char *message; /* Message to record. */ { - const char *name = Tcl_GetString(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); + Tcl_AddObjErrorInfo(interp, message, -1); } -#ifdef USE_DTRACE /* *---------------------------------------------------------------------- * - * DTraceObjCmd -- + * Tcl_AddObjErrorInfo -- * - * This function is invoked to process the "::tcl::dtrace" Tcl command. + * Add information to the "errorInfo" variable that describes the + * current error. This routine differs from Tcl_AddErrorInfo by + * taking a byte pointer and length. * * Results: - * A standard Tcl object result. + * None. * * Side effects: - * The 'tcl-probe' DTrace probe is triggered (if it is enabled). + * "length" bytes from "message" are added to the "errorInfo" variable. + * If "length" is negative, use bytes up to the first NULL byte. + * If Tcl_EvalObj has been called since the current value of errorInfo + * was set, errorInfo is cleared before adding the new message. + * If we are just starting to log an error, errorInfo is initialized + * from the error message in the interpreter's result. * *---------------------------------------------------------------------- */ -static int -DTraceObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +void +Tcl_AddObjErrorInfo(interp, message, length) + 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. */ { - if (TCL_DTRACE_TCL_PROBE_ENABLED()) { - char *a[10]; - int i = 0; + register Interp *iPtr = (Interp *) interp; + Tcl_Obj *objPtr; + + /* + * If we are just starting to log an error, errorInfo is initialized + * from the error message in the interpreter's result. + */ - while (i++ < 10) { - a[i-1] = i < objc ? TclGetString(objv[i]) : NULL; + if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ + iPtr->flags |= ERR_IN_PROGRESS; + + if (iPtr->result[0] == 0) { + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, + iPtr->objResultPtr, TCL_GLOBAL_ONLY); + } else { /* use the string result */ + objPtr = Tcl_NewStringObj(interp->result, -1); + Tcl_IncrRefCount(objPtr); + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, + objPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objPtr); + } + + /* + * If the errorCode variable wasn't set by the code that generated + * the error, set it to "NONE". + */ + + if (!(iPtr->flags & ERROR_CODE_SET)) { + objPtr = Tcl_NewStringObj("NONE", -1); + Tcl_IncrRefCount(objPtr); + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL, + objPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objPtr); } - 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; + + /* + * Now append "message" to the end of errorInfo. + */ + + if (length != 0) { + objPtr = Tcl_NewStringObj(message, length); + Tcl_IncrRefCount(objPtr); + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, + objPtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); + Tcl_DecrRefCount(objPtr); /* free msg object appended above */ + } } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclDTraceInfo -- + * Tcl_VarEvalVA -- * - * Extract information from a TIP280 dict for use by DTrace probes. + * Given a variable number of string arguments, concatenate them + * all together and execute the result as a Tcl command. * * Results: - * None. + * A standard Tcl return result. An error message or other result may + * be left in the interp's result. * * Side effects: - * None. + * Depends on what was done by the command. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -void -TclDTraceInfo( - Tcl_Obj *info, - const char **args, - int *argsi) +int +Tcl_VarEvalVA (interp, argList) + Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ + va_list argList; /* Variable argument list. */ { - 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; + 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_Eval(interp, Tcl_DStringValue(&buf)); + Tcl_DStringFree(&buf); + return result; } /* *---------------------------------------------------------------------- * - * DTraceCmdReturn -- + * Tcl_VarEval -- * - * NR callback for DTrace command return probes. + * Given a variable number of string arguments, concatenate them + * all together and execute the result as a Tcl command. * * Results: - * None. + * A standard Tcl return result. An error message or other + * result may be left in interp->result. * * Side effects: - * None. + * Depends on what was done by the command. * *---------------------------------------------------------------------- */ - -static int -DTraceCmdReturn( - ClientData data[], - Tcl_Interp *interp, - int result) + /* VARARGS2 */ /* ARGSUSED */ +int +Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) { - char *cmdName = TclGetString((Tcl_Obj *) data[0]); + Tcl_Interp *interp; + va_list argList; + int result; - if (TCL_DTRACE_CMD_RETURN_ENABLED()) { - TCL_DTRACE_CMD_RETURN(cmdName, result); - } - if (TCL_DTRACE_CMD_RESULT_ENABLED()) { - Tcl_Obj *r = Tcl_GetObjResult(interp); + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + result = Tcl_VarEvalVA(interp, argList); + va_end(argList); - TCL_DTRACE_CMD_RESULT(cmdName, result, TclGetString(r), r); - } return result; } - -TCL_DTRACE_DEBUG_LOG() - -#endif /* USE_DTRACE */ /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * Tcl_NRCallObjProc -- + * Tcl_GlobalEval -- * - * 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. + * Evaluate a command at global level in an interpreter. * * 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. + * A standard Tcl result is returned, and the interp's result is + * modified accordingly. * * Side effects: - * Depends on the objProc. + * The command string is executed in interp, and the execution + * is carried out in the variable context of global level (no + * procedures active), just as if an "uplevel #0" command were + * being executed. * - *---------------------------------------------------------------------- + --------------------------------------------------------------------------- */ int -Tcl_NRCallObjProc( - Tcl_Interp *interp, - Tcl_ObjCmdProc *objProc, - ClientData clientData, - int objc, - Tcl_Obj *const objv[]) +Tcl_GlobalEval(interp, command) + Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ + CONST char *command; /* Command to evaluate. */ { - int result = TCL_OK; - NRE_callback *rootPtr = TOP_CB(interp); - -#ifdef USE_DTRACE - if (TCL_DTRACE_CMD_ARGS_ENABLED()) { - const char *a[10]; - int i = 0; - - while (i < 10) { - a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; - } - TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], - a[8], a[9]); - } - if (TCL_DTRACE_CMD_INFO_ENABLED() && ((Interp *) interp)->cmdFramePtr) { - Tcl_Obj *info = TclInfoFrame(interp, ((Interp *) interp)->cmdFramePtr); - const char *a[6]; int i[2]; + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; - TclDTraceInfo(info, a, i); - TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); - TclDecrRefCount(info); - } - if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) - && objc) { - TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); - } - if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } -#endif /* USE_DTRACE */ - result = objProc(clientData, interp, objc, objv); - return TclNRRunCallbacks(interp, result, rootPtr); + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = Tcl_Eval(interp, command); + iPtr->varFramePtr = savedVarFramePtr; + return result; } /* *---------------------------------------------------------------------- * - * Tcl_NRCreateCommand -- + * Tcl_SetRecursionLimit -- * - * Define a new NRE-enabled object-based command in a command table. + * Set the maximum number of recursive calls that may be active + * for an interpreter at once. * * Results: - * The return value is a token for the command, which can be used in - * future calls to Tcl_GetCommandName. + * The return value is the old limit on nesting for interp. * * 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. + * None. * *---------------------------------------------------------------------- */ -Tcl_Command -Tcl_NRCreateCommand( - Tcl_Interp *interp, /* Token for command interpreter (returned by - * previous call to Tcl_CreateInterp). */ - const char *cmdName, /* Name of command. If it contains namespace - * qualifiers, the new command is put in the - * specified namespace; otherwise it is put in - * the global namespace. */ - Tcl_ObjCmdProc *proc, /* Object-based function to associate with - * name, provides direct access for direct - * calls. */ - Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with - * name, provides NR implementation */ - ClientData clientData, /* Arbitrary value to pass to object - * function. */ - Tcl_CmdDeleteProc *deleteProc) - /* If not NULL, gives a function to call when - * this command is deleted. */ -{ - Command *cmdPtr = (Command *) - Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); - - cmdPtr->nreProc = nreProc; - return (Tcl_Command) cmdPtr; -} - -/**************************************************************************** - * Stuff for the public api - ****************************************************************************/ - -int -Tcl_NREvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - int flags) -{ - return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN); -} - -int -Tcl_NREvalObjv( - Tcl_Interp *interp, /* Interpreter in which to evaluate the - * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ - Tcl_Obj *const objv[], /* An array of pointers to objects that are - * the words that make up the command. */ - int flags) /* Collection of OR-ed bits that control the - * evaluation of the script. Only - * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and - * TCL_EVAL_NOERR are currently supported. */ -{ - return TclNREvalObjv(interp, objc, objv, flags, NULL); -} - -int -Tcl_NRCmdSwap( - Tcl_Interp *interp, - Tcl_Command cmd, - int objc, - Tcl_Obj *const objv[], - int flags) -{ - return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd); -} - -/***************************************************************************** - * Stuff for tailcalls - ***************************************************************************** - * - * Just to show that IT CAN BE DONE! The precise semantics are not simple, - * require more thought. Possibly need a new Tcl return code to do it right? - * Questions include: - * (1) How is the objc/objv tailcall to be run? My current thinking is that - * it should essentially be - * [tailcall a b c] <=> [uplevel 1 [list a b c]] - * with two caveats - * (a) the current frame is dropped first, after running all pending - * cleanup tasks and saving its namespace - * (b) 'a' is looked up in the returning frame's namespace, but the - * command is run in the context to which we are returning - * Current implementation does this if [tailcall] is called from within - * a proc, errors otherwise. - * (2) Should a tailcall bypass [catch] in the returning frame? Current - * implementation does not (or does it? Changed, test!) - it causes an - * error. - * - * FIXME NRE! - */ - -void -TclSpliceTailcall( - Tcl_Interp *interp, - NRE_callback *tailcallPtr) -{ - /* - * Find the splicing spot: right before the NRCommand of the thing - * being tailcalled. Note that we skip NRCommands marked in data[1] - * (used by command redirectors). - */ - - NRE_callback *runPtr; - - for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { - if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { - break; - } - } - if (!runPtr) { - Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); - } - - tailcallPtr->nextPtr = runPtr->nextPtr; - runPtr->nextPtr = tailcallPtr; -} - -int -TclNRTailcallObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - - if (objc < 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?"); - return TCL_ERROR; - } - - if (!iPtr->varFramePtr->isProcCallFrame) { /* or is upleveled */ - Tcl_SetResult(interp, - "tailcall can only be called from a proc or lambda", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); - return TCL_ERROR; - } - - /* - * Invocation without args just clears a scheduled tailcall; invocation - * with an argument replaces any previously scheduled tailcall. - */ - - if (iPtr->varFramePtr->tailcallPtr) { - ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr); - iPtr->varFramePtr->tailcallPtr = NULL; - } - - /* - * Create the callback to actually evaluate the tailcalled - * command, then set it in the varFrame so that PopCallFrame can use it - * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to - * build the callback. - */ - - if (objc > 1) { - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; - NRE_callback *tailcallPtr; - - listPtr = Tcl_NewListObj(objc-1, objv+1); - Tcl_IncrRefCount(listPtr); - - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("Tailcall failed to find the proper namespace"); - } - Tcl_IncrRefCount(nsObjPtr); - - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, - NULL, NULL); - tailcallPtr = TOP_CB(interp); - TOP_CB(interp) = tailcallPtr->nextPtr; - iPtr->varFramePtr->tailcallPtr = tailcallPtr; - } - return TCL_RETURN; -} - int -NRTailcallEval( - ClientData data[], - Tcl_Interp *interp, - int result) +Tcl_SetRecursionLimit(interp, depth) + Tcl_Interp *interp; /* Interpreter whose nesting limit + * is to be set. */ + int depth; /* New value for maximimum depth. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr = data[0]; - Tcl_Obj *nsObjPtr = data[1]; - Tcl_Namespace *nsPtr; - int objc; - Tcl_Obj **objv; - - if (result == TCL_OK) { - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - } - - if (result != TCL_OK) { - /* - * Tailcall execution was preempted, eg by an intervening catch or by - * a now-gone namespace: cleanup and return. - */ - - TailcallCleanup(data, interp, result); - return result; - } - - /* - * Perform the tailcall - */ - - TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL); - iPtr->lookupNsPtr = (Namespace *) nsPtr; - ListObjGetElements(listPtr, objc, objv); - return TclNREvalObjv(interp, objc, objv, 0, NULL); -} - -static int -TailcallCleanup( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Tcl_DecrRefCount((Tcl_Obj *) data[0]); - Tcl_DecrRefCount((Tcl_Obj *) data[1]); - return result; -} - -static void -ClearTailcall( - Tcl_Interp *interp, - NRE_callback *tailcallPtr) -{ - TailcallCleanup(tailcallPtr->data, interp, TCL_OK); - TCLNR_FREE(interp, tailcallPtr); -} + int old; - -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?!"); + old = iPtr->maxNestingDepth; + if (depth > 0) { + iPtr->maxNestingDepth = depth; } - TclNRAddCallback(interp, postProcPtr, data0, data1, data2, data3); + return old; } /* *---------------------------------------------------------------------- * - * TclNRCoroutineObjCmd -- (and friends) + * Tcl_AllowExceptions -- * - * This object-based function is invoked to process the "coroutine" Tcl - * command. It is heavily based on "apply". + * 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: - * A standard Tcl object result value. + * None. * * Side effects: - * A new procedure gets created. + * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's + * evalFlags structure. See the reference documentation for + * more details. * - * ** 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_SetResult(interp, "yield can only be called in a coroutine", - TCL_STATIC); - 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, NRCoroutineActivateCallback, corPtr, - clientData, NULL, NULL); - return TCL_OK; -} - -int -TclNRYieldToObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); - return TCL_ERROR; - } - - if (!corPtr) { - Tcl_SetResult(interp, "yieldto can only be called in a coroutine", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); - return TCL_ERROR; - } - - /* - * Add the tailcall in the caller env, then just yield. - * - * This is essentially code from TclNRTailcallObjCmd - */ - - listPtr = Tcl_NewListObj(objc-1, objv+1); - Tcl_IncrRefCount(listPtr); - - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("yieldto failed to find the proper namespace"); - } - Tcl_IncrRefCount(nsObjPtr); - - /* - * Add the callback in the caller's env, then instruct TEBC to yield. - */ - - iPtr->execEnvPtr = corPtr->callerEEPtr; - TclNRAddCallback(interp, YieldToCallback, corPtr, listPtr, nsObjPtr, - NULL); - iPtr->execEnvPtr = corPtr->eePtr; - - return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); -} - -static int -YieldToCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* CoroutineData *corPtr = data[0];*/ - Tcl_Obj *listPtr = data[1]; - ClientData nsPtr = data[2]; - NRE_callback *cbPtr; - - /* - * yieldTo: invoke the command using tailcall tech. - */ - - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL); - cbPtr = TOP_CB(interp); - TOP_CB(interp) = cbPtr->nextPtr; - - TclSpliceTailcall(interp, cbPtr); - return TCL_OK; -} - -static int -RewindCoroutineCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - return Tcl_RestoreInterpState(interp, data[0]); -} - -static int -RewindCoroutine( - CoroutineData *corPtr, - int result) +void +Tcl_AllowExceptions(interp) + Tcl_Interp *interp; /* Interpreter in which to set flag. */ { - 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); + Interp *iPtr = (Interp *) interp; - corPtr->eePtr->rewind = 1; - TclNRAddCallback(interp, RewindCoroutineCallback, state, - NULL, NULL, NULL); - return NRInterpCoroutine(corPtr, interp, 0, NULL); + iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; } - -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; -} /* *---------------------------------------------------------------------- * - * NRCoroutineActivateCallback -- - * - * This is the workhorse for coroutines: it implements both yield and - * resume. + * Tcl_GetVersion * - * 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. - * - *---------------------------------------------------------------------- - */ - -static int -NRCoroutineActivateCallback( - 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_SetResult(interp, "cannot yield: C stack busy", - TCL_STATIC); - 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; -} - -/* - *---------------------------------------------------------------------- + * 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. * - * NRCoroInjectObjCmd -- + * Results: + * None. * - * Implementation of [::tcl::unsupported::inject] command. + * Side effects: + * None. * *---------------------------------------------------------------------- */ -static int -NRCoroInjectObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) +void +Tcl_GetVersion(majorV, minorV, patchLevelV, type) + int *majorV; + int *minorV; + int *patchLevelV; + int *type; { - 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 != NRInterpCoroutine)) { - Tcl_AppendResult(interp, "can only inject a command into a coroutine", - NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objv[1]), NULL); - return TCL_ERROR; + if (majorV != NULL) { + *majorV = TCL_MAJOR_VERSION; } - - corPtr = cmdPtr->objClientData; - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_AppendResult(interp, - "can only inject a command into a suspended coroutine", NULL); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); - return TCL_ERROR; + if (minorV != NULL) { + *minorV = TCL_MINOR_VERSION; } - - /* - * Add the callback to the coro's execEnv, so that it is the first thing - * to happen when the coro is resumed. - */ - - iPtr->execEnvPtr = corPtr->eePtr; - TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN); - iPtr->execEnvPtr = savedEEPtr; - - return TCL_OK; -} - -int -NRInterpCoroutine( - 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_ResetResult(interp); - Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]), - "\" is already running", NULL); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); - return TCL_ERROR; + if (patchLevelV != NULL) { + *patchLevelV = TCL_RELEASE_SERIAL; } - - /* - * 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; + if (type != NULL) { + *type = TCL_RELEASE_LEVEL; } - - TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, - NULL, NULL, NULL); - return TCL_OK; } +#ifdef USE_DTRACE /* *---------------------------------------------------------------------- * - * TclNRCoroutineObjCmd -- + * DTraceObjCmd -- + * + * This function is invoked to process the "::tcl::dtrace" Tcl command. + * + * Results: + * A standard Tcl object result. * - * Implementation of [coroutine] command; see documentation for - * description of what this does. + * Side effects: + * The 'tcl-probe' DTrace probe is triggered (if it is enabled). * *---------------------------------------------------------------------- */ -int -TclNRCoroutineObjCmd( +static int +DTraceObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + 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_AppendResult(interp, "can't create procedure \"", fullName, - "\": unknown namespace", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); - return TCL_ERROR; - } - if (procName == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": bad procedure name", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); - return TCL_ERROR; - } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_AppendResult(interp, "can't create procedure \"", procName, - "\" in non-global namespace with name starting with \":\"", - NULL); - Tcl_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); - Tcl_DStringAppend(&ds, "::", 2); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - /*objProc*/ NULL, NRInterpCoroutine, 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); + if (TCL_DTRACE_TCL_PROBE_ENABLED()) { + char *a[10]; + int i = 0; - Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr)); + 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]); } - - /* - * 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; - iPtr->numLevels--; - - /* - * Create the coro's execEnv, switch to it to push the exit and coro - * command callbacks, then switch back. - */ - - corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE); - corPtr->callerEEPtr = iPtr->execEnvPtr; - corPtr->eePtr->corPtr = corPtr; - - SAVE_CONTEXT(corPtr->caller); - corPtr->callerEEPtr = iPtr->execEnvPtr; - RESTORE_CONTEXT(corPtr->running); - iPtr->execEnvPtr = corPtr->eePtr; - - TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, - NULL, NULL, NULL); - - iPtr->lookupNsPtr = lookupNsPtr; - Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); - - SAVE_CONTEXT(corPtr->running); - RESTORE_CONTEXT(corPtr->caller); - iPtr->execEnvPtr = corPtr->callerEEPtr; - - /* - * Now just resume the coroutine. Take care to insure that the command is - * looked up in the correct namespace. - */ - - TclNRAddCallback(interp, NRCoroutineActivateCallback, 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; -} +TCL_DTRACE_DEBUG_LOG() -#undef iPtr +#endif /* USE_DTRACE */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil * End: */ |