diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 1378 |
1 files changed, 702 insertions, 676 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 24c7189..e673a3c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.18 1999/03/11 02:49:34 stanton Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.19 1999/04/16 00:46:42 stanton Exp $ */ #include "tclInt.h" @@ -26,8 +26,13 @@ */ static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); -static void HiddenCmdsDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); +static void ProcessUnexpectedResult _ANSI_ARGS_(( + Tcl_Interp *interp, int returnCode)); +static void RecordTracebackInfo _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr, + int numSrcBytes)); + +extern TclStubs tclStubs; /* * The following structure defines the commands in the Tcl core. @@ -62,7 +67,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, (CompileProc *) NULL, 1}, - {"break", Tcl_BreakCmd, (Tcl_ObjCmdProc *) NULL, + {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, (CompileProc *) NULL, 1}, @@ -72,8 +77,10 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, (CompileProc *) NULL, 1}, - {"continue", Tcl_ContinueCmd, (Tcl_ObjCmdProc *) NULL, + {"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, @@ -84,9 +91,9 @@ static CmdInfo builtInCmds[] = { TclCompileExprCmd, 1}, {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, (CompileProc *) NULL, 1}, - {"fileevent", Tcl_FileEventCmd, (Tcl_ObjCmdProc *) NULL, + {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd, (CompileProc *) NULL, 1}, - {"for", Tcl_ForCmd, (Tcl_ObjCmdProc *) NULL, + {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd, TclCompileForCmd, 1}, {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, TclCompileForeachCmd, 1}, @@ -94,14 +101,12 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, (CompileProc *) NULL, 1}, - {"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL, + {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd, TclCompileIfCmd, 1}, - {"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL, + {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd, TclCompileIncrCmd, 1}, {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, (CompileProc *) NULL, 1}, - {"interp", (Tcl_CmdProc *) NULL, Tcl_InterpObjCmd, - (CompileProc *) NULL, 1}, {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, (CompileProc *) NULL, 1}, {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, @@ -114,7 +119,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, (CompileProc *) NULL, 1}, - {"load", Tcl_LoadCmd, (Tcl_ObjCmdProc *) NULL, + {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd, (CompileProc *) NULL, 0}, {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, (CompileProc *) NULL, 1}, @@ -126,31 +131,31 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, (CompileProc *) NULL, 1}, - {"package", Tcl_PackageCmd, (Tcl_ObjCmdProc *) NULL, + {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd, (CompileProc *) NULL, 1}, {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, (CompileProc *) NULL, 1}, - {"regexp", Tcl_RegexpCmd, (Tcl_ObjCmdProc *) NULL, + {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd, (CompileProc *) NULL, 1}, - {"regsub", Tcl_RegsubCmd, (Tcl_ObjCmdProc *) NULL, + {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd, (CompileProc *) NULL, 1}, {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, (CompileProc *) NULL, 1}, {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, (CompileProc *) NULL, 1}, - {"scan", Tcl_ScanCmd, (Tcl_ObjCmdProc *) NULL, + {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, (CompileProc *) NULL, 1}, - {"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL, + {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, TclCompileSetCmd, 1}, {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, (CompileProc *) NULL, 1}, {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, (CompileProc *) NULL, 1}, - {"subst", Tcl_SubstCmd, (Tcl_ObjCmdProc *) NULL, + {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, (CompileProc *) NULL, 1}, {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, (CompileProc *) NULL, 1}, - {"trace", Tcl_TraceCmd, (Tcl_ObjCmdProc *) NULL, + {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd, (CompileProc *) NULL, 1}, {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, (CompileProc *) NULL, 1}, @@ -160,7 +165,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, (CompileProc *) NULL, 1}, - {"while", Tcl_WhileCmd, (Tcl_ObjCmdProc *) NULL, + {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd, TclCompileWhileCmd, 1}, /* @@ -178,7 +183,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, (CompileProc *) NULL, 1}, - {"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL, + {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd, (CompileProc *) NULL, 0}, {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, (CompileProc *) NULL, 0}, @@ -186,7 +191,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, (CompileProc *) NULL, 1}, - {"glob", Tcl_GlobCmd, (Tcl_ObjCmdProc *) NULL, + {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd, (CompileProc *) NULL, 0}, {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd, (CompileProc *) NULL, 0}, @@ -194,21 +199,21 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, (CompileProc *) NULL, 1}, - {"pwd", Tcl_PwdCmd, (Tcl_ObjCmdProc *) NULL, + {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd, (CompileProc *) NULL, 0}, {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, (CompileProc *) NULL, 1}, - {"seek", Tcl_SeekCmd, (Tcl_ObjCmdProc *) NULL, + {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd, (CompileProc *) NULL, 1}, - {"socket", Tcl_SocketCmd, (Tcl_ObjCmdProc *) NULL, + {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd, (CompileProc *) NULL, 0}, - {"tell", Tcl_TellCmd, (Tcl_ObjCmdProc *) NULL, + {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd, (CompileProc *) NULL, 1}, {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, (CompileProc *) NULL, 1}, - {"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL, + {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd, (CompileProc *) NULL, 1}, - {"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL, + {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd, (CompileProc *) NULL, 1}, #ifdef MAC_TCL @@ -216,14 +221,14 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 0}, {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, - {"ls", Tcl_LsCmd, (Tcl_ObjCmdProc *) NULL, + {"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_ExecCmd, (Tcl_ObjCmdProc *) NULL, + {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd, (CompileProc *) NULL, 0}, {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, (CompileProc *) NULL, 0}, @@ -233,35 +238,7 @@ static CmdInfo builtInCmds[] = { {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0} }; - -/* - *---------------------------------------------------------------------- - * - * Tcl_InitStubs -- - * - * Ensures that the correct version of Tcl is loaded. This is - * a trivial implementation of the stubs library initializer - * that will get called if a stubs aware extension is directly - * linked with the Tcl library. - * - * Results: - * The actual version of Tcl that satisfies the request, or - * NULL to indicate that an error occurred. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ -char * -Tcl_InitStubs (interp, version, exact) - Tcl_Interp *interp; - char *version; - int exact; -{ - return Tcl_PkgRequire(interp, "Tcl", version, exact); -} /* *---------------------------------------------------------------------- @@ -285,14 +262,23 @@ Tcl_InitStubs (interp, version, exact) Tcl_Interp * Tcl_CreateInterp() { - register Interp *iPtr; - register Command *cmdPtr; - register CmdInfo *cmdInfoPtr; + Interp *iPtr; + Tcl_Interp *interp; + Command *cmdPtr; + BuiltinFunc *builtinFuncPtr; + MathFunc *mathFuncPtr; + Tcl_HashEntry *hPtr; + CmdInfo *cmdInfoPtr; + int i; union { char c[sizeof(short)]; short s; } order; - int i; +#ifdef TCL_COMPILE_STATS + ByteCodeStats *statsPtr; +#endif /* TCL_COMPILE_STATS */ + + TclInitSubsystems(NULL); /* * Panic if someone updated the CallFrame structure without @@ -310,15 +296,20 @@ Tcl_CreateInterp() * Tcl object type table and other object management code. */ - TclInitNamespaces(); - iPtr = (Interp *) ckalloc(sizeof(Interp)); - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - iPtr->objResultPtr = Tcl_NewObj(); /* an empty object */ + interp = (Tcl_Interp *) iPtr; + + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = NULL; + iPtr->errorLine = 0; + iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); - iPtr->errorLine = 0; + 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 = 1000; iPtr->framePtr = NULL; @@ -327,9 +318,11 @@ Tcl_CreateInterp() iPtr->returnCode = TCL_OK; iPtr->errorInfo = NULL; iPtr->errorCode = NULL; + iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; + for (i = 0; i < NUM_REGEXPS; i++) { iPtr->patterns[i] = NULL; iPtr->patLengths[i] = -1; @@ -339,6 +332,7 @@ Tcl_CreateInterp() iPtr->packageUnknown = NULL; iPtr->cmdCount = 0; iPtr->termOffset = 0; + TclInitLiteralTable(&(iPtr->literalTable)); iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; @@ -353,26 +347,63 @@ Tcl_CreateInterp() iPtr->resultSpace[0] = 0; iPtr->globalNsPtr = NULL; /* force creation of global ns below */ - iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace( - (Tcl_Interp *) iPtr, "", (ClientData) NULL, - (Tcl_NamespaceDeleteProc *) NULL); + iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", + (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (iPtr->globalNsPtr == NULL) { panic("Tcl_CreateInterp: can't create global namespace"); } /* - * Initialize support for code compilation. Do this after initializing - * namespaces since TclCreateExecEnv will try to reference a Tcl - * variable (it links to the Tcl "tcl_traceExec" variable). + * 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); + + /* + * Initialize the compilation and execution statistics kept for this + * interpreter. + */ + +#ifdef TCL_COMPILE_STATS + statsPtr = &(iPtr->stats); + statsPtr->numExecutions = 0; + statsPtr->numCompilations = 0; + statsPtr->numByteCodesFreed = 0; + (VOID *) memset(statsPtr->instructionCount, 0, + sizeof(statsPtr->instructionCount)); + + statsPtr->totalSrcBytes = 0.0; + statsPtr->totalByteCodeBytes = 0.0; + statsPtr->currentSrcBytes = 0.0; + statsPtr->currentByteCodeBytes = 0.0; + (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); + (VOID *) memset(statsPtr->byteCodeCount, 0, + sizeof(statsPtr->byteCodeCount)); + (VOID *) memset(statsPtr->lifetimeCount, 0, + sizeof(statsPtr->lifetimeCount)); + + statsPtr->currentInstBytes = 0.0; + statsPtr->currentLitBytes = 0.0; + statsPtr->currentExceptBytes = 0.0; + statsPtr->currentAuxBytes = 0.0; + statsPtr->currentCmdMapBytes = 0.0; - iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr); + statsPtr->numLiteralsCreated = 0; + statsPtr->totalLitStringBytes = 0.0; + statsPtr->currentLitStringBytes = 0.0; + (VOID *) memset(statsPtr->literalCount, 0, + sizeof(statsPtr->literalCount)); +#endif /* TCL_COMPILE_STATS */ /* * Initialise the stub table pointer. */ - iPtr->stubTable = tclStubsPtr; + iPtr->stubTable = &tclStubs; + /* * Create the core commands. Do it here, rather than calling @@ -428,72 +459,93 @@ Tcl_CreateInterp() } /* - * Initialize/Create "errorInfo" and "errorCode" global vars - * (because some part of the C code assume they exists - * and we can get a seg fault otherwise (in multiple - * interps loading of extensions for instance) --dl) - */ - /* - * We can't assume that because we initialize - * the variables here, they won't be unset later. - * so we had 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 choosed 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); + * Register the builtin math functions. */ -#ifndef TCL_GENERIC_ONLY - TclSetupEnv((Tcl_Interp *) iPtr); -#endif + i = 0; + for (builtinFuncPtr = builtinFuncTable; builtinFuncPtr->name != NULL; + builtinFuncPtr++) { + 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 */ - (void) TclInterpInit((Tcl_Interp *)iPtr); + + TclInterpInit(interp); /* - * Set up variables such as tcl_version. + * 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); */ - TclPlatformInit((Tcl_Interp *)iPtr); - Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL, - TCL_GLOBAL_ONLY); - Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION, - TCL_GLOBAL_ONLY); - Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - TclPrecTraceProc, (ClientData) NULL); +#ifndef TCL_GENERIC_ONLY + TclSetupEnv(interp); +#endif /* * Compute the byte order of this machine. */ order.s = 1; - Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder", - (order.c[0] == 1) ? "littleEndian" : "bigEndian", + Tcl_SetVar2(interp, "tcl_platform", "byteOrder", + ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), 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", (char *) NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, (ClientData) NULL); + TclpSetVariables(interp); + + /* * Register Tcl's version number. */ - Tcl_PkgProvideEx((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION, - (ClientData) tclStubsPtr); + Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); - return (Tcl_Interp *) iPtr; +#ifdef Tcl_InitStubs +#undef Tcl_InitStubs +#endif + Tcl_InitStubs(interp, TCL_VERSION, 1); + + return interp; } /* @@ -562,13 +614,18 @@ Tcl_CallWhenDeleted(interp, proc, clientData) { Interp *iPtr = (Interp *) interp; static int assocDataCounter = 0; +#ifdef TCL_THREADS + static Tcl_Mutex assocMutex; +#endif int new; - char buffer[128]; + char buffer[32 + TCL_INTEGER_SPACE]; AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; + Tcl_MutexLock(&assocMutex); sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); assocDataCounter++; + Tcl_MutexUnlock(&assocMutex); if (iPtr->assocData == (Tcl_HashTable *) NULL) { iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); @@ -763,6 +820,82 @@ Tcl_GetAssocData(interp, name, procPtr) /* *---------------------------------------------------------------------- * + * Tcl_InterpDeleted -- + * + * Returns nonzero if the interpreter has been deleted with a call + * to Tcl_DeleteInterp. + * + * Results: + * Nonzero if the interpreter is deleted, zero otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InterpDeleted(interp) + Tcl_Interp *interp; +{ + return (((Interp *) interp)->flags & DELETED) ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteInterp -- + * + * Ensures that the interpreter will be deleted eventually. If there + * are no Tcl_Preserve calls in effect for this interpreter, it is + * deleted immediately, otherwise the interpreter is deleted when + * the last Tcl_Preserve is matched by a call to Tcl_Release. In either + * case, the procedure runs the currently registered deletion callbacks. + * + * Results: + * None. + * + * Side effects: + * The interpreter is marked as deleted. The caller may still use it + * safely if there are calls to Tcl_Preserve in effect for the + * interpreter, but further calls to Tcl_Eval etc in this interpreter + * will fail. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteInterp(interp) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ +{ + Interp *iPtr = (Interp *) interp; + + /* + * If the interpreter has already been marked deleted, just punt. + */ + + if (iPtr->flags & DELETED) { + return; + } + + /* + * Mark the interpreter as deleted. No further evals will be allowed. + */ + + iPtr->flags |= DELETED; + + /* + * Ensure that the interpreter is eventually deleted. + */ + + Tcl_EventuallyFree((ClientData) interp, + (Tcl_FreeProc *) DeleteInterpProc); +} + +/* + *---------------------------------------------------------------------- + * * DeleteInterpProc -- * * Helper procedure to delete an interpreter. This procedure is @@ -789,7 +922,6 @@ DeleteInterpProc(interp) Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *hTablePtr; - AssocData *dPtr; ResolverScheme *resPtr, *nextResPtr; int i; @@ -810,6 +942,8 @@ DeleteInterpProc(interp) panic("DeleteInterpProc called on interpreter not marked deleted"); } + TclHandleFree(iPtr->handle); + /* * Dismantle everything in the global namespace except for the * "errorInfo" and "errorCode" variables. These remain until the @@ -822,6 +956,27 @@ DeleteInterpProc(interp) TclTeardownNamespace(iPtr->globalNsPtr); /* + * Delete all the hidden commands. + */ + + hTablePtr = iPtr->hiddenCmdTablePtr; + if (hTablePtr != NULL) { + /* + * Non-pernicious deletion. The deletion callbacks will not be + * allowed to create any new hidden or non-hidden commands. + * Tcl_DeleteCommandFromToken() will remove the entry from the + * hiddenCmdTablePtr. + */ + + hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_DeleteCommandFromToken(interp, + (Tcl_Command) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree((char *) hTablePtr); + } + /* * Tear down the math function table. */ @@ -838,6 +993,8 @@ DeleteInterpProc(interp) */ while (iPtr->assocData != (Tcl_HashTable *) NULL) { + AssocData *dPtr; + hTablePtr = iPtr->assocData; iPtr->assocData = (Tcl_HashTable *) NULL; for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); @@ -911,187 +1068,17 @@ DeleteInterpProc(interp) resPtr = nextResPtr; } - ckfree((char *) iPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InterpDeleted -- - * - * Returns nonzero if the interpreter has been deleted with a call - * to Tcl_DeleteInterp. - * - * Results: - * Nonzero if the interpreter is deleted, zero otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_InterpDeleted(interp) - Tcl_Interp *interp; -{ - return (((Interp *) interp)->flags & DELETED) ? 1 : 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteInterp -- - * - * Ensures that the interpreter will be deleted eventually. If there - * are no Tcl_Preserve calls in effect for this interpreter, it is - * deleted immediately, otherwise the interpreter is deleted when - * the last Tcl_Preserve is matched by a call to Tcl_Release. In either - * case, the procedure runs the currently registered deletion callbacks. - * - * Results: - * None. - * - * Side effects: - * The interpreter is marked as deleted. The caller may still use it - * safely if there are calls to Tcl_Preserve in effect for the - * interpreter, but further calls to Tcl_Eval etc in this interpreter - * will fail. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteInterp(interp) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by a previous call to Tcl_CreateInterp). */ -{ - Interp *iPtr = (Interp *) interp; - - /* - * If the interpreter has already been marked deleted, just punt. - */ - - if (iPtr->flags & DELETED) { - return; - } - /* - * Mark the interpreter as deleted. No further evals will be allowed. - */ - - iPtr->flags |= DELETED; - - /* - * Ensure that the interpreter is eventually deleted. + * Free up literal objects created for scripts compiled by the + * interpreter. */ - Tcl_EventuallyFree((ClientData) interp, - (Tcl_FreeProc *) DeleteInterpProc); -} - -/* - *---------------------------------------------------------------------- - * - * HiddenCmdsDeleteProc -- - * - * Called on interpreter deletion to delete all the hidden - * commands in an interpreter. - * - * Results: - * None. - * - * Side effects: - * Frees up memory. - * - *---------------------------------------------------------------------- - */ - -static void -HiddenCmdsDeleteProc(clientData, interp) - ClientData clientData; /* The hidden commands hash table. */ - Tcl_Interp *interp; /* The interpreter being deleted. */ -{ - Tcl_HashTable *hiddenCmdTblPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - Command *cmdPtr; - - hiddenCmdTblPtr = (Tcl_HashTable *) clientData; - for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) { - - /* - * Cannot use Tcl_DeleteCommand because (a) the command is not - * in the command hash table, and (b) that table has already been - * deleted above. Hence we emulate what it does, below. - */ - - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - - /* - * 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->deleted) { - - /* - * Another deletion is already in progress. Remove the hash - * table entry now, but don't invoke a callback or free the - * command structure. - */ - - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = NULL; - continue; - } - cmdPtr->deleted = 1; - if (cmdPtr->deleteProc != NULL) { - (*cmdPtr->deleteProc)(cmdPtr->deleteData); - } - - /* - * Bump the command epoch counter. This will invalidate all cached - * references that refer to this command. - */ - - cmdPtr->cmdEpoch++; - - /* - * 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); - } - - /* - * 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). - */ - - TclCleanupCommand(cmdPtr); - } - Tcl_DeleteHashTable(hiddenCmdTblPtr); - ckfree((char *) hiddenCmdTblPtr); + TclDeleteLiteralTable(interp, &(iPtr->literalTable)); + ckfree((char *) iPtr); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_HideCommand -- * @@ -1099,14 +1086,14 @@ HiddenCmdsDeleteProc(clientData, interp) * an interpreter, only from within an ancestor. * * Results: - * A standard Tcl result; also leaves a message in interp->result + * A standard Tcl result; also leaves a message in the interp's result * if an error occurs. * * Side effects: * Removes a command from the command table and create an entry * into the hidden command table under the specified token name. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -1118,7 +1105,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) Interp *iPtr = (Interp *) interp; Tcl_Command cmd; Command *cmdPtr; - Tcl_HashTable *hTblPtr; + Tcl_HashTable *hiddenCmdTablePtr; Tcl_HashEntry *hPtr; int new; @@ -1189,14 +1176,12 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * Initialize the hidden command table if necessary. */ - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", - NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - hTblPtr = (Tcl_HashTable *) + hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; + if (hiddenCmdTablePtr == NULL) { + hiddenCmdTablePtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); - Tcl_SetAssocData(interp, "tclHiddenCmds", HiddenCmdsDeleteProc, - (ClientData) hTblPtr); + Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); + iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } /* @@ -1205,7 +1190,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * exists. */ - hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new); + hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new); if (!new) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "hidden command named \"", hiddenCmdToken, "\" already exists", @@ -1265,7 +1250,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * * Results: * A standard Tcl result. If an error occurs, a message is left - * in interp->result. + * in the interp's result. * * Side effects: * Moves commands from one hash table to another. @@ -1284,7 +1269,7 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) Command *cmdPtr; Namespace *nsPtr; Tcl_HashEntry *hPtr; - Tcl_HashTable *hTblPtr; + Tcl_HashTable *hiddenCmdTablePtr; int new; if (iPtr->flags & DELETED) { @@ -1311,24 +1296,14 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) } /* - * Find the hash table for the hidden commands; error out if there - * is none. - */ - - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", - NULL); - if (hTblPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown hidden command \"", hiddenCmdToken, - "\"", (char *) NULL); - return TCL_ERROR; - } - - /* * Get the command from the hidden command table: */ - hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken); + hPtr = NULL; + hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; + if (hiddenCmdTablePtr != NULL) { + hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); + } if (hPtr == (Tcl_HashEntry *) NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown hidden command \"", hiddenCmdToken, @@ -1508,7 +1483,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) * could get stuck in an infinite loop). */ - ckfree((char*) cmdPtr); + ckfree((char*) Tcl_GetHashValue(hPtr)); } } cmdPtr = (Command *) ckalloc(sizeof(Command)); @@ -1562,7 +1537,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) * * Results: * The return value is a token for the command, which can - * be used in future calls to Tcl_NameOfCommand. + * be used in future calls to Tcl_GetCommandName. * * Side effects: * If no command named "cmdName" already exists for interp, one is @@ -1760,7 +1735,6 @@ TclInvokeStringCommand(clientData, interp, objc, objv) * 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. - * THIS FAILS IF ANY ARGUMENT OBJECT CONTAINS AN EMBEDDED NULL. */ if ((objc + 1) > NUM_ARGS) { @@ -1768,7 +1742,7 @@ TclInvokeStringCommand(clientData, interp, objc, objv) } for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetStringFromObj(objv[i], (int *) NULL); + argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; @@ -1861,11 +1835,9 @@ TclInvokeObjectCommand(clientData, interp, argc, argv) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULL BYTES. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); /* @@ -2436,83 +2408,92 @@ TclCleanupCommand(cmdPtr) /* *---------------------------------------------------------------------- * - * Tcl_Eval -- + * Tcl_CreateMathFunc -- * - * Execute a Tcl command in a string. + * Creates a new math function for expressions in a given + * interpreter. * * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and interp->result contains a string value - * to supplement the return code. The value of interp->result - * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: - * you must copy it or lose it! + * None. * * Side effects: - * The string is compiled to produce a ByteCode object that holds the - * command's bytecode instructions. However, this ByteCode object is - * lost after executing the command. The command's execution will - * almost certainly have side effects. interp->termOffset is set to the - * offset of the character in "string" just after the last one - * successfully compiled or executed. + * 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. * *---------------------------------------------------------------------- */ -int -Tcl_Eval(interp, string) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by previous call to Tcl_CreateInterp). */ - char *string; /* Pointer to TCL command to execute. */ +void +Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which function is + * to be available. */ + 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. */ { - register Tcl_Obj *cmdPtr; - int length = strlen(string); - int result; - - if (length > 0) { - /* - * Initialize a Tcl object from the command string. - */ - - TclNewObj(cmdPtr); - TclInitStringRep(cmdPtr, string, length); - Tcl_IncrRefCount(cmdPtr); - - /* - * Compile and execute the bytecodes. - */ - - result = Tcl_EvalObj(interp, cmdPtr); + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; + int new, i; - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ + hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); + if (new) { + Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); + if (!new) { + if (mathFuncPtr->builtinFuncIndex >= 0) { + /* + * 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. + */ - /* - * Discard the Tcl object created to hold the command and its code. - */ - - Tcl_DecrRefCount(cmdPtr); - } else { - /* - * An empty string. Just reset the interpreter's result. - */ + 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. + */ - Tcl_ResetResult(interp); - result = TCL_OK; + if (numArgs != mathFuncPtr->numArgs) { + iPtr->compileEpoch++; + } + } } - return result; + + mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ + if (numArgs > MAX_MATH_ARGS) { + numArgs = MAX_MATH_ARGS; + } + mathFuncPtr->numArgs = numArgs; + for (i = 0; i < numArgs; i++) { + mathFuncPtr->argTypes[i] = argTypes[i]; + } + mathFuncPtr->proc = proc; + mathFuncPtr->clientData = clientData; } /* *---------------------------------------------------------------------- * - * Tcl_EvalObj -- + * Tcl_EvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are * compiled into bytecodes if necessary. @@ -2534,27 +2515,59 @@ Tcl_Eval(interp, string) *---------------------------------------------------------------------- */ -#undef Tcl_EvalObj - int -Tcl_EvalObj(interp, objPtr) +Tcl_EvalObjEx(interp, objPtr, flags) Tcl_Interp *interp; /* Token for command interpreter * (returned by a previous call to * Tcl_CreateInterp). */ - Tcl_Obj *objPtr; /* Pointer to object containing + 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. */ { register Interp *iPtr = (Interp *) interp; - int flags; /* Interp->evalFlags value when the + int evalFlags; /* Interp->evalFlags value when the * procedure was called. */ register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ int oldCount = iPtr->cmdCount; /* Used to tell whether any commands * at all were executed. */ - int numSrcChars; - register int result; + int numSrcBytes; + int result; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ Namespace *namespacePtr; /* + * Prevent the object from being deleted as a side effect of evaling it. + */ + + Tcl_IncrRefCount(objPtr); + + if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) { + /* + * We're not supposed to use the compiler or byte-code interpreter. + * Let Tcl_EvalEx evaluate the command directly (and probably + * more slowly). + */ + + char *p; + int length; + + p = Tcl_GetStringFromObj(objPtr, &length); + result = Tcl_EvalEx(interp, p, length, flags); + Tcl_DecrRefCount(objPtr); + return result; + } + + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; + } + + /* * Reset both the interpreter's string and object results and clear out * any error information. This makes sure that we return an empty * result if there are no commands in the command string. @@ -2571,21 +2584,23 @@ Tcl_EvalObj(interp, objPtr) if (iPtr->numLevels > iPtr->maxNestingDepth) { iPtr->numLevels--; Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); - return TCL_ERROR; + "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); + result = TCL_ERROR; + goto done; } /* - * On the Mac, we will never reach the default recursion limit before blowing - * the stack. So we need to do a check here. + * On the Mac, we will never reach the default recursion limit before + * blowing the stack. So we need to do a check here. */ if (TclpCheckStackSpace() == 0) { /*NOTREACHED*/ iPtr->numLevels--; Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); - return TCL_ERROR; + "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); + result = TCL_ERROR; + goto done; } /* @@ -2597,9 +2612,10 @@ Tcl_EvalObj(interp, objPtr) 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); - iPtr->numLevels--; - return TCL_ERROR; + "attempt to call eval in deleted interpreter", + (char *) NULL); + result = TCL_ERROR; + goto done; } /* @@ -2624,12 +2640,12 @@ Tcl_EvalObj(interp, objPtr) if (objPtr->typePtr == &tclByteCodeType) { codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if ((codePtr->iPtr != iPtr) + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if (codePtr->iPtr != iPtr) { + if ((Interp *) *codePtr->interpHandle != iPtr) { panic("Tcl_EvalObj: compiled script jumped interps"); } codePtr->compileEpoch = iPtr->compileEpoch; @@ -2639,15 +2655,22 @@ Tcl_EvalObj(interp, objPtr) } } if (objPtr->typePtr != &tclByteCodeType) { - /* - * First reset any error line number information. - */ - - iPtr->errorLine = 1; /* no correct line # information yet */ + iPtr->errorLine = 1; result = tclByteCodeType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { - iPtr->numLevels--; - return result; + goto done; + } + } else { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch)) { + (*tclByteCodeType.freeIntRepProc)(objPtr); + iPtr->errorLine = 1; + result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr); + if (result != TCL_OK) { + iPtr->numLevels--; + return result; + } } } codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; @@ -2657,7 +2680,7 @@ Tcl_EvalObj(interp, objPtr) * Resetting the flags must be done after any compilation. */ - flags = iPtr->evalFlags; + evalFlags = iPtr->evalFlags; iPtr->evalFlags = 0; /* @@ -2665,8 +2688,8 @@ Tcl_EvalObj(interp, objPtr) * don't bother executing the code. */ - numSrcChars = codePtr->numSrcChars; - if ((numSrcChars > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + numSrcBytes = codePtr->numSrcBytes; + if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. @@ -2679,7 +2702,6 @@ Tcl_EvalObj(interp, objPtr) TclCleanupByteCode(codePtr); } } else { - Tcl_ResetResult(interp); result = TCL_OK; } @@ -2690,33 +2712,23 @@ Tcl_EvalObj(interp, objPtr) * empty bodies. */ - if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) { + if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) { result = Tcl_AsyncInvoke(interp, result); } /* - * Free up any extra resources that were allocated. + * Update the interpreter's evaluation level count. If we are again at + * the top level, process any unusual return code returned by the + * evaluated code. */ - iPtr->numLevels--; - if (iPtr->numLevels == 0) { + if (iPtr->numLevels == 1) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } if ((result != TCL_OK) && (result != TCL_ERROR) - && !(flags & TCL_ALLOW_EXCEPTIONS)) { - Tcl_ResetResult(interp); - if (result == TCL_BREAK) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"break\" outside of a loop", -1); - } else if (result == TCL_CONTINUE) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"continue\" outside of a loop", -1); - } else { - char buf[50]; - sprintf(buf, "command returned bad code: %d", result); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - } + && ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) { + ProcessUnexpectedResult(interp, result); result = TCL_ERROR; } } @@ -2727,33 +2739,7 @@ Tcl_EvalObj(interp, objPtr) */ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - char buf[200]; - char *ellipsis = ""; - char *bytes; - int length; - - /* - * Figure out how much of the command to print in the error - * message (up to a certain number of characters, or up to - * the first new-line). - * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL. - */ - - bytes = Tcl_GetStringFromObj(objPtr, &length); - length = TclMin(numSrcChars, length); - if (length > 150) { - length = 150; - ellipsis = " ..."; - } - - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - sprintf(buf, "\n while executing\n\"%.*s%s\"", - length, bytes, ellipsis); - } else { - sprintf(buf, "\n invoked from within\n\"%.*s%s\"", - length, bytes, ellipsis); - } - Tcl_AddObjErrorInfo(interp, buf, -1); + RecordTracebackInfo(interp, objPtr, numSrcBytes); } /* @@ -2763,13 +2749,114 @@ Tcl_EvalObj(interp, objPtr) * compiled. */ - iPtr->termOffset = numSrcChars; + iPtr->termOffset = numSrcBytes; iPtr->flags &= ~ERR_ALREADY_LOGGED; + + done: + TclDecrRefCount(objPtr); + iPtr->varFramePtr = savedVarFramePtr; + iPtr->numLevels--; return result; } /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- + * + * ProcessUnexpectedResult -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static void +ProcessUnexpectedResult(interp, returnCode) + Tcl_Interp *interp; /* The interpreter in which the unexpected + * result code was returned. */ + int returnCode; /* The unexpected result code. */ +{ + Tcl_ResetResult(interp); + if (returnCode == TCL_BREAK) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"break\" outside of a loop", -1); + } else if (returnCode == TCL_CONTINUE) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"continue\" outside of a loop", -1); + } else { + char buf[30 + TCL_INTEGER_SPACE]; + + sprintf(buf, "command returned bad code: %d", returnCode); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } +} + +/* + *---------------------------------------------------------------------- + * + * RecordTracebackInfo -- + * + * Procedure called by Tcl_EvalObj to record information about what was + * being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Appends information about the script being evaluated to the + * interpreter's "errorInfo" variable. + * + *---------------------------------------------------------------------- + */ + +static void +RecordTracebackInfo(interp, objPtr, numSrcBytes) + Tcl_Interp *interp; /* The interpreter in which the error + * occurred. */ + Tcl_Obj *objPtr; /* Points to object containing script whose + * evaluation resulted in an error. */ + int numSrcBytes; /* Number of bytes compiled in script. */ +{ + Interp *iPtr = (Interp *) interp; + char buf[200]; + char *ellipsis, *bytes; + int length; + + /* + * Decide how much of the command to print in the error message + * (up to a certain number of bytes). + */ + + bytes = Tcl_GetStringFromObj(objPtr, &length); + length = TclMin(numSrcBytes, length); + + ellipsis = ""; + if (length > 150) { + length = 150; + ellipsis = " ..."; + } + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(buf, "\n while executing\n\"%.*s%s\"", + length, bytes, ellipsis); + } else { + sprintf(buf, "\n invoked from within\n\"%.*s%s\"", + length, bytes, ellipsis); + } + Tcl_AddObjErrorInfo(interp, buf, -1); +} + +/* + *--------------------------------------------------------------------------- * * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- * @@ -2778,15 +2865,15 @@ Tcl_EvalObj(interp, objPtr) * * Results: * Each of the procedures below returns a standard Tcl result. If an - * error occurs then an error message is left in interp->result. - * Otherwise the value of the expression, in the appropriate form, is - * stored at *ptr. If the expression had a result that was + * error occurs then an error message is left in the interp's result. + * Otherwise the value of the expression, in the appropriate form, + * is stored at *ptr. If the expression had a result that was * incompatible with the desired form then an error is returned. * * Side effects: * None. * - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -2824,12 +2911,9 @@ Tcl_ExprLong(interp, string, ptr) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -2878,12 +2962,9 @@ Tcl_ExprDouble(interp, string, ptr) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -2931,12 +3012,9 @@ Tcl_ExprBoolean(interp, string, ptr) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -3044,9 +3122,6 @@ Tcl_ExprBooleanObj(interp, objPtr, ptr) *ptr = (resultPtr->internalRep.doubleValue != 0.0); } else { result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); - if (result != TCL_OK) { - return result; - } } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } @@ -3123,11 +3198,9 @@ TclInvoke(interp, argc, argv, flags) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); /* @@ -3215,15 +3288,15 @@ TclGlobalInvoke(interp, argc, argv, flags) int TclObjInvokeGlobal(interp, objc, objv, flags) - Tcl_Interp *interp; /* Interpreter in which command is - * to be invoked. */ + Tcl_Interp *interp; /* Interpreter in which command is to be + * invoked. */ int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] - * points to the name of the - * command to invoke. */ - int flags; /* Combination of flags controlling - * the call: TCL_INVOKE_HIDDEN and - * TCL_INVOKE_NO_UNKNOWN. */ + 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; int result; @@ -3255,15 +3328,15 @@ TclObjInvokeGlobal(interp, objc, objv, flags) int TclObjInvoke(interp, objc, objv, flags) - Tcl_Interp *interp; /* Interpreter in which command is - * to be invoked. */ + Tcl_Interp *interp; /* Interpreter in which command is to be + * invoked. */ int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] - * points to the name of the - * command to invoke. */ - int flags; /* Combination of flags controlling - * the call: TCL_INVOKE_HIDDEN and - * TCL_INVOKE_NO_UNKNOWN. */ + 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. */ @@ -3287,35 +3360,24 @@ TclObjInvoke(interp, objc, objv, flags) return TCL_ERROR; } - /* - * THE FOLLOWING CODE FAILS IF THE STRING REP CONTAINS NULLS. - */ - - cmdName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + cmdName = Tcl_GetString(objv[0]); if (flags & TCL_INVOKE_HIDDEN) { /* - * Find the table of hidden commands; error out if none. + * We never invoke "unknown" for hidden commands. */ - - hTblPtr = (Tcl_HashTable *) - Tcl_GetAssocData(interp, "tclHiddenCmds", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - badhiddenCmdToken: + + 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; } - hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); - - /* - * We never invoke "unknown" for hidden commands. - */ - - if (hPtr == NULL) { - goto badhiddenCmdToken; - } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); } else { cmdPtr = NULL; @@ -3376,7 +3438,9 @@ TclObjInvoke(interp, objc, objv, flags) * executed when the error occurred. */ - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + if ((result == TCL_ERROR) + && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) + && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { Tcl_DString ds; Tcl_DStringInit(&ds); @@ -3408,13 +3472,14 @@ TclObjInvoke(interp, objc, objv, flags) */ if (localObjv != (Tcl_Obj **) NULL) { + Tcl_DecrRefCount(localObjv[0]); ckfree((char *) localObjv); } return result; } /* - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_ExprString -- * @@ -3422,17 +3487,16 @@ TclObjInvoke(interp, objc, objv, flags) * form. * * Results: - * A standard Tcl result. If the result is TCL_OK, then the - * interpreter's result is set to the string value of the - * expression. If the result is TCL_OK, then interp->result - * contains an error message. + * 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 @@ -3444,7 +3508,7 @@ Tcl_ExprString(interp, string) register Tcl_Obj *exprPtr; Tcl_Obj *resultPtr; int length = strlen(string); - char buf[100]; + char buf[TCL_DOUBLE_SPACE]; int result = TCL_OK; if (length > 0) { @@ -3468,24 +3532,19 @@ Tcl_ExprString(interp, string) } else { /* * Set interpreter's string result from the result object. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(resultPtr, (int *) NULL), - TCL_VOLATILE); + 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. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -3535,15 +3594,42 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure * allocated in frame. */ + LiteralTable *localTablePtr = &(compEnv.localLitTable); register ByteCode *codePtr = NULL; /* Tcl Internal type of bytecode. * Initialized to avoid compiler warning. */ AuxData *auxDataPtr; - Interp dummy; + LiteralEntry *entryPtr; Tcl_Obj *saveObjPtr; char *string; - int result; - int i; + int length, i, result; + + /* + * First handle some common expressions specially. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + if (length == 1) { + if (*string == '0') { + *resultPtrPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } else if (*string == '1') { + *resultPtrPtr = Tcl_NewLongObj(1); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } + } else if ((length == 2) && (*string == '!')) { + if (*(string+1) == '0') { + *resultPtrPtr = Tcl_NewLongObj(1); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } else if (*(string+1) == '1') { + *resultPtrPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } + } /* * Get the ByteCode from the object. If it exists, make sure it hasn't @@ -3556,72 +3642,53 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) * Precompiled expressions, however, are immutable and therefore * they are not recompiled, even if the epoch has changed. * - * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE. */ if (objPtr->typePtr == &tclByteCodeType) { codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if ((codePtr->iPtr != iPtr) + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if (codePtr->iPtr != iPtr) { + if ((Interp *) *codePtr->interpHandle != iPtr) { panic("Tcl_ExprObj: compiled expression jumped interps"); } codePtr->compileEpoch = iPtr->compileEpoch; } else { - tclByteCodeType.freeIntRepProc(objPtr); + (*tclByteCodeType.freeIntRepProc)(objPtr); objPtr->typePtr = (Tcl_ObjType *) NULL; } } } if (objPtr->typePtr != &tclByteCodeType) { - int length; - string = Tcl_GetStringFromObj(objPtr, &length); - TclInitCompileEnv(interp, &compEnv, string); - result = TclCompileExpr(interp, string, string + length, - /*flags*/ 0, &compEnv); - if (result == TCL_OK) { - /* - * If the expression yielded no instructions (e.g., was empty), - * push an integer zero object as the expressions's result. - */ - - if (compEnv.codeNext == NULL) { - int objIndex = TclObjIndexForString("0", 0, - /*allocStrRep*/ 0, /*inHeap*/ 0, &compEnv); - Tcl_Obj *objPtr = compEnv.objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, &compEnv); - } - - /* - * Add done instruction at the end of the instruction sequence. - */ - - TclEmitOpcode(INST_DONE, &compEnv); - - TclInitByteCodeObj(objPtr, &compEnv); - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if (tclTraceCompile == 2) { - TclPrintByteCodeObj(interp, objPtr); - } - TclFreeCompileEnv(&compEnv); - } else { + TclInitCompileEnv(interp, &compEnv, string, length); + result = TclCompileExpr(interp, string, length, &compEnv); + + /* + * Free the compilation environment's literal table bucket array if + * it was dynamically allocated. + */ + + if (localTablePtr->buckets != localTablePtr->staticBuckets) { + ckfree((char *) localTablePtr->buckets); + } + + if (result != TCL_OK) { /* - * Compilation errors. Decrement the ref counts on any objects - * in the object array before freeing the compilation - * environment. + * Compilation errors. Free storage allocated for compilation. */ - - for (i = 0; i < compEnv.objArrayNext; i++) { - Tcl_Obj *elemPtr = compEnv.objArrayPtr[i]; - Tcl_DecrRefCount(elemPtr); - } +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(&compEnv); +#endif /*TCL_COMPILE_DEBUG*/ + entryPtr = compEnv.literalArrayPtr; + for (i = 0; i < compEnv.literalArrayNext; i++) { + TclReleaseLiteral(interp, entryPtr->objPtr); + entryPtr++; + } +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(iPtr); +#endif /*TCL_COMPILE_DEBUG*/ + auxDataPtr = compEnv.auxDataArrayPtr; for (i = 0; i < compEnv.auxDataArrayNext; i++) { if (auxDataPtr->type->freeProc != NULL) { @@ -3632,28 +3699,43 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) TclFreeCompileEnv(&compEnv); return result; } + + /* + * Successful compilation. If the expression yielded no + * instructions, push an zero object as the expression's result. + */ + + if (compEnv.codeNext == compEnv.codeStart) { + TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0), + &compEnv); + } + + /* + * Add a "done" instruction as the last instruction and change the + * object into a ByteCode object. Ownership of the literal objects + * and aux data items is given to the ByteCode object. + */ + + compEnv.numSrcBytes = iPtr->termOffset; + TclEmitOpcode(INST_DONE, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + TclFreeCompileEnv(&compEnv); + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile == 2) { + TclPrintByteCodeObj(interp, objPtr); + } +#endif /* TCL_COMPILE_DEBUG */ } /* * Execute the expression after first saving the interpreter's result. */ - dummy.objResultPtr = Tcl_NewObj(); - Tcl_IncrRefCount(dummy.objResultPtr); - if (interp->freeProc == 0) { - dummy.freeProc = (Tcl_FreeProc *) 0; - dummy.result = ""; - Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, - TCL_VOLATILE); - } else { - dummy.freeProc = interp->freeProc; - dummy.result = interp->result; - interp->freeProc = (Tcl_FreeProc *) 0; - } - saveObjPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(saveObjPtr); - + Tcl_ResetResult(interp); + /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. @@ -3664,6 +3746,8 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; } /* @@ -3679,17 +3763,9 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) *resultPtrPtr = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->objResultPtr); - Tcl_SetResult(interp, dummy.result, - ((dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc)); - Tcl_DecrRefCount(iPtr->objResultPtr); - iPtr->objResultPtr = saveObjPtr; - } else { - Tcl_DecrRefCount(saveObjPtr); - Tcl_FreeResult((Tcl_Interp *) &dummy); + Tcl_SetObjResult(interp, saveObjPtr); } - - Tcl_DecrRefCount(dummy.objResultPtr); - dummy.objResultPtr = NULL; + Tcl_DecrRefCount(saveObjPtr); return result; } @@ -3844,7 +3920,7 @@ void Tcl_AddErrorInfo(interp, message) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ - char *message; /* Message to record. */ + CONST char *message; /* Message to record. */ { Tcl_AddObjErrorInfo(interp, message, -1); } @@ -3876,29 +3952,26 @@ void Tcl_AddObjErrorInfo(interp, message, length) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ - char *message; /* Points to the first byte of an array of + CONST char *message; /* Points to the first byte of an array of * bytes of the message. */ - register int length; /* The number of bytes in the message. + int length; /* The number of bytes in the message. * If < 0, then append all bytes up to a * NULL byte. */ { register Interp *iPtr = (Interp *) interp; - Tcl_Obj *namePtr, *messagePtr; + Tcl_Obj *messagePtr; /* * If we are just starting to log an error, errorInfo is initialized * from the error message in the interpreter's result. */ - namePtr = Tcl_NewStringObj("errorInfo", -1); - Tcl_IncrRefCount(namePtr); - if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ iPtr->flags |= ERR_IN_PROGRESS; if (iPtr->result[0] == 0) { - (void) Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, - iPtr->objResultPtr, TCL_GLOBAL_ONLY); + (void) Tcl_SetVar2Ex(interp, "errorInfo", NULL, iPtr->objResultPtr, + TCL_GLOBAL_ONLY); } else { /* use the string result */ Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, TCL_GLOBAL_ONLY); @@ -3922,16 +3995,14 @@ Tcl_AddObjErrorInfo(interp, message, length) if (length != 0) { messagePtr = Tcl_NewStringObj(message, length); Tcl_IncrRefCount(messagePtr); - Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr, + Tcl_SetVar2Ex(interp, "errorInfo", NULL, messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ } - - Tcl_DecrRefCount(namePtr); /* free the name object */ } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_VarEvalVA -- * @@ -3939,13 +4010,13 @@ Tcl_AddObjErrorInfo(interp, message, length) * all together and execute the result as a Tcl command. * * Results: - * A standard Tcl return result. An error message or other - * result may be left in interp->result. + * A standard Tcl return result. An error message or other result may + * be left in the interp's result. * * Side effects: * Depends on what was done by the command. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -4011,14 +4082,14 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_GlobalEval -- * * Evaluate a command at global level in an interpreter. * * Results: - * A standard Tcl result is returned, and interp->result is + * A standard Tcl result is returned, and the interp's result is * modified accordingly. * * Side effects: @@ -4027,7 +4098,7 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) * procedures active), just as if an "uplevel #0" command were * being executed. * - *---------------------------------------------------------------------- + --------------------------------------------------------------------------- */ int @@ -4049,51 +4120,6 @@ Tcl_GlobalEval(interp, command) /* *---------------------------------------------------------------------- * - * Tcl_GlobalEvalObj -- - * - * Execute Tcl commands stored in a Tcl object at global level in - * an interpreter. These commands are compiled into bytecodes if - * necessary. - * - * Results: - * A standard Tcl result is returned, and the interpreter's result - * contains a Tcl object 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 commands are 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_GlobalEvalObj(interp, objPtr) - Tcl_Interp *interp; /* Interpreter in which to evaluate - * commands. */ - Tcl_Obj *objPtr; /* Pointer to object containing commands - * to execute. */ -{ - register Interp *iPtr = (Interp *) interp; - int result; - CallFrame *savedVarFramePtr; - - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = NULL; - result = Tcl_EvalObj(interp, objPtr); - iPtr->varFramePtr = savedVarFramePtr; - return result; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SetRecursionLimit -- * * Set the maximum number of recursive calls that may be active |