diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 1230 |
1 files changed, 137 insertions, 1093 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index bb89da9..ae65db0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -41,18 +41,6 @@ #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 @@ -132,8 +120,6 @@ static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); static Tcl_NRPostProc NRRunObjProc; -static Tcl_ObjCmdProc OldMathFuncProc; -static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); @@ -206,7 +192,6 @@ 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. */ @@ -221,96 +206,93 @@ 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, TclCompileFormatCmd, NULL, 1}, - {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, - {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, - {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1}, - {"join", Tcl_JoinObjCmd, NULL, NULL, 1}, - {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, 1}, - {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, 1}, - {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, 1}, - {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1}, - {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1}, - {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, - {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1}, - {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1}, - {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, - {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1}, - {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1}, - {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, - {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, - {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1}, - {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, - {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, - {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, - {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, 1}, - {"rename", Tcl_RenameObjCmd, NULL, NULL, 1}, - {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1}, - {"scan", Tcl_ScanObjCmd, NULL, NULL, 1}, - {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1}, - {"split", Tcl_SplitObjCmd, NULL, NULL, 1}, - {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1}, - {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1}, - {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, 1}, - {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1}, - {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, - {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1}, - {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, 1}, - {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1}, - {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1}, - {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, - {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1}, - {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, 1}, - {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1}, + {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1}, + {"apply", Tcl_ApplyObjCmd, NULL, 1}, + {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, + {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, 1}, + {"concat", Tcl_ConcatObjCmd, NULL, 1}, + {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, 1}, + {"coroutine", TclNRCoroutineObjCmd, NULL, 1}, + {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, 1}, + {"eval", Tcl_EvalObjCmd, NULL, 1}, + {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, 1}, + {"for", Tcl_ForObjCmd, TclCompileForCmd, 1}, + {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, 1}, + {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, 1}, + {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, 1}, + {"if", Tcl_IfObjCmd, TclCompileIfCmd, 1}, + {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, 1}, + {"join", Tcl_JoinObjCmd, NULL, 1}, + {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, 1}, + {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, 1}, + {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, 1}, + {"linsert", Tcl_LinsertObjCmd, NULL, 1}, + {"list", Tcl_ListObjCmd, TclCompileListCmd, 1}, + {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, 1}, + {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, 1}, + {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, 1}, + {"lrepeat", Tcl_LrepeatObjCmd, NULL, 1}, + {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, 1}, + {"lreverse", Tcl_LreverseObjCmd, NULL, 1}, + {"lsearch", Tcl_LsearchObjCmd, NULL, 1}, + {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, 1}, + {"lsort", Tcl_LsortObjCmd, NULL, 1}, + {"package", Tcl_PackageObjCmd, NULL, 1}, + {"proc", Tcl_ProcObjCmd, NULL, 1}, + {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, 1}, + {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, 1}, + {"rename", Tcl_RenameObjCmd, NULL, 1}, + {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, 1}, + {"scan", Tcl_ScanObjCmd, NULL, 1}, + {"set", Tcl_SetObjCmd, TclCompileSetCmd, 1}, + {"split", Tcl_SplitObjCmd, NULL, 1}, + {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, 1}, + {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, 1}, + {"tailcall", TclNRTailcallObjCmd, TclCompileTailcallCmd, 1}, + {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, 1}, + {"trace", Tcl_TraceObjCmd, NULL, 1}, + {"try", Tcl_TryObjCmd, TclCompileTryCmd, 1}, + {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, 1}, + {"uplevel", Tcl_UplevelObjCmd, NULL, 1}, + {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, 1}, + {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, 1}, + {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, 1}, + {"yield", TclNRYieldObjCmd, TclCompileYieldCmd, 1}, + {"yieldto", TclNRYieldToObjCmd, NULL, 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} + {"after", Tcl_AfterObjCmd, NULL, 1}, + {"cd", Tcl_CdObjCmd, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, 1}, + {"eof", Tcl_EofObjCmd, NULL, 1}, + {"encoding", Tcl_EncodingObjCmd, NULL, 0}, + {"exec", Tcl_ExecObjCmd, NULL, 0}, + {"exit", Tcl_ExitObjCmd, NULL, 0}, + {"fblocked", Tcl_FblockedObjCmd, NULL, 1}, + {"fconfigure", Tcl_FconfigureObjCmd, NULL, 0}, + {"fcopy", Tcl_FcopyObjCmd, NULL, 1}, + {"fileevent", Tcl_FileEventObjCmd, NULL, 1}, + {"flush", Tcl_FlushObjCmd, NULL, 1}, + {"gets", Tcl_GetsObjCmd, NULL, 1}, + {"glob", Tcl_GlobObjCmd, NULL, 0}, + {"load", Tcl_LoadObjCmd, NULL, 0}, + {"open", Tcl_OpenObjCmd, NULL, 0}, + {"pid", Tcl_PidObjCmd, NULL, 1}, + {"puts", Tcl_PutsObjCmd, NULL, 1}, + {"pwd", Tcl_PwdObjCmd, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, 1}, + {"seek", Tcl_SeekObjCmd, NULL, 1}, + {"socket", Tcl_SocketObjCmd, NULL, 0}, + {"source", Tcl_SourceObjCmd, NULL, 0}, + {"tell", Tcl_TellObjCmd, NULL, 1}, + {"time", Tcl_TimeObjCmd, NULL, 1}, + {"unload", Tcl_UnloadObjCmd, NULL, 0}, + {"update", Tcl_UpdateObjCmd, NULL, 1}, + {"vwait", Tcl_VwaitObjCmd, NULL, 1}, + {NULL, NULL, NULL, 0} }; /* @@ -493,16 +475,6 @@ Tcl_CreateInterp(void) TclInitSubsystems(); - /* - * Panic if someone updated the CallFrame structure without also updating - * the Tcl_CallFrame structure (or vice versa). - */ - - if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) { - /*NOTREACHED*/ - Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); - } - if (cancelTableInitialized == 0) { Tcl_MutexLock(&cancelLock); if (cancelTableInitialized == 0) { @@ -521,9 +493,12 @@ Tcl_CreateInterp(void) iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = NULL; + iPtr->legacyResult = NULL; + /* Special invalid value: Any attempt to free the legacy result + * will cause a crash. */ + iPtr->legacyFreeProc = (void (*) (void))-1; iPtr->errorLine = 0; + iPtr->stubTable = &tclStubs; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); @@ -562,10 +537,6 @@ Tcl_CreateInterp(void) iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - iPtr->appendUsed = 0; - Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; @@ -593,7 +564,6 @@ Tcl_CreateInterp(void) iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); - iPtr->resultSpace[0] = 0; iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ @@ -622,13 +592,11 @@ Tcl_CreateInterp(void) } /* - * Initialise the rootCallframe. It cannot be allocated on the stack, as - * it has to be in place before TclCreateExecEnv tries to use a variable. + * Initialise the rootCallframe. */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtr = ckalloc(sizeof(CallFrame)); - result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + result = TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { Tcl_Panic("Tcl_CreateInterp: failed to push the root stack frame"); @@ -707,12 +675,6 @@ Tcl_CreateInterp(void) #endif /* TCL_COMPILE_STATS */ /* - * Initialise the stub table pointer. - */ - - iPtr->stubTable = &tclStubs; - - /* * Initialize the ensemble error message rewriting support. */ @@ -731,12 +693,6 @@ Tcl_CreateInterp(void) * 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; @@ -744,44 +700,22 @@ Tcl_CreateInterp(void) TclInvalidateStringRep(iPtr->cmdSourcePtr); /* - * 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. + * Create the core commands by calling Tcl_CreateCommand. + * + * FIXME! do it directly for faster interp creation */ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + Command *cmdPtr; + if ((cmdInfoPtr->objProc == NULL) - && (cmdInfoPtr->compileProc == NULL) - && (cmdInfoPtr->nreProc == NULL)) { + && (cmdInfoPtr->compileProc == NULL)) { Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc"); } - hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, - cmdInfoPtr->name, &isNew); - if (isNew) { - cmdPtr = ckalloc(sizeof(Command)); - cmdPtr->hPtr = hPtr; - cmdPtr->nsPtr = iPtr->globalNsPtr; - cmdPtr->refCount = 1; - cmdPtr->cmdEpoch = 0; - cmdPtr->compileProc = cmdInfoPtr->compileProc; - cmdPtr->proc = TclInvokeObjectCommand; - cmdPtr->clientData = cmdPtr; - cmdPtr->objProc = cmdInfoPtr->objProc; - cmdPtr->objClientData = NULL; - cmdPtr->deleteProc = NULL; - cmdPtr->deleteData = NULL; - cmdPtr->flags = 0; - cmdPtr->importRefPtr = NULL; - cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = cmdInfoPtr->nreProc; - Tcl_SetHashValue(hPtr, cmdPtr); - } + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, cmdInfoPtr->name, cmdInfoPtr->objProc, + NULL, NULL); + cmdPtr->compileProc = cmdInfoPtr->compileProc; } /* @@ -830,13 +764,7 @@ Tcl_CreateInterp(void) 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, + Tcl_CreateObjCommand(interp, "::tcl::unsupported::inject", NRCoroInjectObjCmd, NULL, NULL); #ifdef USE_DTRACE @@ -1486,8 +1414,7 @@ DeleteInterpProc( if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) { Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); } - Tcl_PopCallFrame(interp); - ckfree(iPtr->rootFramePtr); + TclPopStackFrame(interp); iPtr->rootFramePtr = NULL; Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); @@ -1497,7 +1424,6 @@ DeleteInterpProc( */ Tcl_FreeResult(interp); - iPtr->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); @@ -1519,10 +1445,6 @@ DeleteInterpProc( if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; - } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); @@ -2040,7 +1962,6 @@ 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 @@ -2224,7 +2145,6 @@ Tcl_CreateObjCommand( cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = NULL; /* * Plug in any existing import references found above. Be sure to update @@ -2282,8 +2202,7 @@ TclInvokeStringCommand( { Command *cmdPtr = clientData; int i, result; - const char **argv = - TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); + const char **argv = ckalloc((unsigned)(objc + 1) * sizeof(char *)); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); @@ -2296,7 +2215,7 @@ TclInvokeStringCommand( result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv); - TclStackFree(interp, (void *) argv); + ckfree((void *) argv); return result; } @@ -2312,7 +2231,7 @@ TclInvokeStringCommand( * in the Command structure. * * Results: - * A standard Tcl string result value. + * A standard Tcl result value. * * Side effects: * Besides those side effects of the called Tcl_CmdProc, @@ -2331,8 +2250,7 @@ TclInvokeObjectCommand( Command *cmdPtr = clientData; Tcl_Obj *objPtr; int i, length, result; - Tcl_Obj **objv = - TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *))); + Tcl_Obj **objv = ckalloc((unsigned)(argc * sizeof(Tcl_Obj *))); for (i = 0; i < argc; i++) { length = strlen(argv[i]); @@ -2345,19 +2263,8 @@ 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); - } - - /* - * Move the interpreter's object result to the string result, then reset - * the object result. - */ - - (void) Tcl_GetStringResult(interp); + result = Tcl_NRCallObjProc(interp, cmdPtr->objProc, + cmdPtr->objClientData, argc, objv); /* * Decrement the ref counts for the argument objects created above, then @@ -2368,7 +2275,7 @@ TclInvokeObjectCommand( objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } - TclStackFree(interp, objv); + ckfree(objv); return result; } @@ -2580,176 +2487,6 @@ 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. - * - * Results: - * If cmdName exists in interp, then the information at *infoPtr is - * stored with the command in place of the current information and 1 is - * returned. If the command doesn't exist then 0 is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetCommandInfo( - Tcl_Interp *interp, /* Interpreter in which to look for - * command. */ - const char *cmdName, /* Name of desired command. */ - const Tcl_CmdInfo *infoPtr) /* Where to find information to store in the - * command. */ -{ - Tcl_Command cmd; - - cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); - return Tcl_SetCommandInfoFromToken(cmd, infoPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetCommandInfoFromToken -- - * - * Modifies various information about a Tcl command. Note that this - * function will not change a command's namespace; use TclRenameCommand - * to do that. Also, the isNativeObjectProc member of *infoPtr is - * ignored. - * - * Results: - * If cmdName exists in interp, then the information at *infoPtr is - * stored with the command in place of the current information and 1 is - * returned. If the command doesn't exist then 0 is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetCommandInfoFromToken( - Tcl_Command cmd, - const Tcl_CmdInfo *infoPtr) -{ - Command *cmdPtr; /* Internal representation of the command */ - - if (cmd == NULL) { - return 0; - } - - /* - * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. - */ - - cmdPtr = (Command *) cmd; - cmdPtr->proc = infoPtr->proc; - cmdPtr->clientData = infoPtr->clientData; - if (infoPtr->objProc == NULL) { - cmdPtr->objProc = TclInvokeStringCommand; - cmdPtr->objClientData = cmdPtr; - cmdPtr->nreProc = NULL; - } else { - if (infoPtr->objProc != cmdPtr->objProc) { - cmdPtr->nreProc = NULL; - cmdPtr->objProc = infoPtr->objProc; - } - cmdPtr->objClientData = infoPtr->objClientData; - } - cmdPtr->deleteProc = infoPtr->deleteProc; - cmdPtr->deleteData = infoPtr->deleteData; - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetCommandInfo -- - * - * Returns various information about a Tcl command. - * - * Results: - * If cmdName exists in interp, then *infoPtr is modified to hold - * information about cmdName and 1 is returned. If the command doesn't - * exist then 0 is returned and *infoPtr isn't modified. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetCommandInfo( - Tcl_Interp *interp, /* Interpreter in which to look for - * command. */ - const char *cmdName, /* Name of desired command. */ - Tcl_CmdInfo *infoPtr) /* Where to store information about - * command. */ -{ - Tcl_Command cmd; - - cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); - return Tcl_GetCommandInfoFromToken(cmd, infoPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetCommandInfoFromToken -- - * - * Returns various information about a Tcl command. - * - * Results: - * Copies information from the command identified by 'cmd' into a - * caller-supplied structure and returns 1. If the 'cmd' is NULL, leaves - * the structure untouched and returns 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetCommandInfoFromToken( - Tcl_Command cmd, - Tcl_CmdInfo *infoPtr) -{ - Command *cmdPtr; /* Internal representation of the command */ - - if (cmd == NULL) { - return 0; - } - - /* - * Set isNativeObjectProc 1 if objProc was registered by a call to - * Tcl_CreateObjCommand. Otherwise set it to 0. - */ - - cmdPtr = (Command *) cmd; - infoPtr->isNativeObjectProc = - (cmdPtr->objProc != TclInvokeStringCommand); - infoPtr->objProc = cmdPtr->objProc; - infoPtr->objClientData = cmdPtr->objClientData; - infoPtr->proc = cmdPtr->proc; - infoPtr->clientData = cmdPtr->clientData; - infoPtr->deleteProc = cmdPtr->deleteProc; - infoPtr->deleteData = cmdPtr->deleteData; - infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; - - return 1; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_GetCommandName -- * * Given a token returned by Tcl_CreateCommand, this function returns the @@ -3343,360 +3080,6 @@ TclCleanupCommand( /* *---------------------------------------------------------------------- * - * Tcl_CreateMathFunc -- - * - * Creates a new math function for expressions in a given interpreter. - * - * Results: - * None. - * - * Side effects: - * The Tcl function defined by "name" is created or redefined. If the - * function already exists then its definition is replaced; this includes - * the builtin functions. Redefining a builtin function forces all - * existing code to be invalidated since that code may be compiled using - * an instruction specific to the replaced function. In addition, - * redefioning a non-builtin function will force existing code to be - * invalidated if the number of arguments has changed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CreateMathFunc( - Tcl_Interp *interp, /* Interpreter in which function is to be - * available. */ - const char *name, /* Name of function (e.g. "sin"). */ - int numArgs, /* Nnumber of arguments required by - * function. */ - Tcl_ValueType *argTypes, /* Array of types acceptable for each - * argument. */ - Tcl_MathProc *proc, /* C function that implements the math - * function. */ - ClientData clientData) /* Additional value to pass to the - * function. */ -{ - Tcl_DString bigName; - OldMathFuncData *data = ckalloc(sizeof(OldMathFuncData)); - - data->proc = proc; - data->numArgs = numArgs; - data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType)); - memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); - data->clientData = clientData; - - Tcl_DStringInit(&bigName); - TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::"); - Tcl_DStringAppend(&bigName, name, -1); - - Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName), - OldMathFuncProc, data, OldMathFuncDeleteProc); - Tcl_DStringFree(&bigName); -} - -/* - *---------------------------------------------------------------------- - * - * OldMathFuncProc -- - * - * Dispatch to a math function created with Tcl_CreateMathFunc - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Whatever the math function does. - * - *---------------------------------------------------------------------- - */ - -static int -OldMathFuncProc( - ClientData clientData, /* Ponter to OldMathFuncData describing the - * function being called */ - Tcl_Interp *interp, /* Tcl interpreter */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Parameter vector */ -{ - Tcl_Obj *valuePtr; - OldMathFuncData *dataPtr = clientData; - Tcl_Value funcResult, *args; - int result; - int j, k; - double d; - - /* - * Check argument count. - */ - - if (objc != dataPtr->numArgs + 1) { - MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv); - return TCL_ERROR; - } - - /* - * Convert arguments from Tcl_Obj's to Tcl_Value's. - */ - - args = ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); - for (j = 1, k = 0; j < objc; ++j, ++k) { - /* TODO: Convert to TclGetNumberFromObj? */ - valuePtr = objv[j]; - result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); -#ifdef ACCEPT_NAN - if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) { - d = valuePtr->internalRep.doubleValue; - result = TCL_OK; - } -#endif - if (result != TCL_OK) { - /* - * We have a non-numeric argument. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument to math function didn't have numeric value", - -1)); - TclCheckBadOctal(interp, 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. - */ - - 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; - } - 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; - } - - /* - * Return the result of the call. - */ - - if (funcResult.type == TCL_INT) { - TclNewLongObj(valuePtr, funcResult.intValue); - } else if (funcResult.type == TCL_WIDE_INT) { - valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); - } else { - return CheckDoubleResult(interp, funcResult.doubleValue); - } - Tcl_SetObjResult(interp, valuePtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * OldMathFuncDeleteProc -- - * - * Cleans up after deleting a math function registered with - * Tcl_CreateMathFunc - * - * Results: - * None. - * - * Side effects: - * Frees allocated memory. - * - *---------------------------------------------------------------------- - */ - -static void -OldMathFuncDeleteProc( - ClientData clientData) -{ - OldMathFuncData *dataPtr = clientData; - - ckfree(dataPtr->argTypes); - ckfree(dataPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetMathFuncInfo -- - * - * Discovers how a particular math function was created in a given - * interpreter. - * - * Results: - * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the - * interpreter result if that happens.) - * - * Side effects: - * If this function succeeds, the variables pointed to by the numArgsPtr - * and argTypePtr arguments will be updated to detail the arguments - * allowed by the function. The variable pointed to by the procPtr - * argument will be set to NULL if the function is a builtin function, - * and will be set to the address of the C function used to implement the - * math function otherwise (in which case the variable pointed to by the - * clientDataPtr argument will also be updated.) - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetMathFuncInfo( - Tcl_Interp *interp, - const char *name, - int *numArgsPtr, - Tcl_ValueType **argTypesPtr, - Tcl_MathProc **procPtr, - ClientData *clientDataPtr) -{ - Tcl_Obj *cmdNameObj; - Command *cmdPtr; - - /* - * Get the command that implements the math function. - */ - - TclNewLiteralStringObj(cmdNameObj, "tcl::mathfunc::"); - Tcl_AppendToObj(cmdNameObj, name, -1); - Tcl_IncrRefCount(cmdNameObj); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdNameObj); - Tcl_DecrRefCount(cmdNameObj); - - /* - * Report unknown functions. - */ - - if (cmdPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown math function \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL); - *numArgsPtr = -1; - *argTypesPtr = NULL; - *procPtr = NULL; - *clientDataPtr = NULL; - return TCL_ERROR; - } - - /* - * Retrieve function info for user defined functions; return dummy - * information for builtins. - */ - - if (cmdPtr->objProc == &OldMathFuncProc) { - OldMathFuncData *dataPtr = cmdPtr->clientData; - - *procPtr = dataPtr->proc; - *numArgsPtr = dataPtr->numArgs; - *argTypesPtr = dataPtr->argTypes; - *clientDataPtr = dataPtr->clientData; - } else { - *procPtr = NULL; - *numArgsPtr = -1; - *argTypesPtr = NULL; - *procPtr = NULL; - *clientDataPtr = NULL; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ListMathFuncs -- - * - * Produces a list of all the math functions defined in a given - * interpreter. - * - * Results: - * A pointer to a Tcl_Obj structure with a reference count of zero, or - * NULL in the case of an error (in which case a suitable error message - * will be left in the interpreter result.) - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_ListMathFuncs( - Tcl_Interp *interp, - const char *pattern) -{ - Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1); - Tcl_Obj *result; - Tcl_InterpState state; - - if (pattern) { - Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); - Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj); - - Tcl_AppendObjToObj(script, arg); - Tcl_DecrRefCount(arg); /* Should tear down patternObj too */ - } - - state = Tcl_SaveInterpState(interp, TCL_OK); - Tcl_IncrRefCount(script); - if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { - result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); - } else { - result = Tcl_NewObj(); - } - Tcl_DecrRefCount(script); - Tcl_RestoreInterpState(interp, state); - - return result; -} - -/* - *---------------------------------------------------------------------- - * * TclInterpReady -- * * Check if an interpreter is ready to eval commands or scripts, i.e., if @@ -3707,7 +3090,7 @@ Tcl_ListMathFuncs( * otherwise. * * Side effects: - * The interpreters object and string results are cleared. + * The interpreter's result is cleared. * *---------------------------------------------------------------------- */ @@ -3719,8 +3102,8 @@ TclInterpReady( register Interp *iPtr = (Interp *) interp; /* - * Reset both the interpreter's string and object results and clear out - * any previous error information. + * Reset the interpreter's result and clear out any previous error + * information. */ Tcl_ResetResult(interp); @@ -4210,18 +3593,12 @@ TclNREvalObjv( cmdPtr->refCount++; /* - * Find the objProc to call: nreProc if available, objProc otherwise. Push - * a callback to do the actual running. + * Find the objProc to call, push a callback to do the actual running. */ - if (cmdPtr->nreProc) { - TclNRAddCallback(interp, NRRunObjProc, cmdPtr, - INT2PTR(objc), (ClientData) objv, NULL); - - return TCL_OK; - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } + TclNRAddCallback(interp, NRRunObjProc, cmdPtr, + INT2PTR(objc), (ClientData) objv, NULL); + return TCL_OK; } void @@ -4240,24 +3617,9 @@ TclNRRunCallbacks( /* All callbacks down to rootPtr not inclusive * are to be run. */ { - Interp *iPtr = (Interp *) interp; NRE_callback *cbPtr; 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) { POP_CB(interp, cbPtr); procPtr = cbPtr->procPtr; @@ -4319,7 +3681,7 @@ NRRunObjProc( int objc = PTR2INT(data[1]); Tcl_Obj **objv = data[2]; - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); } @@ -4499,7 +3861,7 @@ TEOV_NotFound( Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv); newObjc = objc + handlerObjc; - newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc); + newObjv = ckalloc((int) sizeof(Tcl_Obj *) * newObjc); /* * Copy command prefix from unknown handler and add on the real command's @@ -4538,7 +3900,7 @@ TEOV_NotFound( for (i = 0; i < handlerObjc; ++i) { Tcl_DecrRefCount(newObjv[i]); } - TclStackFree(interp, newObjv); + ckfree(newObjv); return TCL_ERROR; } @@ -4577,7 +3939,7 @@ TEOV_NotFoundCallback( for (i = 0; i < objc; ++i) { Tcl_DecrRefCount(objv[i]); } - TclStackFree(interp, objv); + ckfree(objv); return result; } @@ -4746,54 +4108,6 @@ 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. - * - * Results: - * The return value is a pointer to a newly allocated Tcl_Obj containing - * the value of the array of tokens. The reference count of the returned - * object has been incremented. If an error occurs in evaluating the - * tokens then a NULL value is returned and an error message is left in - * interp's result. - * - * Side effects: - * A new object is allocated to hold the result. - * - *---------------------------------------------------------------------- - * - * This uses a non-standard return convention; its use is now deprecated. It - * is a wrapper for the new function Tcl_EvalTokensStandard, and is not used - * in the core any longer. It is only kept for backward compatibility. - */ - -Tcl_Obj * -Tcl_EvalTokens( - Tcl_Interp *interp, /* Interpreter in which to lookup variables, - * execute nested commands, and report - * errors. */ - Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to - * evaluate and concatenate. */ - int count) /* Number of tokens to consider at tokenPtr. - * Must be at least 1. */ -{ - Tcl_Obj *resPtr; - - if (Tcl_EvalTokensStandard(interp, tokenPtr, count) != TCL_OK) { - return NULL; - } - resPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resPtr); - Tcl_ResetResult(interp); - return resPtr; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_EvalEx, TclEvalEx -- * * This function evaluates a Tcl script without using the compiler or @@ -4839,10 +4153,10 @@ Tcl_EvalEx( * 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)); + Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse)); Tcl_Obj **stackObjArray = - TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *)); - int *expandStack = TclStackAlloc(interp, minObjs * sizeof(int)); + ckalloc(minObjs * sizeof(Tcl_Obj *)); + int *expandStack = ckalloc(minObjs * sizeof(int)); if (numBytes < 0) { numBytes = strlen(script); @@ -5069,9 +4383,9 @@ Tcl_EvalEx( iPtr->varFramePtr = savedVarFramePtr; cleanup_return: - TclStackFree(interp, expandStack); - TclStackFree(interp, stackObjArray); - TclStackFree(interp, parsePtr); + ckfree(expandStack); + ckfree(stackObjArray); + ckfree(parsePtr); return code; } @@ -5104,50 +4418,7 @@ Tcl_Eval( * previous call to Tcl_CreateInterp). */ const char *script) /* Pointer to TCL command to execute. */ { - int code = Tcl_EvalEx(interp, script, -1, 0); - - /* - * For backwards compatibility with old C code that predates the object - * system in Tcl 8.0, we have to mirror the object result back into the - * string result (some callers may expect it there). - */ - - (void) Tcl_GetStringResult(interp); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalObj, Tcl_GlobalEvalObj -- - * - * These functions are deprecated but we keep them around for backwards - * compatibility reasons. - * - * Results: - * See the functions they call. - * - * Side effects: - * See the functions they call. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_EvalObj -int -Tcl_EvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - return Tcl_EvalObjEx(interp, objPtr, 0); -} -#undef Tcl_GlobalEvalObj -int -Tcl_GlobalEvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); + return Tcl_EvalEx(interp, script, -1, 0); } /* @@ -5156,8 +4427,8 @@ 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, or run directly if the obj is a canonical + * list. * * Results: * The return value is one of the return codes defined in tcl.h (such as @@ -5180,7 +4451,7 @@ Tcl_EvalObjEx( * 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. */ + * are TCL_EVAL_GLOBAL. */ { int result = TCL_OK; NRE_callback *rootPtr = TOP_CB(interp); @@ -5197,10 +4468,9 @@ TclNREvalObjEx( * 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. */ + * are TCL_EVAL_GLOBAL. */ { Interp *iPtr = (Interp *) interp; - int result; /* * This function consists of three independent blocks for: direct @@ -5249,9 +4519,7 @@ TclNREvalObjEx( ListObjGetElements(listPtr, objc, objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); - } - - if (!(flags & TCL_EVAL_DIRECT)) { + } else { /* * Let the compiler/engine subsystem do the evaluation. */ @@ -5276,24 +4544,6 @@ TclNREvalObjEx( objPtr, INT2PTR(allowExceptions), NULL); return TclNRExecuteByteCode(interp, codePtr); } - - { - /* - * We're not supposed to use the compiler or byte-code - * interpreter. Let Tcl_EvalEx evaluate the command directly (and - * probably more slowly). - * - */ - - const char *script; - int numSrcBytes; - - Tcl_IncrRefCount(objPtr); - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - TclDecrRefCount(objPtr); - return result; - } } static int @@ -5438,9 +4688,6 @@ Tcl_ExprLong( Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); - if (result != TCL_OK) { - (void) Tcl_GetStringResult(interp); - } } return result; } @@ -5467,9 +4714,6 @@ Tcl_ExprDouble( result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); /* Discard the expression object. */ - if (result != TCL_OK) { - (void) Tcl_GetStringResult(interp); - } } return result; } @@ -5495,14 +4739,6 @@ Tcl_ExprBoolean( Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); - if (result != TCL_OK) { - /* - * Move the interpreter's object result to the string result, then - * reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - } return result; } } @@ -5665,7 +4901,7 @@ TclObjInvokeNamespace( * or TCL_INVOKE_NO_TRACEBACK. */ { int result; - Tcl_CallFrame *framePtr; + CallFrame *framePtr; /* * Make the specified namespace the current namespace and invoke the @@ -5755,12 +4991,8 @@ TclObjInvoke( */ 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 = Tcl_NRCallObjProc(interp, cmdPtr->objProc, + cmdPtr->objClientData, objc, objv); /* * If an error occurred, record information about what was being executed @@ -5828,12 +5060,6 @@ Tcl_ExprString( Tcl_DecrRefCount(resultPtr); } } - - /* - * Force the string rep of the interp result. - */ - - (void) Tcl_GetStringResult(interp); return code; } @@ -5937,19 +5163,7 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { - if (iPtr->result[0] != 0) { - /* - * The interp's string result is set, apparently by some extension - * making a deprecated direct write to it. That extension may - * expect interp->result to continue to be set, so we'll take - * special pains to avoid clearing it, until we drop support for - * interp->result completely. - */ - - iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); - } else { - iPtr->errorInfo = iPtr->objResultPtr; - } + iPtr->errorInfo = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); @@ -5971,122 +5185,6 @@ Tcl_AddObjErrorInfo( } /* - *--------------------------------------------------------------------------- - * - * Tcl_VarEvalVA -- - * - * Given a variable number of string arguments, concatenate them all - * together and execute the result as a Tcl command. - * - * Results: - * A standard Tcl return result. An error message or other result may be - * left in the interp's result. - * - * Side effects: - * Depends on what was done by the command. - * - *--------------------------------------------------------------------------- - */ - -int -Tcl_VarEvalVA( - Tcl_Interp *interp, /* Interpreter in which to evaluate command */ - va_list argList) /* Variable argument list. */ -{ - Tcl_DString buf; - char *string; - int result; - - /* - * Copy the strings one after the other into a single larger string. Use - * stack-allocated space for small commands, but if the command gets too - * large than call ckalloc to create the space. - */ - - Tcl_DStringInit(&buf); - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - Tcl_DStringAppend(&buf, string, -1); - } - - result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); - Tcl_DStringFree(&buf); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_VarEval -- - * - * Given a variable number of string arguments, concatenate them all - * together and execute the result as a Tcl command. - * - * Results: - * A standard Tcl return result. An error message or other result may be - * left in interp->result. - * - * Side effects: - * Depends on what was done by the command. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -int -Tcl_VarEval( - Tcl_Interp *interp, - ...) -{ - va_list argList; - int result; - - va_start(argList, interp); - result = Tcl_VarEvalVA(interp, argList); - va_end(argList); - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GlobalEval -- - * - * Evaluate a command at global level in an interpreter. - * - * Results: - * A standard Tcl result is returned, and the interp's result is modified - * accordingly. - * - * Side effects: - * The command string is executed in interp, and the execution is carried - * out in the variable context of global level (no functions active), - * just as if an "uplevel #0" command were being executed. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GlobalEval( - Tcl_Interp *interp, /* Interpreter in which to evaluate - * command. */ - const char *command) /* Command to evaluate. */ -{ - register Interp *iPtr = (Interp *) interp; - int result; - CallFrame *savedVarFramePtr; - - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = iPtr->rootFramePtr; - result = Tcl_Eval(interp, command); - iPtr->varFramePtr = savedVarFramePtr; - return result; -} - -/* *---------------------------------------------------------------------- * * Tcl_SetRecursionLimit -- @@ -7195,60 +6293,6 @@ Tcl_NRCallObjProc( return TclNRRunCallbacks(interp, result, rootPtr); } -/* - *---------------------------------------------------------------------- - * - * Tcl_NRCreateCommand -- - * - * Define a new NRE-enabled object-based command in a command table. - * - * Results: - * The return value is a token for the command, which can be used in - * future calls to Tcl_GetCommandName. - * - * Side effects: - * If no command named "cmdName" already exists for interp, one is - * created. Otherwise, if a command does exist, then if the object-based - * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand - * was called previously for the same command and just set its - * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old - * command. - * - * In the future, during bytecode evaluation when "cmdName" is seen as - * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based - * Tcl_ObjCmdProc proc will be called. When the command is deleted from - * the table, deleteProc will be called. See the manual entry for details - * on the calling sequence. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -Tcl_NRCreateCommand( - Tcl_Interp *interp, /* Token for command interpreter (returned by - * previous call to Tcl_CreateInterp). */ - const char *cmdName, /* Name of command. If it contains namespace - * qualifiers, the new command is put in the - * specified namespace; otherwise it is put in - * the global namespace. */ - Tcl_ObjCmdProc *proc, /* Object-based function to associate with - * name, provides direct access for direct - * calls. */ - Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with - * name, provides NR implementation */ - ClientData clientData, /* Arbitrary value to pass to object - * function. */ - Tcl_CmdDeleteProc *deleteProc) - /* If not NULL, gives a function to call when - * this command is deleted. */ -{ - Command *cmdPtr = (Command *) - Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); - - cmdPtr->nreProc = nreProc; - return (Tcl_Command) cmdPtr; -} - /**************************************************************************** * Stuff for the public api ****************************************************************************/ @@ -7941,7 +6985,7 @@ NRCoroInjectObjCmd( } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); - if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { + if ((!cmdPtr) || (cmdPtr->deleteProc != DeleteCoroutine)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a command into a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", @@ -8098,8 +7142,8 @@ TclNRCoroutineObjCmd( } Tcl_DStringAppend(&ds, procName, -1); - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + TclNRInterpCoroutine, corPtr, DeleteCoroutine); Tcl_DStringFree(&ds); corPtr->cmdPtr = cmdPtr; |