summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCompile.c64
-rw-r--r--generic/tclInt.h2
-rw-r--r--generic/tclListObj.c178
-rw-r--r--generic/tclOO.c2
-rw-r--r--generic/tclOO.h2
-rw-r--r--generic/tclOOBasic.c120
-rw-r--r--generic/tclOOCall.c223
-rw-r--r--generic/tclOOInfo.c90
-rw-r--r--generic/tclOOInt.h7
-rw-r--r--generic/tclUtil.c23
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) {