Rewind from a refactoring that veered into the weeds.bug_3293874

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) {