diff options
| -rw-r--r-- | ChangeLog | 22 | ||||
| -rw-r--r-- | generic/tclBasic.c | 35 | ||||
| -rw-r--r-- | generic/tclDictObj.c | 28 | ||||
| -rw-r--r-- | generic/tclEvent.c | 7 | ||||
| -rw-r--r-- | generic/tclFCmd.c | 8 | ||||
| -rw-r--r-- | generic/tclIOGT.c | 10 | ||||
| -rw-r--r-- | generic/tclInt.h | 10 | ||||
| -rw-r--r-- | generic/tclResult.c | 157 | ||||
| -rw-r--r-- | generic/tclTrace.c | 122 |
9 files changed, 249 insertions, 150 deletions
@@ -1,3 +1,25 @@ +2004-10-19 Don Porter <dgp@users.sourceforge.net> + + * generic/tclInt.h (Tcl*InterpState): New internal routines + * generic/tclResult.c (Tcl*InterpState): TclSaveInterpState, + TclRestoreInterpState, and TclDiscardInterpState are superior + replacements for Tcl_(Save|Restore|Discard)Result. Intent is that + these routines will be converted to public routines after TIP approval. + + * generic/tclBasic.c (TclEvalObjvInternal): + * generic/tclDictObj.c (DictUpdateCmd, DictWithCmd): + * generic/tclIOGT.c (ExecuteCallback): + * generic/tclTrace.c (Trace*Proc,TclCheck*Traces,TclCallVarTraces): + Callers of Tcl_*Result updated to call the new routines. The + calls were relocated in several cases to perform save/restore + operations only when needed. + + * generic/tclEvent.c (HandleBgErrors): + * generic/tclFCmd.c (CopyRenameOneFile): + Calls to Tcl_*Result that were eliminated because they appeared + to serve no useful purpose, typically saving/restoring an error + message, only to throw it away. + 2004-10-18 Don Porter <dgp@users.sourceforge.net> * generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp): diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 84b934d..c568e30 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,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.128 2004/10/18 21:15:34 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.129 2004/10/19 21:54:06 dgp Exp $ */ #include "tclInt.h" @@ -3059,17 +3059,6 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) * Call 'leave' command traces */ if (!(cmdPtr->flags & CMD_IS_DELETED)) { - int saveErrFlags = iPtr->flags & ERR_ALREADY_LOGGED; - Tcl_Obj *saveOptions = iPtr->returnOpts; - Tcl_Obj *saveErrInfo = iPtr->errorInfo; - Tcl_Obj *saveErrCode = iPtr->errorCode; - if (saveErrInfo) { - Tcl_IncrRefCount(saveErrInfo); - } - if (saveErrCode) { - Tcl_IncrRefCount(saveErrCode); - } - Tcl_IncrRefCount(saveOptions); if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); @@ -3078,28 +3067,6 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) traceCode = TclCheckInterpTraces(interp, command, length, cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); } - if (traceCode == TCL_OK) { - Tcl_DecrRefCount(iPtr->returnOpts); - iPtr->returnOpts = saveOptions; - Tcl_IncrRefCount(iPtr->returnOpts); - iPtr->flags |= saveErrFlags; - if (iPtr->errorCode) { - Tcl_DecrRefCount(iPtr->errorCode); - } - iPtr->errorCode = saveErrCode; - if (iPtr->errorInfo) { - Tcl_DecrRefCount(iPtr->errorInfo); - } - iPtr->errorInfo = saveErrInfo; - } else { - if (saveErrCode) { - Tcl_DecrRefCount(saveErrCode); - } - if (saveErrInfo) { - Tcl_DecrRefCount(saveErrInfo); - } - } - Tcl_DecrRefCount(saveOptions); } TclCleanupCommand(cmdPtr); diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 6f78c9c..6d99243 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDictObj.c,v 1.24 2004/10/11 19:58:31 dkf Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.25 2004/10/19 21:54:06 dgp Exp $ */ #include "tclInt.h" @@ -2739,7 +2739,7 @@ DictUpdateCmd(interp, objc, objv) { Tcl_Obj *dictPtr, *objPtr; int i, result, dummy, allocdict = 0; - Tcl_SavedResult sr; + TclInterpState state; if (objc < 6 || objc & 1) { Tcl_WrongNumArgs(interp, 2, objv, @@ -2794,9 +2794,9 @@ DictUpdateCmd(interp, objc, objv) * Double-check that it is still a dictionary. */ - Tcl_SaveResult(interp, &sr); + state = TclSaveInterpState(interp, result); if (Tcl_DictObjSize(interp, dictPtr, &dummy) != TCL_OK) { - Tcl_DiscardResult(&sr); + TclDiscardInterpState(state); return TCL_ERROR; } @@ -2826,15 +2826,14 @@ DictUpdateCmd(interp, objc, objv) if (Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DiscardResult(&sr); + TclDiscardInterpState(state); if (allocdict) { TclDecrRefCount(dictPtr); } return TCL_ERROR; } - Tcl_RestoreResult(interp, &sr); - return result; + return TclRestoreInterpState(interp, state); } /* @@ -2863,7 +2862,7 @@ DictWithCmd(interp, objc, objv) { Tcl_Obj *dictPtr, *keysPtr, *keyPtr, *valPtr, **keyv, *leafPtr; Tcl_DictSearch s; - Tcl_SavedResult sr; + TclInterpState state; int done, result, keyc, i, allocdict=0; if (objc < 4) { @@ -2939,10 +2938,10 @@ DictWithCmd(interp, objc, objv) * Double-check that it is still a dictionary. */ - Tcl_SaveResult(interp, &sr); + state = TclSaveInterpState(interp, result); if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) { TclDecrRefCount(keysPtr); - Tcl_DiscardResult(&sr); + TclDiscardInterpState(state); return TCL_ERROR; } @@ -2968,7 +2967,7 @@ DictWithCmd(interp, objc, objv) if (allocdict) { TclDecrRefCount(dictPtr); } - Tcl_DiscardResult(&sr); + TclDiscardInterpState(state); return TCL_ERROR; } if (leafPtr == DICT_PATH_NON_EXISTENT) { @@ -2976,7 +2975,7 @@ DictWithCmd(interp, objc, objv) if (allocdict) { TclDecrRefCount(dictPtr); } - Tcl_RestoreResult(interp, &sr); + TclRestoreInterpState(interp, state); return TCL_OK; } } else { @@ -3016,11 +3015,10 @@ DictWithCmd(interp, objc, objv) if (allocdict) { TclDecrRefCount(dictPtr); } - Tcl_DiscardResult(&sr); + TclDiscardInterpState(state); return TCL_ERROR; } - Tcl_RestoreResult(interp, &sr); - return result; + return TclRestoreInterpState(interp, state); } /* diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 5ef1533..9eb195f 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.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: tclEvent.c,v 1.48 2004/10/15 04:01:29 dgp Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.49 2004/10/19 21:54:06 dgp Exp $ */ #include "tclInt.h" @@ -291,11 +291,8 @@ HandleBgErrors(clientData) */ if (Tcl_IsSafe(interp)) { - Tcl_SavedResult save; - - Tcl_SaveResult(interp, &save); + Tcl_ResetResult(interp); TclObjInvoke(interp, 2, objv, TCL_INVOKE_HIDDEN); - Tcl_RestoreResult(interp, &save); } else { /* diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 17959fc..a74b6d6 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFCmd.c,v 1.28 2004/10/06 14:59:02 dgp Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.29 2004/10/19 21:54:07 dgp Exp $ */ #include "tclInt.h" @@ -642,7 +642,6 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * cross-filesystem copy. We do this through our Tcl * library. */ - Tcl_SavedResult savedResult; Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL); Tcl_IncrRefCount(copyCommand); Tcl_ListObjAppendElement(interp, copyCommand, @@ -656,7 +655,6 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) } Tcl_ListObjAppendElement(interp, copyCommand, source); Tcl_ListObjAppendElement(interp, copyCommand, target); - Tcl_SaveResult(interp, &savedResult); result = Tcl_EvalObjEx(interp, copyCommand, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); Tcl_DecrRefCount(copyCommand); @@ -666,11 +664,7 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * We will pass on the Tcl error message and * can ensure this by setting errfile to NULL */ - Tcl_DiscardResult(&savedResult); errfile = NULL; - } else { - /* The copy was successful */ - Tcl_RestoreResult(interp, &savedResult); } } else { errfile = errorBuffer; diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 22e5362..37b57be 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * CVS: $Id: tclIOGT.c,v 1.10 2004/10/06 13:47:34 dkf Exp $ + * CVS: $Id: tclIOGT.c,v 1.11 2004/10/19 21:54:07 dgp Exp $ */ #include "tclInt.h" @@ -383,13 +383,13 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) Tcl_Obj* resObj; /* See below, switch (transmit) */ int resLen; unsigned char* resBuf; - Tcl_SavedResult ciSave; + TclInterpState state = NULL; int res = TCL_OK; Tcl_Obj* command = Tcl_DuplicateObj (dataPtr->command); Tcl_Obj* temp; if (preserve) { - Tcl_SaveResult (dataPtr->interp, &ciSave); + state = TclSaveInterpState(dataPtr->interp, res); } if (command == (Tcl_Obj*) NULL) { @@ -488,14 +488,14 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) Tcl_ResetResult(dataPtr->interp); if (preserve) { - Tcl_RestoreResult(dataPtr->interp, &ciSave); + (void) TclRestoreInterpState(dataPtr->interp, state); } return res; cleanup: if (preserve) { - Tcl_RestoreResult(dataPtr->interp, &ciSave); + (void) TclRestoreInterpState(dataPtr->interp, state); } if (command != (Tcl_Obj*) NULL) { diff --git a/generic/tclInt.h b/generic/tclInt.h index 3ffaacc..260e8dc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.182 2004/10/18 21:15:41 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.183 2004/10/19 21:54:07 dgp Exp $ */ #ifndef _TCLINT @@ -1422,6 +1422,8 @@ typedef struct Interp { #define SAFE_INTERP 0x80 #define INTERP_TRACE_IN_PROGRESS 0x200 +typedef struct TclInterpState_ *TclInterpState; + /* * Maximum number of levels of nesting permitted in Tcl commands (used * to catch infinite recursion). @@ -1708,6 +1710,8 @@ EXTERN int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp, CONST char *value)); EXTERN void TclCleanupLiteralTable _ANSI_ARGS_(( Tcl_Interp* interp, LiteralTable* tablePtr )); +EXTERN void TclDiscardInterpState _ANSI_ARGS_ (( + TclInterpState state)); EXTERN void TclExpandTokenArray _ANSI_ARGS_(( Tcl_Parse *parsePtr)); EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, @@ -1904,6 +1908,10 @@ EXTERN VOID TclRememberJoinableThread _ANSI_ARGS_((Tcl_ThreadId id)) EXTERN void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex)); EXTERN void TclRemoveScriptLimitCallbacks _ANSI_ARGS_(( Tcl_Interp *interp)); +EXTERN int TclRestoreInterpState _ANSI_ARGS_ (( + Tcl_Interp *interp, TclInterpState state)); +EXTERN TclInterpState TclSaveInterpState _ANSI_ARGS_ (( + Tcl_Interp *interp, int status)); EXTERN VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id, int result)); EXTERN int TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp, diff --git a/generic/tclResult.c b/generic/tclResult.c index 2545d1f..de474f7 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclResult.c,v 1.16 2004/10/17 14:22:08 msofer Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.17 2004/10/19 21:54:07 dgp Exp $ */ #include "tclInt.h" @@ -21,6 +21,159 @@ static void ResetObjResult _ANSI_ARGS_((Interp *iPtr)); static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, int newSpace)); +/* + * This structure is used to take a snapshot of the interpreter + * state in TclSaveInterpState. You can snapshot the state, + * execute a command, and then back up to the result or the + * error that was previously in progress. + */ +typedef struct InterpState { + int status; /* return code status */ + int flags; /* Each remaining field saves */ + int returnLevel; /* the corresponding field of */ + int returnCode; /* the Interp struct. These */ + Tcl_Obj *errorInfo; /* fields take together are the */ + Tcl_Obj *errorCode; /* "state" of the interp. */ + Tcl_Obj *returnOpts; + Tcl_Obj *objResult; +} InterpState; + + +/* + *---------------------------------------------------------------------- + * + * TclSaveInterpState -- + * + * Fills a token with a snapshot of the current state of the + * interpreter. The snapshot can be restored at any point by + * TclRestoreInterpState. + * + * The token returned must be eventally passed to one of the + * routines TclRestoreInterpState or TclDiscardInterpState, + * or there will be a memory leak. + * + * Results: + * Returns a token representing the interp state. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclInterpState +TclSaveInterpState(interp, status) + Tcl_Interp* interp; /* Interpreter's state to be saved */ + int status; /* status code for current operation */ +{ + Interp *iPtr = (Interp *)interp; + InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState)); + + statePtr->status = status; + statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED; + statePtr->returnLevel = iPtr->returnLevel; + statePtr->returnCode = iPtr->returnCode; + statePtr->errorInfo = iPtr->errorInfo; + if (statePtr->errorInfo) { + Tcl_IncrRefCount(statePtr->errorInfo); + } + statePtr->errorCode = iPtr->errorCode; + if (statePtr->errorCode) { + Tcl_IncrRefCount(statePtr->errorCode); + } + statePtr->returnOpts = iPtr->returnOpts; + if (statePtr->returnOpts) { + Tcl_IncrRefCount(statePtr->returnOpts); + } + statePtr->objResult = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(statePtr->objResult); + return (TclInterpState) statePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclRestoreInterpState -- + * + * Accepts an interp and a token previously returned by + * TclSaveInterpState. Restore the state of the interp + * to what it was at the time of the TclSaveInterpState call. + * + * Results: + * Returns the status value originally passed in to TclSaveInterpState. + * + * Side effects: + * Restores the interp state and frees memory held by token. + * + *---------------------------------------------------------------------- + */ + +int +TclRestoreInterpState(interp, state) + Tcl_Interp* interp; /* Interpreter's state to be restored*/ + TclInterpState state; /* saved interpreter state */ +{ + Interp *iPtr = (Interp *)interp; + InterpState *statePtr = (InterpState *)state; + int status = statePtr->status; + + iPtr->flags &= ~ERR_ALREADY_LOGGED; + iPtr->flags |= (statePtr->flags & ERR_ALREADY_LOGGED); + + iPtr->returnLevel = statePtr->returnLevel; + iPtr->returnCode = statePtr->returnCode; + iPtr->errorInfo = statePtr->errorInfo; + if (iPtr->errorInfo) { + Tcl_IncrRefCount(iPtr->errorInfo); + } + iPtr->errorCode = statePtr->errorCode; + if (iPtr->errorCode) { + Tcl_IncrRefCount(iPtr->errorCode); + } + iPtr->returnOpts = statePtr->returnOpts; + if (iPtr->returnOpts) { + Tcl_IncrRefCount(iPtr->returnOpts); + } + Tcl_SetObjResult(interp, statePtr->objResult); + TclDiscardInterpState(state); + return status; +} + +/* + *---------------------------------------------------------------------- + * + * TclDiscardInterpState -- + * + * Accepts a token previously returned by TclSaveInterpState. + * Frees the memory it uses. + * + * Results: + * None. + * + * Side effects: + * Frees memory. + * + *---------------------------------------------------------------------- + */ + +void +TclDiscardInterpState(state) + TclInterpState state; /* saved interpreter state */ +{ + InterpState *statePtr = (InterpState *)state; + + if (statePtr->errorInfo) { + Tcl_DecrRefCount(statePtr->errorInfo); + } + if (statePtr->errorCode) { + Tcl_DecrRefCount(statePtr->errorCode); + } + if (statePtr->returnOpts) { + Tcl_DecrRefCount(statePtr->returnOpts); + } + Tcl_DecrRefCount(statePtr->objResult); + ckfree((char*) statePtr); +} /* *---------------------------------------------------------------------- @@ -739,7 +892,7 @@ Tcl_ResetResult(interp) iPtr->errorCode = NULL; } if (iPtr->errorInfo) { - /* Legacy support*/ + /* Legacy support */ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); Tcl_DecrRefCount(iPtr->errorInfo); diff --git a/generic/tclTrace.c b/generic/tclTrace.c index b2067b3..3d5e835 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTrace.c,v 1.16 2004/10/15 04:01:33 dgp Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.17 2004/10/19 21:54:07 dgp Exp $ */ #include "tclInt.h" @@ -1286,9 +1286,6 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) int flags; /* OR-ed bits giving operation and other * information. */ { - Interp *iPtr = (Interp *) interp; - Tcl_Obj *stateReturnOpts; - Tcl_SavedResult state; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int code; Tcl_DString cmd; @@ -1313,38 +1310,23 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) } /* - * Execute the command. Save the interp's result used for the - * command, including the value of iPtr->returnOpts which may be - * modified when Tcl_Eval is invoked. We discard any object - * result the command returns. + * Execute the command. + * We discard any object result the command returns. * * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to * other areas that this will be destroyed by us, otherwise a * double-free might occur depending on what the eval does. */ - Tcl_SaveResult(interp, &state); - stateReturnOpts = iPtr->returnOpts; - Tcl_IncrRefCount(stateReturnOpts); if (flags & TCL_TRACE_DESTROYED) { tcmdPtr->flags |= TCL_TRACE_DESTROYED; } - code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); if (code != TCL_OK) { /* We ignore errors in these traced commands */ /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/ } - - Tcl_RestoreResult(interp, &state); - if (iPtr->returnOpts != stateReturnOpts) { - Tcl_DecrRefCount(iPtr->returnOpts); - iPtr->returnOpts = stateReturnOpts; - Tcl_IncrRefCount(iPtr->returnOpts); - } - Tcl_DecrRefCount(stateReturnOpts); - Tcl_DStringFree(&cmd); } /* @@ -1440,6 +1422,7 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, int curLevel; int traceCode = TCL_OK; TraceCommandInfo* tcmdPtr; + TclInterpState state = NULL; if (command == NULL || cmdPtr->tracePtr == NULL) { return traceCode; @@ -1471,6 +1454,9 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; tcmdPtr->curCode = code; tcmdPtr->refCount++; + if (state == NULL) { + state = TclSaveInterpState(interp, code); + } traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, curLevel, command, (Tcl_Command)cmdPtr, objc, objv); if ((--tcmdPtr->refCount) <= 0) { @@ -1480,6 +1466,9 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, lastTracePtr = tracePtr; } iPtr->activeCmdTracePtr = active.nextPtr; + if (state) { + (void) TclRestoreInterpState(interp, state); + } return(traceCode); } @@ -1525,6 +1514,7 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, int curLevel; int traceCode = TCL_OK; TraceCommandInfo* tcmdPtr; + TclInterpState state = NULL; if (command == NULL || iPtr->tracePtr == NULL || (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { @@ -1571,6 +1561,9 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, */ Tcl_Preserve((ClientData) tracePtr); tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; + if (state == NULL) { + state = TclSaveInterpState(interp, code); + } if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { /* New style trace */ @@ -1603,6 +1596,13 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, lastTracePtr = tracePtr; } iPtr->activeInterpTracePtr = active.nextPtr; + if (state) { + if (traceCode == TCL_OK) { + (void) TclRestoreInterpState(interp, state); + } else { + TclDiscardInterpState(state); + } + } return(traceCode); } @@ -1765,8 +1765,6 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, * Second, create the tcl callback, if required. */ if (call) { - Tcl_SavedResult state; - Tcl_Obj *stateReturnOpts; Tcl_DString cmd; Tcl_DString sub; int i; @@ -1814,16 +1812,10 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, } /* - * Execute the command. Save the interp's result used for - * the command, including the value of iPtr->returnOpts which - * may be modified when Tcl_Eval is invoked. We discard any - * object result the command returns. + * Execute the command. + * We discard any object result the command returns. */ - Tcl_SaveResult(interp, &state); - stateReturnOpts = iPtr->returnOpts; - Tcl_IncrRefCount(stateReturnOpts); - tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; iPtr->flags |= INTERP_TRACE_IN_PROGRESS; tcmdPtr->refCount++; @@ -1838,20 +1830,6 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, if (tcmdPtr->flags == 0) { flags |= TCL_TRACE_DESTROYED; } - - if (traceCode == TCL_OK) { - /* Restore result if trace execution was successful */ - Tcl_RestoreResult(interp, &state); - if (iPtr->returnOpts != stateReturnOpts) { - Tcl_DecrRefCount(iPtr->returnOpts); - iPtr->returnOpts = stateReturnOpts; - Tcl_IncrRefCount(iPtr->returnOpts); - } - } else { - Tcl_DiscardResult(&state); - } - Tcl_DecrRefCount(stateReturnOpts); - Tcl_DStringFree(&cmd); } @@ -1923,7 +1901,6 @@ TraceVarProc(clientData, interp, name1, name2, flags) int flags; /* OR-ed bits giving operation and other * information. */ { - Tcl_SavedResult state; TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; char *result; int code; @@ -1979,19 +1956,17 @@ TraceVarProc(clientData, interp, name1, name2, flags) #endif /* - * Execute the command. Save the interp's result used for - * the command. We discard any object result the command returns. + * Execute the command. + * We discard any object result the command returns. * * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to * other areas that this will be destroyed by us, otherwise a * double-free might occur depending on what the eval does. */ - Tcl_SaveResult(interp, &state); if (flags & TCL_TRACE_DESTROYED) { tvarPtr->flags |= TCL_TRACE_DESTROYED; } - code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); if (code != TCL_OK) { /* copy error msg to result */ @@ -1999,9 +1974,6 @@ TraceVarProc(clientData, interp, name1, name2, flags) Tcl_IncrRefCount(errMsgObj); result = (char *) errMsgObj; } - - Tcl_RestoreResult(interp, &state); - Tcl_DStringFree(&cmd); } } @@ -2450,16 +2422,7 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) int copiedName; int code = TCL_OK; int disposeFlags = 0; - int saveErrFlags = iPtr->flags & ERR_ALREADY_LOGGED; - Tcl_Obj *saveErrInfo = iPtr->errorInfo; - Tcl_Obj *saveErrCode = iPtr->errorCode; - - if (saveErrInfo) { - Tcl_IncrRefCount(saveErrInfo); - } - if (saveErrCode) { - Tcl_IncrRefCount(saveErrCode); - } + TclInterpState state = NULL; /* * If there are already similar trace procedures active for the @@ -2526,6 +2489,9 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) continue; } Tcl_Preserve((ClientData) tracePtr); + if (state == NULL) { + state = TclSaveInterpState((Tcl_Interp *)iPtr, code); + } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { @@ -2559,6 +2525,9 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) continue; } Tcl_Preserve((ClientData) tracePtr); + if (state == NULL) { + state = TclSaveInterpState((Tcl_Interp *)iPtr, code); + } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { @@ -2582,24 +2551,6 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) */ done: - if (code == TCL_OK) { - iPtr->flags |= saveErrFlags; - if (iPtr->errorInfo) { - Tcl_DecrRefCount(iPtr->errorInfo); - } - iPtr->errorInfo = saveErrInfo; - if (iPtr->errorCode) { - Tcl_DecrRefCount(iPtr->errorCode); - } - iPtr->errorCode = saveErrCode; - } else { - if (saveErrInfo) { - Tcl_DecrRefCount(saveErrInfo); - } - if (saveErrCode) { - Tcl_DecrRefCount(saveErrCode); - } - } if (code == TCL_ERROR) { if (leaveErrMsg) { CONST char *type = ""; @@ -2623,8 +2574,17 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) } else { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result); } + TclDiscardInterpState(state); + } else { + (void) TclRestoreInterpState((Tcl_Interp *)iPtr, state); } DisposeTraceResult(disposeFlags,result); + } else if (state) { + if (code == TCL_OK) { + code = TclRestoreInterpState((Tcl_Interp *)iPtr, state); + } else { + TclDiscardInterpState(state); + } } if (arrayPtr != NULL) { |