merge 8.7

1 files changed, 461 insertions, 203 deletions

diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index c093d82..1b4f587 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -47,6 +47,28 @@ struct ChainBuilder {
 	!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))
 
 /*
+ * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for
+ * Itcl's special type of private.
+ */
+
+#define IS_PUBLIC(mPtr)				\
+    (((mPtr)->flags & PUBLIC_METHOD) != 0)
+#define IS_UNEXPORTED(mPtr)			\
+    (((mPtr)->flags & SCOPE_FLAGS) == 0)
+#define IS_ITCLPRIVATE(mPtr)				\
+    (((mPtr)->flags & PRIVATE_METHOD) != 0)
+#define IS_PRIVATE(mPtr)			\
+    (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0)
+#define WANT_PUBLIC(flags)			\
+    (((flags) & PUBLIC_METHOD) != 0)
+#define WANT_UNEXPORTED(flags)			\
+    (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0)
+#define WANT_ITCLPRIVATE(flags)			\
+    (((flags) & PRIVATE_METHOD) != 0)
+#define WANT_PRIVATE(flags)			\
+    (((flags) & TRUE_PRIVATE_METHOD) != 0)
+
+/*
  * Function declarations for things defined in this file.
  */
 
@@ -60,12 +82,26 @@ static inline void	AddMethodToCallChain(Method *const mPtr,
 			    struct ChainBuilder *const cbPtr,
 			    Tcl_HashTable *const doneFilters,
 			    Class *const filterDecl, int flags);
-static inline void	AddSimpleChainToCallContext(Object *const oPtr,
+static inline int	AddInstancePrivateToCallContext(Object *const oPtr,
+			    Tcl_Obj *const methodNameObj,
+			    struct ChainBuilder *const cbPtr, int flags);
+static inline void	AddStandardMethodName(int flags, Tcl_Obj *namePtr,
+			    Method *mPtr, Tcl_HashTable *namesPtr);
+static inline void	AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr,
+			    Tcl_HashTable *namesPtr);
+static inline int	AddSimpleChainToCallContext(Object *const oPtr,
+			    Class *const contextCls,
+			    Tcl_Obj *const methodNameObj,
+			    struct ChainBuilder *const cbPtr,
+			    Tcl_HashTable *const doneFilters, int flags,
+			    Class *const filterDecl);
+static int		AddPrivatesFromClassChainToCallContext(Class *classPtr,
+			    Class *const contextCls,
 			    Tcl_Obj *const methodNameObj,
 			    struct ChainBuilder *const cbPtr,
 			    Tcl_HashTable *const doneFilters, int flags,
 			    Class *const filterDecl);
-static void		AddSimpleClassChainToCallContext(Class *classPtr,
+static int		AddSimpleClassChainToCallContext(Class *classPtr,
 			    Tcl_Obj *const methodNameObj,
 			    struct ChainBuilder *const cbPtr,
 			    Tcl_HashTable *const doneFilters, int flags,
@@ -78,6 +114,8 @@ static inline int	IsStillValid(CallChain *callPtr, Object *oPtr,
 			    int flags, int reuseMask);
 static Tcl_NRPostProc	ResetFilterFlags;
 static Tcl_NRPostProc	SetFilterFlags;
+static int		SortMethodNames(Tcl_HashTable *namesPtr, int flags,
+			    const char ***stringsPtr);
 static inline void	StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);
 
 /*
@@ -364,6 +402,14 @@ FinalizeMethodRefs(
 int
 TclOOGetSortedMethodList(
     Object *oPtr,		/* The object to get the method names for. */
+    Object *contextObj,		/* From what context object we are inquiring.
+				 * NULL when the context shouldn't see
+				 * object-level private methods. Note that
+				 * flags can override this. */
+    Class *contextCls,		/* From what context class we are inquiring.
+				 * NULL when the context shouldn't see
+				 * class-level private methods. Note that
+				 * flags can override this. */
     int flags,			/* Whether we just want the public method
 				 * names. */
     const char ***stringsPtr)	/* Where to write a pointer to the array of
@@ -376,12 +422,10 @@ TclOOGetSortedMethodList(
 				 * at. Is set-like in nature and keyed by
 				 * pointer to class. */
     FOREACH_HASH_DECLS;
-    int i;
+    int i, numStrings;
     Class *mixinPtr;
     Tcl_Obj *namePtr;
     Method *mPtr;
-    int isWantedIn;
-    void *isWanted;
 
     Tcl_InitObjHashTable(&names);
     Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
@@ -398,18 +442,13 @@ TclOOGetSortedMethodList(
 
     if (oPtr->methodsPtr) {
 	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
-	    int isNew;
-
-	    if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) {
+	    if (IS_PRIVATE(mPtr)) {
 		continue;
 	    }
-	    hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
-	    if (isNew) {
-		isWantedIn = ((!(flags & PUBLIC_METHOD)
-			|| mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0);
-		isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
-		Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
+	    if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) {
+		continue;
 	    }
+	    AddStandardMethodName(flags, namePtr, mPtr, &names);
 	}
     }
 
@@ -417,84 +456,46 @@ TclOOGetSortedMethodList(
      * Process method names due to private methods on the object's class.
      */
 
-    if (flags & PRIVATE_METHOD) {
+    if (WANT_UNEXPORTED(flags)) {
 	FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) {
-	    if (mPtr->flags & PRIVATE_METHOD) {
-		int isNew;
-
-		hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
-		if (isNew) {
-		    isWantedIn = IN_LIST;
-		    if (mPtr->typePtr == NULL) {
-			isWantedIn |= NO_IMPLEMENTATION;
-		    }
-		    Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
-		} else if (mPtr->typePtr != NULL) {
-		    isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr));
-		    if (isWantedIn & NO_IMPLEMENTATION) {
-			isWantedIn &= ~NO_IMPLEMENTATION;
-			Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
-		    }
-		}
+	    if (IS_UNEXPORTED(mPtr)) {
+		AddStandardMethodName(flags, namePtr, mPtr, &names);
 	    }
 	}
     }
 
     /*
+     * Process method names due to private methods on the context's object or
+     * class. Which must be correct if either are not NULL.
+     */
+
+    if (contextObj && contextObj->methodsPtr) {
+	AddPrivateMethodNames(contextObj->methodsPtr, &names);
+    }
+    if (contextCls) {
+	AddPrivateMethodNames(&contextCls->classMethods, &names);
+    }
+
+    /*
      * Process (normal) method names from the class hierarchy and the mixin
      * hierarchy.
      */
 
     AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses);
     FOREACH(mixinPtr, oPtr->mixins) {
-	AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names,
+	AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names,
 		&examinedClasses);
     }
 
-    Tcl_DeleteHashTable(&examinedClasses);
-
     /*
-     * See how many (visible) method names there are. If none, we do not (and
-     * should not) try to sort the list of them.
+     * Tidy up, sort the names and resolve finally whether we really want
+     * them (processing export layering).
      */
 
-    i = 0;
-    if (names.numEntries != 0) {
-	const char **strings;
-
-	/*
-	 * We need to build the list of methods to sort. We will be using
-	 * qsort() for this, because it is very unlikely that the list will be
-	 * heavily sorted when it is long enough to matter.
-	 */
-
-	strings = ckalloc(sizeof(char *) * names.numEntries);
-	FOREACH_HASH(namePtr, isWanted, &names) {
-	    if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
-		if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
-		    continue;
-		}
-		strings[i++] = TclGetString(namePtr);
-	    }
-	}
-
-	/*
-	 * Note that 'i' may well be less than names.numEntries when we are
-	 * dealing with public method names.
-	 */
-
-	if (i > 0) {
-	    if (i > 1) {
-		qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
-	    }
-	    *stringsPtr = strings;
-	} else {
-	    ckfree(strings);
-	}
-    }
-
+    Tcl_DeleteHashTable(&examinedClasses);
+    numStrings = SortMethodNames(&names, flags, stringsPtr);
     Tcl_DeleteHashTable(&names);
-    return i;
+    return numStrings;
 }
 
 int
@@ -511,10 +512,7 @@ TclOOGetSortedClassMethodList(
 				/* Used to track what classes have been looked
 				 * at. Is set-like in nature and keyed by
 				 * pointer to class. */
-    FOREACH_HASH_DECLS;
-    int i;
-    Tcl_Obj *namePtr;
-    void *isWanted;
+    int numStrings;
 
     Tcl_InitObjHashTable(&names);
     Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
@@ -527,50 +525,100 @@ TclOOGetSortedClassMethodList(
     Tcl_DeleteHashTable(&examinedClasses);
 
     /*
+     * Process private method names if we should. [TIP 500]
+     */
+
+    if (WANT_PRIVATE(flags)) {
+	AddPrivateMethodNames(&clsPtr->classMethods, &names);
+	flags &= ~TRUE_PRIVATE_METHOD;
+    }
+
+    /*
+     * Tidy up, sort the names and resolve finally whether we really want
+     * them (processing export layering).
+     */
+
+    numStrings = SortMethodNames(&names, flags, stringsPtr);
+    Tcl_DeleteHashTable(&names);
+    return numStrings;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SortMethodNames --
+ *
+ *	Shared helper for TclOOGetSortedMethodList etc. that knows the method
+ *	sorting rules.
+ *
+ * Returns:
+ *	The length of the sorted list.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+SortMethodNames(
+    Tcl_HashTable *namesPtr,	/* The table of names; unsorted, but contains
+				 * whether the names are wanted and under what
+				 * circumstances. */
+    int flags,			/* Whether we are looking for unexported
+				 * methods. Full private methods are handled
+				 * on insertion to the table. */
+    const char ***stringsPtr)	/* Where to store the sorted list of strings
+				 * that we produce. ckalloced() */
+{
+    const char **strings;
+    FOREACH_HASH_DECLS;
+    Tcl_Obj *namePtr;
+    void *isWanted;
+    int i = 0;
+
+    /*
      * See how many (visible) method names there are. If none, we do not (and
      * should not) try to sort the list of them.
      */
 
-    i = 0;
-    if (names.numEntries != 0) {
-	const char **strings;
+    if (namesPtr->numEntries == 0) {
+	*stringsPtr = NULL;
+	return 0;
+    }
 
-	/*
-	 * We need to build the list of methods to sort. We will be using
-	 * qsort() for this, because it is very unlikely that the list will be
-	 * heavily sorted when it is long enough to matter.
-	 */
+    /*
+     * We need to build the list of methods to sort. We will be using qsort()
+     * for this, because it is very unlikely that the list will be heavily
+     * sorted when it is long enough to matter.
+     */
 
-	strings = ckalloc(sizeof(char *) * names.numEntries);
-	FOREACH_HASH(namePtr, isWanted, &names) {
-	    if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
-		if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
-		    continue;
-		}
-		strings[i++] = TclGetString(namePtr);
+    strings = ckalloc(sizeof(char *) * namesPtr->numEntries);
+    FOREACH_HASH(namePtr, isWanted, namesPtr) {
+	if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) {
+	    if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
+		continue;
 	    }
+	    strings[i++] = TclGetString(namePtr);
 	}
+    }
 
-	/*
-	 * Note that 'i' may well be less than names.numEntries when we are
-	 * dealing with public method names.
-	 */
+    /*
+     * Note that 'i' may well be less than names.numEntries when we are
+     * dealing with public method names. We don't sort unless there's at least
+     * two method names.
+     */
 
-	if (i > 0) {
-	    if (i > 1) {
-		qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
-	    }
-	    *stringsPtr = strings;
-	} else {
-	    ckfree(strings);
+    if (i > 0) {
+	if (i > 1) {
+	    qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
 	}
+	*stringsPtr = strings;
+    } else {
+	ckfree(strings);
+	*stringsPtr = NULL;
     }
-
-    Tcl_DeleteHashTable(&names);
     return i;
 }
 
-/* Comparator for GetSortedMethodList */
+/* Comparator for SortMethodNames */
 static int
 CmpStr(
     const void *ptr1,
@@ -579,7 +627,7 @@ CmpStr(
     const char **strPtr1 = (const char **) ptr1;
     const char **strPtr2 = (const char **) ptr2;
 
-    return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1);
+    return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1) + 1);
 }
 
 /*
@@ -612,6 +660,8 @@ AddClassMethodNames(
 				 * pointers to the classes, and the values are
 				 * immaterial. */
 {
+    int i;
+
     /*
      * If we've already started looking at this class, stop working on it now
      * to prevent repeated work.
@@ -642,7 +692,6 @@ AddClassMethodNames(
 
 	if (clsPtr->mixins.num != 0) {
 	    Class *mixinPtr;
-	    int i;
 
 	    FOREACH(mixinPtr, clsPtr->mixins) {
 		if (mixinPtr != clsPtr) {
@@ -653,20 +702,7 @@ AddClassMethodNames(
 	}
 
 	FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
-	    hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
-	    if (isNew) {
-		int isWanted = (!(flags & PUBLIC_METHOD)
-			|| (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0;
-
-		isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
-		Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
-	    } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
-		    && mPtr->typePtr != NULL) {
-		int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));
-
-		isWanted &= ~NO_IMPLEMENTATION;
-		Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
-	    }
+	    AddStandardMethodName(flags, namePtr, mPtr, namesPtr);
 	}
 
 	if (clsPtr->superclasses.num != 1) {
@@ -676,7 +712,6 @@ AddClassMethodNames(
     }
     if (clsPtr->superclasses.num != 0) {
 	Class *superPtr;
-	int i;
 
 	FOREACH(superPtr, clsPtr->superclasses) {
 	    AddClassMethodNames(superPtr, flags, namesPtr,
@@ -688,19 +723,121 @@ AddClassMethodNames(
 /*
  * ----------------------------------------------------------------------
  *
+ * AddPrivateMethodNames, AddStandardMethodName --
+ *
+ *	Factored-out helpers for the sorted name list production functions.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddPrivateMethodNames(
+    Tcl_HashTable *methodsTablePtr,
+    Tcl_HashTable *namesPtr)
+{
+    FOREACH_HASH_DECLS;
+    Method *mPtr;
+    Tcl_Obj *namePtr;
+
+    FOREACH_HASH(namePtr, mPtr, methodsTablePtr) {
+	if (IS_PRIVATE(mPtr)) {
+	    int isNew;
+
+	    hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
+	    Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST));
+	}
+    }
+}
+
+static inline void
+AddStandardMethodName(
+    int flags,
+    Tcl_Obj *namePtr,
+    Method *mPtr,
+    Tcl_HashTable *namesPtr)
+{
+    if (!IS_PRIVATE(mPtr)) {
+	int isNew;
+	Tcl_HashEntry *hPtr =
+		Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
+
+	if (isNew) {
+	    int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr))
+		    ? IN_LIST : 0;
+
+	    isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
+	    Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
+	} else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
+		&& mPtr->typePtr != NULL) {
+	    int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));
+
+	    isWanted &= ~NO_IMPLEMENTATION;
+	    Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
+	}
+    }
+}
+
+#undef IN_LIST
+#undef NO_IMPLEMENTATION
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddInstancePrivateToCallContext --
+ *
+ *	Add private methods from the instance. Called when the calling Tcl
+ *	context is a TclOO method declared by an object that is the same as
+ *	the current object. Returns true iff a private method was actually
+ *	found and added to the call chain (as this suppresses caching).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+AddInstancePrivateToCallContext(
+    Object *const oPtr,		/* Object to add call chain entries for. */
+    Tcl_Obj *const methodName,	/* Name of method to add the call chain
+				 * entries for. */
+    struct ChainBuilder *const cbPtr,
+				/* Where to add the call chain entries. */
+    int flags)			/* What sort of call chain are we building. */
+{
+    Tcl_HashEntry *hPtr;
+    Method *mPtr;
+    int donePrivate = 0;
+
+    if (oPtr->methodsPtr) {
+	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName);
+	if (hPtr != NULL) {
+	    mPtr = Tcl_GetHashValue(hPtr);
+	    if (IS_PRIVATE(mPtr)) {
+		AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
+		donePrivate = 1;
+	    }
+	}
+    }
+    return donePrivate;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * AddSimpleChainToCallContext --
  *
  *	The core of the call-chain construction engine, this handles calling a
  *	particular method on a particular object. Note that filters and
  *	unknown handling are already handled by the logic that uses this
- *	function.
+ *	function. Returns true if a private method was one of those found.
  *
  * ----------------------------------------------------------------------
  */
 
-static inline void
+static inline int
 AddSimpleChainToCallContext(
     Object *const oPtr,		/* Object to add call chain entries for. */
+    Class *const contextCls,	/* Context class; the currently considered
+				 * class is equal to this, private methods may
+				 * also be added. [TIP 500] */
     Tcl_Obj *const methodNameObj,
 				/* Name of method to add the call chain
 				 * entries for. */
@@ -714,44 +851,62 @@ AddSimpleChainToCallContext(
 				 * NULL, either the filter was declared by the
 				 * object or this isn't a filter. */
 {
-    int i;
+    int i, foundPrivate = 0, blockedUnexported = 0;
+    Tcl_HashEntry *hPtr;
+    Method *mPtr;
 
     if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
-	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr,
-		(char *) methodNameObj);
+	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj);
 
 	if (hPtr != NULL) {
-	    Method *mPtr = Tcl_GetHashValue(hPtr);
-
-	    if (flags & PUBLIC_METHOD) {
-		if (!(mPtr->flags & PUBLIC_METHOD)) {
-		    return;
+	    mPtr = Tcl_GetHashValue(hPtr);
+	    if (!IS_PRIVATE(mPtr)) {
+		if (WANT_PUBLIC(flags)) {
+		    if (!IS_PUBLIC(mPtr)) {
+			blockedUnexported = 1;
+		    } else {
+			flags |= DEFINITE_PUBLIC;
+		    }
 		} else {
-		    flags |= DEFINITE_PUBLIC;
+		    flags |= DEFINITE_PROTECTED;
 		}
-	    } else {
-		flags |= DEFINITE_PROTECTED;
 	    }
 	}
     }
     if (!(flags & SPECIAL)) {
-	Tcl_HashEntry *hPtr;
 	Class *mixinPtr;
 
 	FOREACH(mixinPtr, oPtr->mixins) {
-	    AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr,
-		    doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
+	    if (contextCls) {
+		foundPrivate |= AddPrivatesFromClassChainToCallContext(
+			mixinPtr, contextCls, methodNameObj, cbPtr,
+			doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
+	    }
+	    foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
+		    methodNameObj, cbPtr, doneFilters,
+		    flags | TRAVERSED_MIXIN, filterDecl);
 	}
-	if (oPtr->methodsPtr) {
+	if (oPtr->methodsPtr && !blockedUnexported) {
 	    hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
 	    if (hPtr != NULL) {
-		AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr,
-			doneFilters, filterDecl, flags);
+		mPtr = Tcl_GetHashValue(hPtr);
+		if (!IS_PRIVATE(mPtr)) {
+		    AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
+			    flags);
+		}
 	    }
 	}
     }
-    AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr,
-	    doneFilters, flags, filterDecl);
+    if (contextCls) {
+	foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls,
+		contextCls, methodNameObj, cbPtr, doneFilters, flags,
+		filterDecl);
+    }
+    if (!blockedUnexported) {
+	foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls,
+		methodNameObj, cbPtr, doneFilters, flags, filterDecl);
+    }
+    return foundPrivate;
 }
 
 /*
@@ -814,8 +969,8 @@ AddMethodToCallChain(
      * should be sufficient for [incr Tcl] support though.
      */
 
-    if (!(callPtr->flags & PRIVATE_METHOD)
-	    && (mPtr->flags & PRIVATE_METHOD)
+    if (!WANT_UNEXPORTED(callPtr->flags)
+	    && IS_UNEXPORTED(mPtr)
 	    && (mPtr->declaringClassPtr != NULL)
 	    && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) {
 	return;
@@ -856,7 +1011,7 @@ AddMethodToCallChain(
 
     if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
 	callPtr->chain =
-		ckalloc(sizeof(struct MInvoke) * (callPtr->numChain+1));
+		ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1));
 	memcpy(callPtr->chain, callPtr->staticChain,
 		sizeof(struct MInvoke) * callPtr->numChain);
     } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
@@ -955,6 +1110,12 @@ TclOOGetCallContext(
 				 * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
 				 * PRIVATE_METHOD, DESTRUCTOR and
 				 * FILTER_HANDLING are useful. */
+    Object *contextObj,		/* Context object; when equal to oPtr, it
+				 * means that private methods may also be
+				 * added. [TIP 500] */
+    Class *contextCls,		/* Context class; the currently considered
+				 * class is equal to this, private methods may
+				 * also be added. [TIP 500] */
     Tcl_Obj *cacheInThisObj)	/* What object to cache in, or NULL if it is
 				 * to be in the same object as the
 				 * methodNameObj. */
@@ -962,7 +1123,7 @@ TclOOGetCallContext(
     CallContext *contextPtr;
     CallChain *callPtr;
     struct ChainBuilder cb;
-    int i, count, doFilters;
+    int i, count, doFilters, donePrivate = 0;
     Tcl_HashEntry *hPtr;
     Tcl_HashTable doneFilters;
 
@@ -1003,7 +1164,7 @@ TclOOGetCallContext(
 	 */
 
 	const Tcl_ObjIntRep *irPtr;
-	const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
+	const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
 
 	if ((irPtr = Tcl_FetchIntRep(cacheInThisObj, &methodNameType))) {
 	    callPtr = irPtr->twoPtrValue.ptr1;
@@ -1055,10 +1216,11 @@ TclOOGetCallContext(
      */
 
     if (flags & FORCE_UNKNOWN) {
-	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
-		&cb, NULL, BUILDING_MIXINS, NULL);
-	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
-		&cb, NULL, 0, NULL);
+	AddSimpleChainToCallContext(oPtr, NULL,
+		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
+		NULL);
+	AddSimpleChainToCallContext(oPtr, NULL,
+		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
 	callPtr->flags |= OO_UNKNOWN_METHOD;
 	callPtr->epoch = -1;
 	if (callPtr->numChain == 0) {
@@ -1087,10 +1249,10 @@ TclOOGetCallContext(
 		    OBJECT_MIXIN);
 	}
 	FOREACH(filterObj, oPtr->filters) {
-	    AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters,
-		    BUILDING_MIXINS, NULL);
-	    AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0,
-		    NULL);
+	    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+		    filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL);
+	    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+		    filterObj, &cb, &doneFilters, 0, NULL);
 	}
 	AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters,
 		BUILDING_MIXINS);
@@ -1105,9 +1267,15 @@ TclOOGetCallContext(
      * handle class mixins right.
      */
 
-    AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL,
-	    flags|BUILDING_MIXINS, NULL);
-    AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL);
+    if (oPtr == contextObj) {
+	donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj,
+		&cb, flags);
+	donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS);
+    }
+    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+	    methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL);
+    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+	    methodNameObj, &cb, NULL, flags, NULL);
 
     /*
      * Check to see if the method has no implementation. If so, we probably
@@ -1125,17 +1293,18 @@ TclOOGetCallContext(
 	    TclOODeleteChain(callPtr);
 	    return NULL;
 	}
-	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
-		&cb, NULL, BUILDING_MIXINS, NULL);
-	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
-		&cb, NULL, 0, NULL);
+	AddSimpleChainToCallContext(oPtr, NULL,
+		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
+		NULL);
+	AddSimpleChainToCallContext(oPtr, NULL,
+		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
 	callPtr->flags |= OO_UNKNOWN_METHOD;
 	callPtr->epoch = -1;
 	if (count == callPtr->numChain) {
 	    TclOODeleteChain(callPtr);
 	    return NULL;
 	}
-    } else if (doFilters) {
+    } else if (doFilters && !donePrivate) {
 	if (hPtr == NULL) {
 	    if (oPtr->flags & USE_CLASS_CACHE) {
 		if (oPtr->selfCls->classChainCache == NULL) {
@@ -1241,8 +1410,7 @@ TclOOGetStereotypeCallChain(
 	hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
 		(char *) methodNameObj);
 	if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
-	    const int reuseMask =
-		    ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
+	    const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
 
 	    callPtr = Tcl_GetHashValue(hPtr);
 	    if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
@@ -1286,9 +1454,10 @@ TclOOGetStereotypeCallChain(
      * Add the actual method implementations.
      */
 
-    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL,
+    AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL,
 	    flags|BUILDING_MIXINS, NULL);
-    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL);
+    AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags,
+	    NULL);
 
     /*
      * Check to see if the method has no implementation. If so, we probably
@@ -1297,10 +1466,10 @@ TclOOGetStereotypeCallChain(
      */
 
     if (count == callPtr->numChain) {
-	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
-		NULL, BUILDING_MIXINS, NULL);
-	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
-		NULL, 0, NULL);
+	AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
+		&cb, NULL, BUILDING_MIXINS, NULL);
+	AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
+		&cb, NULL, 0, NULL);
 	callPtr->flags |= OO_UNKNOWN_METHOD;
 	callPtr->epoch = -1;
 	if (count == callPtr->numChain) {
@@ -1380,9 +1549,9 @@ AddClassFiltersToCallContext(
 	    (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj,
 		    &isNew);
 	    if (isNew) {
-		AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
+		AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
 			doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr);
-		AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
+		AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
 			doneFilters, clearedFlags, clsPtr);
 	    }
 	}
@@ -1409,6 +1578,87 @@ AddClassFiltersToCallContext(
 /*
  * ----------------------------------------------------------------------
  *
+ * AddPrivatesFromClassChainToCallContext --
+ *
+ *	Helper for AddSimpleChainToCallContext that is used to find private
+ *	methds and add them to the call chain. Returns true when a private
+ *	method is found and added. [TIP 500]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+AddPrivatesFromClassChainToCallContext(
+    Class *classPtr,		/* Class to add the call chain entries for. */
+    Class *const contextCls,	/* Context class; the currently considered
+				 * class is equal to this, private methods may
+				 * also be added. */
+    Tcl_Obj *const methodName,	/* Name of method to add the call chain
+				 * entries for. */
+    struct ChainBuilder *const cbPtr,
+				/* Where to add the call chain entries. */
+    Tcl_HashTable *const doneFilters,
+				/* Where to record what call chain entries
+				 * have been processed. */
+    int flags,			/* What sort of call chain are we building. */
+    Class *const filterDecl)	/* The class that declared the filter. If
+				 * NULL, either the filter was declared by the
+				 * object or this isn't a filter. */
+{
+    int i;
+    Class *superPtr;
+
+    /*
+     * We hard-code the tail-recursive form. It's by far the most common case
+     * *and* it is much more gentle on the stack.
+     *
+     * Note that mixins must be processed before the main class hierarchy.
+     * [Bug 1998221]
+     */
+
+  tailRecurse:
+    FOREACH(superPtr, classPtr->mixins) {
+	if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
+		methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN,
+		filterDecl)) {
+	    return 1;
+	}
+    }
+
+    if (classPtr == contextCls) {
+	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
+		(char *) methodName);
+
+	if (hPtr != NULL) {
+	    register Method *mPtr = Tcl_GetHashValue(hPtr);
+
+	    if (IS_PRIVATE(mPtr)) {
+		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
+			flags);
+		return 1;
+	    }
+	}
+    }
+
+    switch (classPtr->superclasses.num) {
+    case 1:
+	classPtr = classPtr->superclasses.list[0];
+	goto tailRecurse;
+    default:
+	FOREACH(superPtr, classPtr->superclasses) {
+	    if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
+		    methodName, cbPtr, doneFilters, flags, filterDecl)) {
+		return 1;
+	    }
+	}
+    case 0:
+	return 0;
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * AddSimpleClassChainToCallContext --
  *
  *	Construct a call-chain from a class hierarchy.
@@ -1416,7 +1666,7 @@ AddClassFiltersToCallContext(
  * ----------------------------------------------------------------------
  */
 
-static void
+static int
 AddSimpleClassChainToCallContext(
     Class *classPtr,		/* Class to add the call chain entries for. */
     Tcl_Obj *const methodNameObj,
@@ -1432,7 +1682,7 @@ AddSimpleClassChainToCallContext(
 				 * NULL, either the filter was declared by the
 				 * object or this isn't a filter. */
 {
-    int i;
+    int i, privateDanger = 0;
     Class *superPtr;
 
     /*
@@ -1445,8 +1695,9 @@ AddSimpleClassChainToCallContext(
 
   tailRecurse:
     FOREACH(superPtr, classPtr->mixins) {
-	AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
-		doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
+	privateDanger |= AddSimpleClassChainToCallContext(superPtr,
+		methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN,
+		filterDecl);
     }
 
     if (flags & CONSTRUCTOR) {
@@ -1460,21 +1711,26 @@ AddSimpleClassChainToCallContext(
 	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
 		(char *) methodNameObj);
 
+	if (classPtr->flags & HAS_PRIVATE_METHODS) {
+	    privateDanger |= 1;
+	}
 	if (hPtr != NULL) {
 	    register Method *mPtr = Tcl_GetHashValue(hPtr);
 
-	    if (!(flags & KNOWN_STATE)) {
-		if (flags & PUBLIC_METHOD) {
-		    if (mPtr->flags & PUBLIC_METHOD) {
+	    if (!IS_PRIVATE(mPtr)) {
+		if (!(flags & KNOWN_STATE)) {
+		    if (flags & PUBLIC_METHOD) {
+			if (!IS_PUBLIC(mPtr)) {
+			    return privateDanger;
+			}
 			flags |= DEFINITE_PUBLIC;
 		    } else {
-			return;
+			flags |= DEFINITE_PROTECTED;
 		    }
-		} else {
-		    flags |= DEFINITE_PROTECTED;
 		}
+		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
+			flags);
 	    }
-	    AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags);
 	}
     }
 
@@ -1484,11 +1740,11 @@ AddSimpleClassChainToCallContext(
 	goto tailRecurse;
     default:
 	FOREACH(superPtr, classPtr->superclasses) {
-	    AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
-		    doneFilters, flags, filterDecl);
+	    privateDanger |= AddSimpleClassChainToCallContext(superPtr,
+		    methodNameObj, cbPtr, doneFilters, flags, filterDecl);
 	}
     case 0:
-	return;
+	return privateDanger;
     }
 }
 
@@ -1508,7 +1764,7 @@ TclOORenderCallChain(
     Tcl_Interp *interp,
     CallChain *callPtr)
 {
-    Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral;
+    Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral;
     Tcl_Obj *resultObj, *descObjs[4], **objv;
     Foundation *fPtr = TclOOGetFoundation(interp);
     int i;
@@ -1517,12 +1773,14 @@ TclOORenderCallChain(
      * Allocate the literals (potentially) used in our description.
      */
 
-    filterLiteral = Tcl_NewStringObj("filter", -1);
+    TclNewLiteralStringObj(filterLiteral, "filter");
     Tcl_IncrRefCount(filterLiteral);
-    methodLiteral = Tcl_NewStringObj("method", -1);
+    TclNewLiteralStringObj(methodLiteral, "method");
     Tcl_IncrRefCount(methodLiteral);
-    objectLiteral = Tcl_NewStringObj("object", -1);
+    TclNewLiteralStringObj(objectLiteral, "object");
     Tcl_IncrRefCount(objectLiteral);
+    TclNewLiteralStringObj(privateLiteral, "private");
+    Tcl_IncrRefCount(privateLiteral);
 
     /*
      * Do the actual construction of the descriptions. They consist of a list
@@ -1540,16 +1798,15 @@ TclOORenderCallChain(
     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[0] =
+	    miPtr->isFilter ? filterLiteral :
+	    callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
+	    IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
+		    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)
@@ -1567,6 +1824,7 @@ TclOORenderCallChain(
     Tcl_DecrRefCount(filterLiteral);
     Tcl_DecrRefCount(methodLiteral);
     Tcl_DecrRefCount(objectLiteral);
+    Tcl_DecrRefCount(privateLiteral);
 
     /*
      * Finish building the description and return it.