diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2011-05-25 13:35:37 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2011-05-25 13:35:37 (GMT) |
commit | 1d49ca67e112ecdac5812541cf20613f4147a0e9 (patch) | |
tree | 66985fe8898ea0617e9fdf977923ca63d85c4389 /generic | |
parent | baa07264d9df82bf8e15be928bf6e988276cdd2b (diff) | |
download | tcl-1d49ca67e112ecdac5812541cf20613f4147a0e9.zip tcl-1d49ca67e112ecdac5812541cf20613f4147a0e9.tar.gz tcl-1d49ca67e112ecdac5812541cf20613f4147a0e9.tar.bz2 |
Implementation of TIP #381: Call Chain Introspection and Control
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tclOO.c | 2 | ||||
-rw-r--r-- | generic/tclOOBasic.c | 120 | ||||
-rw-r--r-- | generic/tclOOCall.c | 223 | ||||
-rw-r--r-- | generic/tclOOInfo.c | 90 | ||||
-rw-r--r-- | generic/tclOOInt.h | 7 |
5 files changed, 429 insertions, 13 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c index 6ae82d1..9df3f53 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -346,6 +346,8 @@ InitFoundation( Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd, + NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 0d38dcd..b286088 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -680,10 +680,11 @@ TclOO_Object_VarName( /* * ---------------------------------------------------------------------- * - * TclOONextObjCmd -- + * TclOONextObjCmd, TclOONextToObjCmd -- * - * Implementation of the [next] command. Note that this command is only - * ever to be used inside the body of a procedure-like method. + * Implementation of the [next] and [nextto] commands. Note that these + * commands are only ever to be used inside the body of a procedure-like + * method. * * ---------------------------------------------------------------------- */ @@ -723,6 +724,97 @@ TclOONextObjCmd( return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1); } +int +TclOONextToObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + Class *classPtr; + CallContext *contextPtr; + int i; + Tcl_Object object; + + /* + * Start with sanity checks on the calling context to make sure that we + * are invoked from a suitable method context. If so, we can safely + * retrieve the handle to the object call context. + */ + + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + Tcl_AppendResult(interp, TclGetString(objv[0]), + " may only be called from inside a method", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + return TCL_ERROR; + } + contextPtr = framePtr->clientData; + + /* + * Sanity check the arguments; we need the first one to refer to a class. + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?"); + return TCL_ERROR; + } + object = Tcl_GetObjectFromObj(interp, objv[1]); + if (object == NULL) { + return TCL_ERROR; + } + classPtr = ((Object *)object)->classPtr; + if (classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + + /* + * Search for an implementation of a method associated with the current + * call on the call chain past the point where we currently are. Do not + * allow jumping backwards! + */ + + for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) { + struct MInvoke *miPtr = contextPtr->callPtr->chain + i; + + if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { + /* + * Invoke the (advanced) method call context in the caller + * context. Note that this is like [uplevel 1] and not [eval]. + */ + + TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr, + INT2PTR(contextPtr->index), NULL); + contextPtr->index = i-1; + iPtr->varFramePtr = framePtr->callerVarPtr; + return TclNRObjectContextInvokeNext(interp, + (Tcl_ObjectContext) contextPtr, objc, objv, 2); + } + } + + /* + * Generate an appropriate error message, depending on whether the value + * is on the chain but unreachable, or not on the chain at all. + */ + + for (i=contextPtr->index ; i>=0 ; i--) { + struct MInvoke *miPtr = contextPtr->callPtr->chain + i; + + if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { + Tcl_AppendResult(interp, "method implementation by \"", + TclGetString(objv[1]), "\" not reachable from here", + NULL); + return TCL_ERROR; + } + } + Tcl_AppendResult(interp, "method has no non-filter implementation by \"", + TclGetString(objv[1]), "\"", NULL); + return TCL_ERROR; +} + static int RestoreFrame( ClientData data[], @@ -730,8 +822,12 @@ RestoreFrame( int result) { Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; iPtr->varFramePtr = data[0]; + if (contextPtr != NULL) { + contextPtr->index = PTR2INT(data[2]); + } return result; } @@ -754,16 +850,17 @@ TclOOSelfObjCmd( Tcl_Obj *const *objv) { static const char *const subcmds[] = { - "caller", "class", "filter", "method", "namespace", "next", "object", - "target", NULL + "call", "caller", "class", "filter", "method", "namespace", "next", + "object", "target", NULL }; enum SelfCmds { - SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT, - SELF_OBJECT, SELF_TARGET + SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, + SELF_NEXT, SELF_OBJECT, SELF_TARGET }; Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; + Tcl_Obj *result[3]; int index; #define CurrentlyInvoked(contextPtr) \ @@ -834,7 +931,6 @@ TclOOSelfObjCmd( return TCL_ERROR; } else { register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr); - Tcl_Obj *result[3]; Object *oPtr; const char *type; @@ -862,7 +958,6 @@ TclOOSelfObjCmd( CallContext *callerPtr = framePtr->callerVarPtr->clientData; Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr; Object *declarerPtr; - Tcl_Obj *result[3]; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; @@ -894,7 +989,6 @@ TclOOSelfObjCmd( Method *mPtr = contextPtr->callPtr->chain[contextPtr->index+1].mPtr; Object *declarerPtr; - Tcl_Obj *result[2]; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; @@ -928,7 +1022,6 @@ TclOOSelfObjCmd( } else { Method *mPtr; Object *declarerPtr; - Tcl_Obj *result[2]; int i; for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){ @@ -957,6 +1050,11 @@ TclOOSelfObjCmd( Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } + case SELF_CALL: + result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); + result[1] = Tcl_NewIntObj(contextPtr->index); + Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); + return TCL_OK; } return TCL_ERROR; } 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 diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 4f25772..ac8ae46 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -17,6 +17,7 @@ #include "tclOOInt.h" static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +static Tcl_ObjCmdProc InfoObjectCallCmd; static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; @@ -28,6 +29,7 @@ static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectNsCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoObjectVariablesCmd; +static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; @@ -48,6 +50,7 @@ struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; }; */ static const struct NameProcMap infoObjectCmds[] = { + {"::oo::InfoObject::call", InfoObjectCallCmd}, {"::oo::InfoObject::class", InfoObjectClassCmd}, {"::oo::InfoObject::definition", InfoObjectDefnCmd}, {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, @@ -67,6 +70,7 @@ static const struct NameProcMap infoObjectCmds[] = { */ static const struct NameProcMap infoClassCmds[] = { + {"::oo::InfoClass::call", InfoClassCallCmd}, {"::oo::InfoClass::constructor", InfoClassConstrCmd}, {"::oo::InfoClass::definition", InfoClassDefnCmd}, {"::oo::InfoClass::destructor", InfoClassDestrCmd}, @@ -1456,6 +1460,92 @@ InfoClassVariablesCmd( } /* + * ---------------------------------------------------------------------- + * + * InfoObjectCallCmd -- + * + * Implements [info object call $objName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + CallContext *contextPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + /* + * Get the call context and render its call chain. + */ + + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); + if (contextPtr == NULL) { + Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, + TclOORenderCallChain(interp, contextPtr->callPtr)); + TclOODeleteContext(contextPtr); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassCallCmd -- + * + * Implements [info class call $clsName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Class *clsPtr; + CallChain *callPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + + /* + * Get an render the stereotypical call chain. + */ + + callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD); + if (callPtr == NULL) { + Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr)); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index bd32f22..b151183 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -465,6 +465,9 @@ MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData, MODULE_SCOPE int TclOONextObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOONextToObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); @@ -518,6 +521,8 @@ MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, Tcl_Obj *cacheInThisObj); +MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, + Tcl_Obj *methodNameObj, int flags); MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); @@ -544,6 +549,8 @@ MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr, Class *superPtr); +MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, + CallChain *callPtr); MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, CallContext *contextPtr); MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); |