From 81faf4a2ce359423c0d9e7c6a0980c9e2ac67697 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Mon, 12 Nov 2007 03:38:12 +0000 Subject: * generic/tclBasic.c: New macro TclResetResult, new iPtr flag * generic/tclExecute.c: bit INTERP_RESULT_UNCLEAN: shortcut for * generic/tclInt.h: Tcl_ResetResult for the "normal" case: * generic/tclProc.c: TCL_OK, no return options, no errorCode * generic/tclResult.c: nor errorInfo, return at normal level. * generic/tclStubLib.c: [Patch 1830184] * generic/tclUtil.c: --- ChangeLog | 13 +++++++++++- generic/tclBasic.c | 5 +++-- generic/tclExecute.c | 6 +++--- generic/tclInt.h | 36 +++++++++++++++++++++++++++++++- generic/tclProc.c | 3 ++- generic/tclResult.c | 59 ++++++++++++++++++++++++++++++---------------------- generic/tclStubLib.c | 3 ++- generic/tclUtil.c | 3 ++- 8 files changed, 93 insertions(+), 35 deletions(-) diff --git a/ChangeLog b/ChangeLog index aaf06cd..a1bb2ae 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2007-11-12 Miguel Sofer + + * generic/tclBasic.c: New macro TclResetResult, new iPtr flag + * generic/tclExecute.c: bit INTERP_RESULT_UNCLEAN: shortcut for + * generic/tclInt.h: Tcl_ResetResult for the "normal" case: + * generic/tclProc.c: TCL_OK, no return options, no errorCode + * generic/tclResult.c: nor errorInfo, return at normal level. + * generic/tclStubLib.c: [Patch 1830184] + * generic/tclUtil.c: + + 2007-11-11 Jeff Hobbs * generic/tclCompCmds.c, generic/tclCompile.c, generic/tclCompile.h: @@ -8,7 +19,7 @@ added TclReToGlob function to convert RE to glob patterns and use these in the possible cases. -2007-11-10 Miguel Sofer +2007-11-11 Miguel Sofer * generic/tclResult.c (ResetObjResult): clarify the logic. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 6ec97ef..5b38f5f 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -14,7 +14,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.279 2007/11/11 19:32:13 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.280 2007/11/12 03:38:13 msofer Exp $ */ #include "tclInt.h" @@ -3426,7 +3426,7 @@ TclInterpReady( * any previous error information. */ - Tcl_ResetResult(interp); + TclResetResult(iPtr); /* * If the interpreter has been deleted, return an error. @@ -5398,6 +5398,7 @@ Tcl_AddObjErrorInfo( } Tcl_AppendToObj(iPtr->errorInfo, message, length); } + ((Interp *) interp)->flags |= INTERP_RESULT_UNCLEAN; } /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 80247a6..db7a504 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.346 2007/11/12 02:07:19 hobbs Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.347 2007/11/12 03:38:13 msofer Exp $ */ #include "tclInt.h" @@ -1218,7 +1218,7 @@ Tcl_ExprObj( saveObjPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(saveObjPtr); - Tcl_ResetResult(interp); + TclResetResult(interp); /* * Increment the code's ref count while it is being executed. If @@ -6336,7 +6336,7 @@ TclExecuteByteCode( case INST_END_CATCH: catchTop--; - Tcl_ResetResult(interp); + TclResetResult(interp); result = TCL_OK; TRACE(("=> catchTop=%d\n", (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); diff --git a/generic/tclInt.h b/generic/tclInt.h index 6d6916c..57033fa 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.342 2007/11/11 19:32:16 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.343 2007/11/12 03:38:13 msofer Exp $ */ #ifndef _TCLINT @@ -1973,6 +1973,39 @@ typedef struct InterpList { #define INTERP_TRACE_IN_PROGRESS 0x200 #define INTERP_ALTERNATE_WRONG_ARGS 0x400 #define ERR_LEGACY_COPY 0x800 +#define INTERP_RESULT_UNCLEAN 0x1000 + +/* + * The following macro resets the interp's obj result and returns 1 if a call + * to the full Tcl_ResetResult is needed. TclResetResult macro uses it. + */ + +#define ResetObjResultM(iPtr) \ + { \ + register Tcl_Obj *objResultPtr = (iPtr)->objResultPtr; \ + \ + if (Tcl_IsShared(objResultPtr)) {\ + TclDecrRefCount(objResultPtr);\ + TclNewObj(objResultPtr);\ + Tcl_IncrRefCount(objResultPtr);\ + (iPtr)->objResultPtr = objResultPtr; \ + } else if (objResultPtr->bytes != tclEmptyStringRep) { \ + if (objResultPtr->bytes != NULL) {\ + ckfree((char *) objResultPtr->bytes); \ + }\ + objResultPtr->bytes = tclEmptyStringRep;\ + objResultPtr->length = 0;\ + TclFreeIntRep(objResultPtr);\ + objResultPtr->typePtr = NULL;\ + }\ + } + +#define TclResetResult(iPtr) \ + {\ + ResetObjResultM((Interp *)(iPtr)); \ + if (((Interp *)(iPtr))->flags & INTERP_RESULT_UNCLEAN) \ + TclCleanResult((Interp *)(iPtr)); \ + }\ /* * Maximum number of levels of nesting permitted in Tcl commands (used to @@ -2416,6 +2449,7 @@ MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); +MODULE_SCOPE void TclCleanResult(Interp *iPtr); MODULE_SCOPE int TclDoubleDigits(char *buf, double value, int *signum); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); /* TIP #280 - Modified token based evulation, with line information */ diff --git a/generic/tclProc.c b/generic/tclProc.c index 2b062bf..22333dd 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.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: tclProc.c,v 1.136 2007/11/11 19:32:17 msofer Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.137 2007/11/12 03:38:14 msofer Exp $ */ #include "tclInt.h" @@ -2218,6 +2218,7 @@ TclUpdateReturnInfo( iPtr->flags |= ERR_LEGACY_COPY; } } + iPtr->flags |= INTERP_RESULT_UNCLEAN; return code; } diff --git a/generic/tclResult.c b/generic/tclResult.c index 3d432df..6f92950 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.42 2007/11/11 19:53:20 msofer Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.43 2007/11/12 03:38:14 msofer Exp $ */ #include "tclInt.h" @@ -336,6 +336,7 @@ Tcl_RestoreResult( Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = statePtr->objResultPtr; + iPtr->flags |= INTERP_RESULT_UNCLEAN; } /* @@ -443,6 +444,7 @@ Tcl_SetResult( */ ResetObjResult(iPtr); + iPtr->flags |= INTERP_RESULT_UNCLEAN; } /* @@ -475,6 +477,7 @@ Tcl_GetStringResult( Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } + ((Interp *)interp)->flags |= INTERP_RESULT_UNCLEAN; return interp->result; } @@ -584,6 +587,7 @@ Tcl_GetObjResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; + iPtr->flags &= ~INTERP_RESULT_UNCLEAN; } return iPtr->objResultPtr; } @@ -826,6 +830,7 @@ SetupAppendBuffer( Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; + iPtr->flags |= INTERP_RESULT_UNCLEAN; } /* @@ -866,6 +871,7 @@ Tcl_FreeResult( } ResetObjResult(iPtr); + iPtr->flags &= ~INTERP_RESULT_UNCLEAN; } /* @@ -891,9 +897,17 @@ void Tcl_ResetResult( register Tcl_Interp *interp)/* Interpreter for which to clear result. */ { - register Interp *iPtr = (Interp *) interp; + /* + * This function is defined in a macro in tclInt.h + */ - ResetObjResult(iPtr); + TclResetResult((Interp *) interp); +} + +void +TclCleanResult( + Interp *iPtr) +{ if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -907,8 +921,8 @@ Tcl_ResetResult( if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { - Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, - iPtr->errorCode, TCL_GLOBAL_ONLY); + Tcl_ObjSetVar2((Tcl_Interp *)iPtr, iPtr->ecVar, + NULL, iPtr->errorCode, TCL_GLOBAL_ONLY); } Tcl_DecrRefCount(iPtr->errorCode); iPtr->errorCode = NULL; @@ -916,8 +930,8 @@ Tcl_ResetResult( if (iPtr->errorInfo) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { - Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, - iPtr->errorInfo, TCL_GLOBAL_ONLY); + Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->eiVar, + NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); } Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; @@ -928,7 +942,7 @@ Tcl_ResetResult( Tcl_DecrRefCount(iPtr->returnOpts); iPtr->returnOpts = NULL; } - iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY); + iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY | INTERP_RESULT_UNCLEAN); } /* @@ -954,22 +968,11 @@ ResetObjResult( register Interp *iPtr) /* Points to the interpreter whose result * object should be reset. */ { - register Tcl_Obj *objResultPtr = iPtr->objResultPtr; - - if (Tcl_IsShared(objResultPtr)) { - TclDecrRefCount(objResultPtr); - TclNewObj(objResultPtr); - Tcl_IncrRefCount(objResultPtr); - iPtr->objResultPtr = objResultPtr; - } else if (objResultPtr->bytes != tclEmptyStringRep) { - if (objResultPtr->bytes != NULL) { - ckfree((char *) objResultPtr->bytes); - } - objResultPtr->bytes = tclEmptyStringRep; - objResultPtr->length = 0; - TclFreeIntRep(objResultPtr); - objResultPtr->typePtr = NULL; - } + /* + * This function is defined in a macro in tclInt.h + */ + + ResetObjResultM(iPtr); } /* @@ -1078,6 +1081,7 @@ Tcl_SetObjErrorCode( } iPtr->errorCode = errorObjPtr; Tcl_IncrRefCount(iPtr->errorCode); + iPtr->flags |= INTERP_RESULT_UNCLEAN; } /* @@ -1205,6 +1209,7 @@ TclProcessReturn( } iPtr->returnOpts = returnOpts; Tcl_IncrRefCount(iPtr->returnOpts); + iPtr->flags |= INTERP_RESULT_UNCLEAN; } if (code == TCL_ERROR) { @@ -1234,14 +1239,16 @@ TclProcessReturn( if (valuePtr != NULL) { TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine); } + iPtr->flags |= INTERP_RESULT_UNCLEAN; } if (level != 0) { iPtr->returnLevel = level; iPtr->returnCode = code; + iPtr->flags |= INTERP_RESULT_UNCLEAN; return TCL_RETURN; } if (code == TCL_ERROR) { - iPtr->flags |= ERR_LEGACY_COPY; + iPtr->flags |= (ERR_LEGACY_COPY | INTERP_RESULT_UNCLEAN); } return code; } @@ -1402,6 +1409,7 @@ TclMergeReturnOptions( } else { *optionsPtrPtr = returnOpts; } + ((Interp *)interp)->flags |= INTERP_RESULT_UNCLEAN; return TCL_OK; error: @@ -1508,6 +1516,7 @@ Tcl_SetReturnOptions( } Tcl_DecrRefCount(options); + ((Interp *)interp)->flags |= INTERP_RESULT_UNCLEAN; return code; } diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index f674687..0ee0d4a 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.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. * - * RCS: @(#) $Id: tclStubLib.c,v 1.18 2007/09/19 10:53:25 patthoyts Exp $ + * RCS: @(#) $Id: tclStubLib.c,v 1.19 2007/11/12 03:38:14 msofer Exp $ */ /* @@ -50,6 +50,7 @@ HasStubSupport( interp->result = "This interpreter does not support stubs-enabled extensions."; interp->freeProc = TCL_STATIC; + ((Interp *)interp)->flags |= INTERP_RESULT_UNCLEAN; return NULL; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index d6bf7f1..faf066f 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.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: tclUtil.c,v 1.88 2007/11/12 02:07:20 hobbs Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.89 2007/11/12 03:38:14 msofer Exp $ */ #include "tclInt.h" @@ -2024,6 +2024,7 @@ Tcl_DStringResult( } else { Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); } + ((Interp *) interp)->flags |= INTERP_RESULT_UNCLEAN; dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; -- cgit v0.12