summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog11
-rw-r--r--generic/tclBasic.c5
-rw-r--r--generic/tclExecute.c6
-rw-r--r--generic/tclGet.c6
-rw-r--r--generic/tclInt.h36
-rw-r--r--generic/tclProc.c3
-rw-r--r--generic/tclResult.c59
-rw-r--r--generic/tclStubLib.c3
-rw-r--r--generic/tclUtil.c28
9 files changed, 58 insertions, 99 deletions
diff --git a/ChangeLog b/ChangeLog
index 37aacc8..32ed799 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2007-11-12 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * generic/tclGet.c (Tcl_Get, Tcl_GetInt): revert use of TclGet*
+ macros due to compiler warning. These cases won't save time either.
+
+ * generic/tclUtil.c (TclReToGlob): add more comments, set interp
+ result if specified on error.
+
2007-11-12 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c: New macro TclResetResult, new iPtr flag
@@ -8,6 +16,9 @@
* generic/tclStubLib.c: [Patch 1830184]
* generic/tclUtil.c:
+ THIS PATCH WAS REVERTED: initial (mis)measurements overstated the
+ perfomance wins, which turn out to be tiny. Not worth the
+ complication.
2007-11-11 Jeff Hobbs <jeffh@ActiveState.com>
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index bd4a102..82df237 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.244.2.14 2007/11/12 19:18:13 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.244.2.15 2007/11/13 13:07:41 dgp Exp $
*/
#include "tclInt.h"
@@ -3426,7 +3426,7 @@ TclInterpReady(
* any previous error information.
*/
- TclResetResult(iPtr);
+ Tcl_ResetResult(interp);
/*
* If the interpreter has been deleted, return an error.
@@ -5398,7 +5398,6 @@ 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 3efd610..bb83839 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.285.2.22 2007/11/12 19:18:16 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.285.2.23 2007/11/13 13:07:41 dgp Exp $
*/
#include "tclInt.h"
@@ -1218,7 +1218,7 @@ Tcl_ExprObj(
saveObjPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(saveObjPtr);
- TclResetResult(interp);
+ Tcl_ResetResult(interp);
/*
* Increment the code's ref count while it is being executed. If
@@ -6336,7 +6336,7 @@ TclExecuteByteCode(
case INST_END_CATCH:
catchTop--;
- TclResetResult(interp);
+ Tcl_ResetResult(interp);
result = TCL_OK;
TRACE(("=> catchTop=%d\n", (catchTop - initCatchTop - 1)));
NEXT_INST_F(1, 0, 0);
diff --git a/generic/tclGet.c b/generic/tclGet.c
index f0be043..3d63f74 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.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: tclGet.c,v 1.17.8.1 2007/11/12 19:18:16 dgp Exp $
+ * RCS: @(#) $Id: tclGet.c,v 1.17.8.2 2007/11/13 13:07:42 dgp Exp $
*/
#include "tclInt.h"
@@ -50,7 +50,7 @@ Tcl_GetInt(
obj.length = strlen(src);
obj.typePtr = NULL;
- code = TclGetIntFromObj(interp, &obj, intPtr);
+ code = Tcl_GetIntFromObj(interp, &obj, intPtr);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
@@ -94,7 +94,7 @@ TclGetLong(
obj.length = strlen(src);
obj.typePtr = NULL;
- code = TclGetLongFromObj(interp, &obj, longPtr);
+ code = Tcl_GetLongFromObj(interp, &obj, longPtr);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index bf304c8..639a8c4 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.310.2.13 2007/11/12 19:18:18 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.310.2.14 2007/11/13 13:07:42 dgp Exp $
*/
#ifndef _TCLINT
@@ -1973,39 +1973,6 @@ 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
@@ -2449,7 +2416,6 @@ 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 6aeaa91..c5110b2 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.115.2.14 2007/11/12 19:18:20 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.115.2.15 2007/11/13 13:07:42 dgp Exp $
*/
#include "tclInt.h"
@@ -2218,7 +2218,6 @@ TclUpdateReturnInfo(
iPtr->flags |= ERR_LEGACY_COPY;
}
}
- iPtr->flags |= INTERP_RESULT_UNCLEAN;
return code;
}
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 11ed3bd..80feaee 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.36.2.4 2007/11/12 19:18:20 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.36.2.5 2007/11/13 13:07:42 dgp Exp $
*/
#include "tclInt.h"
@@ -336,7 +336,6 @@ Tcl_RestoreResult(
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = statePtr->objResultPtr;
- iPtr->flags |= INTERP_RESULT_UNCLEAN;
}
/*
@@ -444,7 +443,6 @@ Tcl_SetResult(
*/
ResetObjResult(iPtr);
- iPtr->flags |= INTERP_RESULT_UNCLEAN;
}
/*
@@ -477,7 +475,6 @@ Tcl_GetStringResult(
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
- ((Interp *)interp)->flags |= INTERP_RESULT_UNCLEAN;
return interp->result;
}
@@ -587,7 +584,6 @@ Tcl_GetObjResult(
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
- iPtr->flags &= ~INTERP_RESULT_UNCLEAN;
}
return iPtr->objResultPtr;
}
@@ -830,7 +826,6 @@ SetupAppendBuffer(
Tcl_FreeResult((Tcl_Interp *) iPtr);
iPtr->result = iPtr->appendResult;
- iPtr->flags |= INTERP_RESULT_UNCLEAN;
}
/*
@@ -871,7 +866,6 @@ Tcl_FreeResult(
}
ResetObjResult(iPtr);
- iPtr->flags &= ~INTERP_RESULT_UNCLEAN;
}
/*
@@ -897,17 +891,9 @@ void
Tcl_ResetResult(
register Tcl_Interp *interp)/* Interpreter for which to clear result. */
{
- /*
- * This function is defined in a macro in tclInt.h
- */
-
- TclResetResult((Interp *) interp);
-}
+ register Interp *iPtr = (Interp *) interp;
-void
-TclCleanResult(
- Interp *iPtr)
-{
+ ResetObjResult(iPtr);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
@@ -921,8 +907,8 @@ TclCleanResult(
if (iPtr->errorCode) {
/* Legacy support */
if (iPtr->flags & ERR_LEGACY_COPY) {
- Tcl_ObjSetVar2((Tcl_Interp *)iPtr, iPtr->ecVar,
- NULL, iPtr->errorCode, TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
+ iPtr->errorCode, TCL_GLOBAL_ONLY);
}
Tcl_DecrRefCount(iPtr->errorCode);
iPtr->errorCode = NULL;
@@ -930,8 +916,8 @@ TclCleanResult(
if (iPtr->errorInfo) {
/* Legacy support */
if (iPtr->flags & ERR_LEGACY_COPY) {
- Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->eiVar,
- NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
+ iPtr->errorInfo, TCL_GLOBAL_ONLY);
}
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
@@ -942,7 +928,7 @@ TclCleanResult(
Tcl_DecrRefCount(iPtr->returnOpts);
iPtr->returnOpts = NULL;
}
- iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY | INTERP_RESULT_UNCLEAN);
+ iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY);
}
/*
@@ -968,11 +954,22 @@ ResetObjResult(
register Interp *iPtr) /* Points to the interpreter whose result
* object should be reset. */
{
- /*
- * This function is defined in a macro in tclInt.h
- */
-
- 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;
+ }
}
/*
@@ -1081,7 +1078,6 @@ Tcl_SetObjErrorCode(
}
iPtr->errorCode = errorObjPtr;
Tcl_IncrRefCount(iPtr->errorCode);
- iPtr->flags |= INTERP_RESULT_UNCLEAN;
}
/*
@@ -1209,7 +1205,6 @@ TclProcessReturn(
}
iPtr->returnOpts = returnOpts;
Tcl_IncrRefCount(iPtr->returnOpts);
- iPtr->flags |= INTERP_RESULT_UNCLEAN;
}
if (code == TCL_ERROR) {
@@ -1239,16 +1234,14 @@ 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 | INTERP_RESULT_UNCLEAN);
+ iPtr->flags |= ERR_LEGACY_COPY;
}
return code;
}
@@ -1409,7 +1402,6 @@ TclMergeReturnOptions(
} else {
*optionsPtrPtr = returnOpts;
}
- ((Interp *)interp)->flags |= INTERP_RESULT_UNCLEAN;
return TCL_OK;
error:
@@ -1516,7 +1508,6 @@ Tcl_SetReturnOptions(
}
Tcl_DecrRefCount(options);
- ((Interp *)interp)->flags |= INTERP_RESULT_UNCLEAN;
return code;
}
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index aa1d185..a73cb58 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.15.2.3 2007/11/12 19:18:20 dgp Exp $
+ * RCS: @(#) $Id: tclStubLib.c,v 1.15.2.4 2007/11/13 13:07:42 dgp Exp $
*/
/*
@@ -50,7 +50,6 @@ 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 24c9694..4591dbc 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.82.2.3 2007/11/12 19:18:20 dgp Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.82.2.4 2007/11/13 13:07:42 dgp Exp $
*/
#include "tclInt.h"
@@ -2024,7 +2024,6 @@ Tcl_DStringResult(
} else {
Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
}
- ((Interp *) interp)->flags |= INTERP_RESULT_UNCLEAN;
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
@@ -3194,6 +3193,8 @@ TclGetPlatform(void)
* Returns TCL_OK on success, TCL_ERROR on failure.
* If interp is not NULL, an error message is placed in the result.
* On success, the DString will contain an exact equivalent glob pattern.
+ * The caller is responsible for calling Tcl_DStringFree on success.
+ * If exactPtr is not NULL, it will be 1 if an exact match qualifies.
*
* Side effects:
* None.
@@ -3220,7 +3221,9 @@ TclReToGlob(Tcl_Interp *interp,
*/
if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) {
- *exactPtr = 1;
+ if (exactPtr) {
+ *exactPtr = 1;
+ }
Tcl_DStringAppend(dsPtr, reStr + 4, reStrLen - 4);
return TCL_OK;
}
@@ -3333,21 +3336,9 @@ TclReToGlob(Tcl_Interp *interp,
}
Tcl_DStringSetLength(dsPtr, dsStr - dsStrStart);
-#ifdef TCL_MEM_DEBUG
- /*
- * Check if this is a bad RE (do this at the end because it can be
- * expensive).
- * XXX: Is it possible that we can have a bad RE make it through the
- * XXX: above checks?
- */
-
- if (Tcl_RegExpCompile(NULL, reStr) == NULL) {
- msg = "couldn't compile RE";
- goto invalidGlob;
+ if (exactPtr) {
+ *exactPtr = (anchorLeft && anchorRight);
}
-#endif
-
- *exactPtr = (anchorLeft && anchorRight);
#if 0
fprintf(stderr, "INPUT RE '%.*s' OUTPUT GLOB '%s' anchor %d:%d \n",
@@ -3363,6 +3354,9 @@ TclReToGlob(Tcl_Interp *interp,
reStrLen, reStr, msg, *p);
fflush(stderr);
#endif
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, msg, NULL);
+ }
Tcl_DStringFree(dsPtr);
return TCL_ERROR;
}
generated by cgit v0.12 at 2024-11-21 14:47:08 (GMT)