summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-07-12 14:51:30 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-07-12 14:51:30 (GMT)
commit08c08fbd919645722f3a2fe5db61c2e4dfa97d2c (patch)
tree6e718b7c6384b7ada1efaa63ce6b8177eb7ca225 /generic
parent044907f34579d3b64afa81854a8b9ffce76562ad (diff)
downloadtcl-08c08fbd919645722f3a2fe5db61c2e4dfa97d2c.zip
tcl-08c08fbd919645722f3a2fe5db61c2e4dfa97d2c.tar.gz
tcl-08c08fbd919645722f3a2fe5db61c2e4dfa97d2c.tar.bz2
Reorganize method cache handling a bit to better support itcl nasty cases.
[Bug 1895546]
Diffstat (limited to 'generic')
-rw-r--r--generic/tclOO.c60
-rw-r--r--generic/tclOOCall.c18
-rw-r--r--generic/tclOOInt.h5
3 files changed, 53 insertions, 30 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 1ba0ba8..c1e8678 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.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: tclOO.c,v 1.22 2009/05/08 08:48:19 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.23 2009/07/12 14:51:30 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -625,7 +625,7 @@ ObjectRenamedTrace(
AddRef(oPtr);
oPtr->flags |= OBJECT_DELETED;
- contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR);
+ contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
if (contextPtr != NULL) {
int result;
Tcl_InterpState state;
@@ -1330,7 +1330,8 @@ Tcl_NewObjectInstance(
*/
if (objc >= 0) {
- CallContext *contextPtr = TclOOGetCallContext(oPtr,NULL,CONSTRUCTOR);
+ CallContext *contextPtr =
+ TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
if (contextPtr != NULL) {
int result;
@@ -1426,7 +1427,7 @@ TclNRNewObjectInstance(
*objectPtr = (Tcl_Object) oPtr;
return TCL_OK;
}
- contextPtr = TclOOGetCallContext(oPtr,NULL,CONSTRUCTOR);
+ contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
if (contextPtr == NULL) {
*objectPtr = (Tcl_Object) oPtr;
return TCL_OK;
@@ -2097,34 +2098,49 @@ TclOOObjectCmdCore(
methodNamePtr = objv[1];
if (oPtr->mapMethodNameProc != NULL) {
register Class **startClsPtr = &startCls;
+ Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr);
- methodNamePtr = Tcl_DuplicateObj(methodNamePtr);
result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
- (Tcl_Class *) startClsPtr, methodNamePtr);
+ (Tcl_Class *) startClsPtr, mappedMethodName);
if (result != TCL_OK) {
- if (result == TCL_ERROR) {
+ Tcl_DecrRefCount(mappedMethodName);
+ if (result == TCL_BREAK) {
+ goto noMapping;
+ } else if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (while mapping method name)");
}
- Tcl_DecrRefCount(methodNamePtr);
return result;
}
- }
- Tcl_IncrRefCount(methodNamePtr);
- /*
- * Get the call chain.
- */
+ /*
+ * Get the call chain for the remapped name.
+ */
- contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
- flags | (oPtr->flags & FILTER_HANDLING));
- if (contextPtr == NULL) {
- Tcl_AppendResult(interp, "impossible to invoke method \"",
- TclGetString(methodNamePtr),
- "\": no defined method or unknown method", NULL);
- Tcl_DecrRefCount(methodNamePtr);
- return TCL_ERROR;
+ Tcl_IncrRefCount(mappedMethodName);
+ contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
+ flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
+ Tcl_DecrRefCount(mappedMethodName);
+ if (contextPtr == NULL) {
+ Tcl_AppendResult(interp, "impossible to invoke method \"",
+ TclGetString(methodNamePtr),
+ "\": no defined method or unknown method", NULL);
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Get the call chain.
+ */
+
+ noMapping:
+ contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
+ flags | (oPtr->flags & FILTER_HANDLING), NULL);
+ if (contextPtr == NULL) {
+ Tcl_AppendResult(interp, "impossible to invoke method \"",
+ TclGetString(methodNamePtr),
+ "\": no defined method or unknown method", NULL);
+ return TCL_ERROR;
+ }
}
- Tcl_DecrRefCount(methodNamePtr);
/*
* Check to see if we need to apply magical tricks to start part way
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index c4b9ab2..e9760f7 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.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: tclOOCall.c,v 1.13 2008/10/16 22:34:18 nijtmans Exp $
+ * RCS: @(#) $Id: tclOOCall.c,v 1.14 2009/07/12 14:51:30 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -897,10 +897,13 @@ TclOOGetCallContext(
Tcl_Obj *methodNameObj, /* The name of the method to get the context
* for. NULL when getting a constructor or
* destructor chain. */
- int flags) /* What sort of context are we looking for.
+ int flags, /* What sort of context are we looking for.
* Only the bits PUBLIC_METHOD, CONSTRUCTOR,
* PRIVATE_METHOD, DESTRUCTOR and
* FILTER_HANDLING are useful. */
+ Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is
+ * to be in the same object as the
+ * methodNameObj. */
{
CallContext *contextPtr;
CallChain *callPtr;
@@ -909,6 +912,9 @@ TclOOGetCallContext(
Tcl_HashEntry *hPtr;
Tcl_HashTable doneFilters;
+ if (cacheInThisObj == NULL) {
+ cacheInThisObj = methodNameObj;
+ }
if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
hPtr = NULL;
doFilters = 0;
@@ -944,13 +950,13 @@ TclOOGetCallContext(
const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
- if (methodNameObj->typePtr == &methodNameType) {
- callPtr = methodNameObj->internalRep.otherValuePtr;
+ if (cacheInThisObj->typePtr == &methodNameType) {
+ callPtr = cacheInThisObj->internalRep.otherValuePtr;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
- methodNameObj->typePtr->freeIntRepProc(methodNameObj);
+ cacheInThisObj->typePtr->freeIntRepProc(cacheInThisObj);
}
if (oPtr->flags & USE_CLASS_CACHE) {
@@ -1067,7 +1073,7 @@ TclOOGetCallContext(
}
callPtr->refCount++;
Tcl_SetHashValue(hPtr, callPtr);
- StashCallChain(methodNameObj, callPtr);
+ StashCallChain(cacheInThisObj, callPtr);
} else if (flags & CONSTRUCTOR) {
if (oPtr->selfCls->constructorChainPtr) {
TclOODeleteChain(oPtr->selfCls->constructorChainPtr);
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 1579ddb..17db3f1 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -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: tclOOInt.h,v 1.11 2009/04/11 11:18:51 dkf Exp $
+ * RCS: @(#) $Id: tclOOInt.h,v 1.12 2009/07/12 14:51:30 dkf Exp $
*/
#ifndef TCL_OO_INTERNAL_H
@@ -512,7 +512,8 @@ MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
- Tcl_Obj *methodNameObj, int flags);
+ Tcl_Obj *methodNameObj, int flags,
+ Tcl_Obj *cacheInThisObj);
MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr);
MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr);