diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCompile.c | 64 | ||||
| -rw-r--r-- | generic/tclInt.h | 2 | ||||
| -rw-r--r-- | generic/tclListObj.c | 178 | ||||
| -rw-r--r-- | generic/tclOO.c | 2 | ||||
| -rw-r--r-- | generic/tclOO.h | 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 | ||||
| -rw-r--r-- | generic/tclUtil.c | 23 |
11 files changed, 613 insertions, 102 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2da455b..d80731e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5590,6 +5590,10 @@ TclArgumentBCEnter( * have to save them at compile time. */ + if (ePtr->nline != objc) { + Tcl_Panic ("TIP 280 data structure inconsistency"); + } + for (word = 1; word < objc; word++) { if (ePtr->line[word] >= 0) { int isnew; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 2194ae1..0eaf834 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3320,6 +3320,70 @@ TclFixupForwardJump( rangePtr->type); } } + + /* + * TIP #280: Adjust the mapping from PC values to the per-command + * information about arguments and their line numbers. + * + * Note: We cannot simply remove an out-of-date entry and then reinsert + * with the proper PC, because then we might overwrite another entry which + * was at that location. Therefore we pull (copy + delete) all effected + * entries (beyond the fixed PC) into an array, update them there, and at + * last reinsert them all. + */ + + { + ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; + + /* A helper structure */ + + typedef struct { + int pc; + int cmd; + } MAP; + + /* + * And the helper array. At most the whole hashtable is placed into + * this. + */ + + MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries); + + Tcl_HashSearch hSearch; + Tcl_HashEntry* hPtr; + int n, k, isnew; + + /* + * Phase I: Locate the affected entries, and save them in adjusted + * form to the array. This removes them from the hash. + */ + + for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + + map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr)); + map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr)); + + if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) { + Tcl_DeleteHashEntry(hPtr); + map [n].pc += 3; + n++; + } + } + + /* + * Phase II: Re-insert the modified entries into the hash. + */ + + for (k=0;k<n;k++) { + hPtr = Tcl_CreateHashEntry(&eclPtr->litInfo, INT2PTR(map[k].pc), &isnew); + Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd)); + } + + ckfree (map); + } + return 1; /* the jump was grown */ } diff --git a/generic/tclInt.h b/generic/tclInt.h index d010284..cde46ac 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2443,6 +2443,8 @@ typedef struct List { #define LIST_MAX \ (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) +#define LIST_SIZE(numElems) \ + (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *))) /* * Macro used to get the elements of a list object. diff --git a/generic/tclListObj.c b/generic/tclListObj.c index e1c415b..ac87628 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -101,11 +101,11 @@ NewListIntRep( return NULL; } - listRepPtr = attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj*))); + listRepPtr = attemptckalloc(LIST_SIZE(objc)); if (listRepPtr == NULL) { if (p) { Tcl_Panic("list creation failed: unable to alloc %u bytes", - (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)))); + LIST_SIZE(objc)); } return NULL; } @@ -168,7 +168,7 @@ AttemptNewList( } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list creation failed: unable to alloc %u bytes", - (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))))); + LIST_SIZE(objc))); } Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } @@ -511,31 +511,24 @@ Tcl_ListObjAppendList( register Tcl_Obj *listPtr, /* List object to append elements to. */ Tcl_Obj *elemListPtr) /* List obj with elements to append. */ { - int listLen, objc, result; + int objc; Tcl_Obj **objv; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList"); } -/* - result = TclListObjLength(interp, listPtr, &listLen); - if (result != TCL_OK) { - return result; - } -*/ - - result = TclListObjGetElements(interp, elemListPtr, &objc, &objv); - if (result != TCL_OK) { - return result; + /* Pull the elements to append from elemListPtr */ + if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) { + return TCL_ERROR; } /* - * Insert objc new elements starting after the lists's last element. + * Insert the new elements starting after the lists's last element. * Delete zero existing elements. */ - return Tcl_ListObjReplace(interp, listPtr, /*listLen*/LIST_MAX, 0, objc, objv); + return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv); } /* @@ -571,12 +564,8 @@ Tcl_ListObjAppendElement( Tcl_Obj *listPtr, /* List object to append objPtr to. */ Tcl_Obj *objPtr) /* Object to append to listPtr's list. */ { -#if 1 - return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, 1, &objPtr); -#else - register List *listRepPtr; - register Tcl_Obj **elemPtrs; - int numElems, numRequired, newMax, newSize, i; + register List *listRepPtr, *newPtr = NULL; + int numElems, numRequired, needGrow, isShared, attempt; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); @@ -597,41 +586,90 @@ Tcl_ListObjAppendElement( listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; + needGrow = (numRequired > listRepPtr->maxElemCount); + isShared = (listRepPtr->refCount > 1); - /* - * If there is no room in the current array of element pointers, allocate - * a new, larger array and copy the pointers to it. If the List struct is - * shared, allocate a new one. - */ - - if (numRequired > listRepPtr->maxElemCount){ - newMax = 2 * numRequired; - newSize = sizeof(List) + ((newMax-1) * sizeof(Tcl_Obj *)); - } else { - newMax = listRepPtr->maxElemCount; - newSize = 0; + if (numRequired > LIST_MAX) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", + LIST_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; } - if (listRepPtr->refCount > 1) { - List *oldListRepPtr = listRepPtr; - Tcl_Obj **oldElems; + if (needGrow && !isShared) { + /* Need to grow + unshared intrep => try to realloc */ + attempt = 2 * numRequired; + if (attempt <= LIST_MAX) { + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr == NULL) { + attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; + if (attempt > LIST_MAX) { + attempt = LIST_MAX; + } + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr == NULL) { + attempt = numRequired; + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr) { + listRepPtr = newPtr; + listRepPtr->maxElemCount = attempt; + needGrow = 0; + } + } + if (isShared || needGrow) { + Tcl_Obj **dst, **src = &listRepPtr->elements; - listRepPtr = AttemptNewList(interp, newMax, NULL); - if (listRepPtr == NULL) { + /* + * Either we have a shared intrep and we must copy to write, + * or we need to grow and realloc attempts failed. + * Attempt intrep copy. + */ + attempt = 2 * numRequired; + newPtr = AttemptNewList(NULL, attempt, NULL); + if (newPtr == NULL) { + attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; + if (attempt > LIST_MAX) { + attempt = LIST_MAX; + } + newPtr = AttemptNewList(NULL, attempt, NULL); + } + if (newPtr == NULL) { + attempt = numRequired; + newPtr = AttemptNewList(interp, attempt, NULL); + } + if (newPtr == NULL) { + /* All growth attempts failed; throw the error */ return TCL_ERROR; } - oldElems = &oldListRepPtr->elements; - elemPtrs = &listRepPtr->elements; - for (i=0; i<numElems; i++) { - elemPtrs[i] = oldElems[i]; - Tcl_IncrRefCount(elemPtrs[i]); + + dst = &newPtr->elements; + newPtr->refCount++; + newPtr->canonicalFlag = listRepPtr->canonicalFlag; + newPtr->elemCount = listRepPtr->elemCount; + + if (isShared) { + /* + * The original intrep must remain undisturbed. + * Copy into the new one and bump refcounts + */ + while (numElems--) { + *dst = *src++; + Tcl_IncrRefCount(*dst++); + } + listRepPtr->refCount--; + } else { + /* Old intrep to be freed, re-use refCounts */ + memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *)); + + ckfree(listRepPtr); } - listRepPtr->elemCount = numElems; - listRepPtr->refCount++; - oldListRepPtr->refCount--; - } else if (newSize) { - listRepPtr = ckrealloc(listRepPtr, newSize); - listRepPtr->maxElemCount = newMax; + listRepPtr = newPtr; } listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; @@ -640,8 +678,7 @@ Tcl_ListObjAppendElement( * the ref count for the (now shared) objPtr. */ - elemPtrs = &listRepPtr->elements; - elemPtrs[numElems] = objPtr; + *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr; Tcl_IncrRefCount(objPtr); listRepPtr->elemCount++; @@ -652,7 +689,6 @@ Tcl_ListObjAppendElement( Tcl_InvalidateStringRep(listPtr); return TCL_OK; -#endif } /* @@ -1563,7 +1599,6 @@ TclListObjSetElement( listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; - elemPtrs = &listRepPtr->elements; /* * Ensure that the index is in bounds. @@ -1584,25 +1619,30 @@ TclListObjSetElement( */ if (listRepPtr->refCount > 1) { - List *oldListRepPtr = listRepPtr; - Tcl_Obj **oldElemPtrs = elemPtrs; - int i; + Tcl_Obj **dst, **src = &listRepPtr->elements; + List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL); - listRepPtr = AttemptNewList(interp, listRepPtr->maxElemCount, NULL); - if (listRepPtr == NULL) { - return TCL_ERROR; + if (newPtr == NULL) { + newPtr = AttemptNewList(interp, elemCount, NULL); + if (newPtr == NULL) { + return TCL_ERROR; + } } - listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag; - elemPtrs = &listRepPtr->elements; - for (i=0; i < elemCount; i++) { - elemPtrs[i] = oldElemPtrs[i]; - Tcl_IncrRefCount(elemPtrs[i]); + newPtr->refCount++; + newPtr->elemCount = elemCount; + newPtr->canonicalFlag = listRepPtr->canonicalFlag; + + dst = &newPtr->elements; + while (elemCount--) { + *dst = *src++; + Tcl_IncrRefCount(*dst++); } - listRepPtr->refCount++; - listRepPtr->elemCount = elemCount; - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; - oldListRepPtr->refCount--; + + listRepPtr->refCount--; + + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr; } + elemPtrs = &listRepPtr->elements; /* * Add a reference to the new list element. 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/tclOO.h b/generic/tclOO.h index ed70c08..c791930 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,7 +24,7 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "0.6.2" +#define TCLOO_VERSION "0.6.3" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* 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); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 3b5b527..ce66096 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1778,31 +1778,16 @@ Tcl_ConcatObj( } } if (i == objc) { - Tcl_Obj **listv; - int listc; - resPtr = NULL; for (i = 0; i < objc; i++) { - /* - * Tcl_ListObjAppendList could be used here, but this saves us a - * bit of type checking (since we've already done it). Use of - * LIST_MAX tells us to always put the new stuff on the end. It - * will be set right in Tcl_ListObjReplace. - * Note that all objs at this point are either lists or have an - * empty string rep. - */ - objPtr = objv[i]; if (objPtr->bytes && objPtr->length == 0) { continue; } - TclListObjGetElements(NULL, objPtr, &listc, &listv); - if (listc) { - if (resPtr) { - Tcl_ListObjReplace(NULL, resPtr, LIST_MAX, 0, listc, listv); - } else { - resPtr = TclListObjCopy(NULL, objPtr); - } + if (resPtr) { + Tcl_ListObjAppendList(NULL, resPtr, objPtr); + } else { + resPtr = TclListObjCopy(NULL, objPtr); } } if (!resPtr) { |