diff options
author | dkf <dkf@noemail.net> | 2011-05-25 13:35:37 (GMT) |
---|---|---|
committer | dkf <dkf@noemail.net> | 2011-05-25 13:35:37 (GMT) |
commit | 40d360c5215eb5c467ca781174c0fb6d8f992b2f (patch) | |
tree | 66985fe8898ea0617e9fdf977923ca63d85c4389 /generic/tclOOCall.c | |
parent | 27d699e8685f69a322b3e92e2d70175629d71c47 (diff) | |
download | tcl-40d360c5215eb5c467ca781174c0fb6d8f992b2f.zip tcl-40d360c5215eb5c467ca781174c0fb6d8f992b2f.tar.gz tcl-40d360c5215eb5c467ca781174c0fb6d8f992b2f.tar.bz2 |
Implementation of TIP #381: Call Chain Introspection and Control
FossilOrigin-Name: 2778ad161a0a0c67ae685b848e3b97470f163128
Diffstat (limited to 'generic/tclOOCall.c')
-rw-r--r-- | generic/tclOOCall.c | 223 |
1 files changed, 221 insertions, 2 deletions
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 1e8d1a3..3954a6b 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -104,8 +104,10 @@ TclOODeleteContext( register Object *oPtr = contextPtr->oPtr; TclOODeleteChain(contextPtr->callPtr); - TclStackFree(oPtr->fPtr->interp, contextPtr); - DelRef(oPtr); + if (oPtr != NULL) { + TclStackFree(oPtr->fPtr->interp, contextPtr); + DelRef(oPtr); + } } /* @@ -1099,6 +1101,137 @@ TclOOGetCallContext( /* * ---------------------------------------------------------------------- * + * TclOOGetStereotypeCallChain -- + * + * Construct a call-chain for a method that would be used by a + * stereotypical instance of the given class (i.e., where the object has + * no definitions special to itself). + * + * ---------------------------------------------------------------------- + */ + +CallChain * +TclOOGetStereotypeCallChain( + Class *clsPtr, /* The object to get the context for. */ + 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. + * Only the bits PUBLIC_METHOD, CONSTRUCTOR, + * PRIVATE_METHOD, DESTRUCTOR and + * FILTER_HANDLING are useful. */ +{ + CallChain *callPtr; + struct ChainBuilder cb; + int i, count; + Foundation *fPtr = clsPtr->thisPtr->fPtr; + Tcl_HashEntry *hPtr; + Tcl_HashTable doneFilters; + Object obj; + + /* + * Synthesize a temporary stereotypical object so that we can use existing + * machinery to produce the stereotypical call chain. + */ + + memset(&obj, 0, sizeof(Object)); + obj.fPtr = fPtr; + obj.selfCls = clsPtr; + obj.refCount = 1; + obj.flags = USE_CLASS_CACHE; + + /* + * Check if we can get the chain out of the Tcl_Obj method name or out of + * the cache. This is made a bit more complex by the fact that there are + * multiple different layers of cache (in the Tcl_Obj, in the object, and + * in the class). + */ + + if (clsPtr->classChainCache != NULL) { + hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, + (char *) methodNameObj); + if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { + const int reuseMask = + ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + + callPtr = Tcl_GetHashValue(hPtr); + if (IsStillValid(callPtr, &obj, flags, reuseMask)) { + callPtr->refCount++; + return callPtr; + } + Tcl_SetHashValue(hPtr, NULL); + TclOODeleteChain(callPtr); + } + } else { + hPtr = NULL; + } + + callPtr = (CallChain *) ckalloc(sizeof(CallChain)); + memset(callPtr, 0, sizeof(CallChain)); + callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING); + callPtr->epoch = fPtr->epoch; + callPtr->objectCreationEpoch = fPtr->tsdPtr->nsCount; + callPtr->objectEpoch = clsPtr->thisPtr->epoch; + callPtr->refCount = 1; + callPtr->chain = callPtr->staticChain; + + cb.callChainPtr = callPtr; + cb.filterLength = 0; + cb.oPtr = &obj; + + /* + * Add all defined filters (if any, and if we're going to be processing + * them; they're not processed for constructors, destructors or when we're + * in the middle of processing a filter). + */ + + Tcl_InitObjHashTable(&doneFilters); + AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters); + Tcl_DeleteHashTable(&doneFilters); + count = cb.filterLength = callPtr->numChain; + + /* + * Add the actual method implementations. + */ + + AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); + + /* + * Check to see if the method has no implementation. If so, we probably + * need to add in a call to the unknown method. Otherwise, set up the + * cacheing of the method implementation (if relevant). + */ + + if (count == callPtr->numChain) { + AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, + NULL, 0, NULL); + callPtr->flags |= OO_UNKNOWN_METHOD; + callPtr->epoch = -1; + if (count == callPtr->numChain) { + TclOODeleteChain(callPtr); + return NULL; + } + } else { + if (hPtr == NULL) { + if (clsPtr->classChainCache == NULL) { + clsPtr->classChainCache = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + + Tcl_InitObjHashTable(clsPtr->classChainCache); + } + hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, + (char *) methodNameObj, &i); + } + callPtr->refCount++; + Tcl_SetHashValue(hPtr, callPtr); + StashCallChain(methodNameObj, callPtr); + } + return callPtr; +} + +/* + * ---------------------------------------------------------------------- + * * AddClassFiltersToCallContext -- * * Logic to make extracting all the filters from the class context much @@ -1256,6 +1389,92 @@ AddSimpleClassChainToCallContext( } /* + * ---------------------------------------------------------------------- + * + * TclOORenderCallChain -- + * + * Create a description of a call chain. Used in [info object call], + * [info class call], and [self call]. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclOORenderCallChain( + Tcl_Interp *interp, + CallChain *callPtr) +{ + Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral; + Tcl_Obj *resultObj, *descObjs[4], **objv; + Foundation *fPtr = TclOOGetFoundation(interp); + int i; + + /* + * Allocate the literals (potentially) used in our description. + */ + + filterLiteral = Tcl_NewStringObj("filter", -1); + Tcl_IncrRefCount(filterLiteral); + methodLiteral = Tcl_NewStringObj("method", -1); + Tcl_IncrRefCount(methodLiteral); + objectLiteral = Tcl_NewStringObj("object", -1); + Tcl_IncrRefCount(objectLiteral); + + /* + * Do the actual construction of the descriptions. They consist of a list + * of triples that describe the details of how a method is understood. For + * each triple, the first word is the type of invokation ("method" is + * normal, "unknown" is special because it adds the method name as an + * extra argument when handled by some method types, and "filter" is + * special because it's a filter method). The second word is the name of + * the method in question (which differs for "unknown" and "filter" types) + * and the third word is the full name of the class that declares the + * method (or "object" if it is declared on the instance). + */ + + objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *)); + for (i=0 ; i<callPtr->numChain ; i++) { + struct MInvoke *miPtr = &callPtr->chain[i]; + + descObjs[0] = miPtr->isFilter + ? filterLiteral + : callPtr->flags & OO_UNKNOWN_METHOD + ? fPtr->unknownMethodNameObj + : methodLiteral; + descObjs[1] = callPtr->flags & CONSTRUCTOR + ? fPtr->constructorName + : callPtr->flags & DESTRUCTOR + ? fPtr->destructorName + : miPtr->mPtr->namePtr; + descObjs[2] = miPtr->mPtr->declaringClassPtr + ? Tcl_GetObjectName(interp, + (Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr) + : objectLiteral; + descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1); + + objv[i] = Tcl_NewListObj(4, descObjs); + Tcl_IncrRefCount(objv[i]); + } + + /* + * Drop the local references to the literals; if they're actually used, + * they'll live on the description itself. + */ + + Tcl_DecrRefCount(filterLiteral); + Tcl_DecrRefCount(methodLiteral); + Tcl_DecrRefCount(objectLiteral); + + /* + * Finish building the description and return it. + */ + + resultObj = Tcl_NewListObj(callPtr->numChain, objv); + TclStackFree(interp, objv); + return resultObj; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 |