summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog22
-rw-r--r--generic/tclBasic.c35
-rw-r--r--generic/tclDictObj.c28
-rw-r--r--generic/tclEvent.c7
-rw-r--r--generic/tclFCmd.c8
-rw-r--r--generic/tclIOGT.c10
-rw-r--r--generic/tclInt.h10
-rw-r--r--generic/tclResult.c157
-rw-r--r--generic/tclTrace.c122
9 files changed, 249 insertions, 150 deletions
diff --git a/ChangeLog b/ChangeLog
index 4ef89d5..2dad878 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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) {
generated by cgit v0.12 at 2024-07-15 13:02:11 (GMT)