Private methods seem to be working...

5 files changed, 144 insertions, 54 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 1080967..6aa03fa 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1174,7 +1174,7 @@ ObjectNamespaceDeleted(
 
     if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
 	CallContext *contextPtr =
-		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
 	int result;
 
 	Tcl_InterpState state;
@@ -1651,7 +1651,7 @@ Tcl_NewObjectInstance(
 
     if (objc >= 0) {
 	CallContext *contextPtr =
-		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
 
 	if (contextPtr != NULL) {
 	    int isRoot, result;
@@ -1724,7 +1724,7 @@ TclNRNewObjectInstance(
 	*objectPtr = (Tcl_Object) oPtr;
 	return TCL_OK;
     }
-    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
     if (contextPtr == NULL) {
 	*objectPtr = (Tcl_Object) oPtr;
 	return TCL_OK;
@@ -2164,7 +2164,8 @@ Tcl_CopyObjectInstance(
     }
 
     TclResetRewriteEnsemble(interp, 1);
-    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
+    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL,
+	    NULL, NULL);
     if (contextPtr) {
 	args[0] = TclOOObjectName(interp, o2Ptr);
 	args[1] = oPtr->fPtr->clonedName;
@@ -2562,6 +2563,8 @@ TclOOObjectCmdCore(
     CallContext *contextPtr;
     Tcl_Obj *methodNamePtr;
     CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
+    Object *callerObjPtr = NULL;
+    Class *callerClsPtr = NULL;
     int result;
 
     /*
@@ -2585,11 +2588,11 @@ TclOOObjectCmdCore(
 	Method *callerMethodPtr =
 		callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr;
 
-	if (callerMethodPtr->declaringObjectPtr == oPtr) {
-	    flags |= OBJECT_PRIVATE_METHOD;
+	if (callerMethodPtr->declaringObjectPtr) {
+	    callerObjPtr = callerMethodPtr->declaringObjectPtr;
 	}
-	if (callerMethodPtr->declaringClassPtr == oPtr->selfCls) {
-	    flags |= CLASS_PRIVATE_METHOD;
+	if (callerMethodPtr->declaringClassPtr) {
+	    callerClsPtr = callerMethodPtr->declaringClassPtr;
 	}
     }
 
@@ -2620,7 +2623,8 @@ TclOOObjectCmdCore(
 
 	Tcl_IncrRefCount(mappedMethodName);
 	contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
-		flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
+		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
+		callerClsPtr, methodNamePtr);
 	TclDecrRefCount(mappedMethodName);
 	if (contextPtr == NULL) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2637,7 +2641,8 @@ TclOOObjectCmdCore(
 
     noMapping:
 	contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
-		flags | (oPtr->flags & FILTER_HANDLING), NULL);
+		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
+		callerClsPtr, NULL);
 	if (contextPtr == NULL) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		    "impossible to invoke method \"%s\": no defined method or"
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index d874cba..dc49356 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -347,7 +347,8 @@ TclOO_Object_Destroy(
     }
     if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
 	oPtr->flags |= DESTRUCTOR_CALLED;
-	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL,
+		NULL);
 	if (contextPtr != NULL) {
 	    contextPtr->callPtr->flags |= DESTRUCTOR;
 	    contextPtr->skip = 0;
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index aa30808..55f7e5b 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -60,6 +60,13 @@ static inline void	AddMethodToCallChain(Method *const mPtr,
 			    Tcl_HashTable *const doneFilters,
 			    Class *const filterDecl, int flags);
 static inline void	AddSimpleChainToCallContext(Object *const oPtr,
+			    Object *const contextObj, Class *const contextCls,
+			    Tcl_Obj *const methodNameObj,
+			    struct ChainBuilder *const cbPtr,
+			    Tcl_HashTable *const doneFilters, int flags,
+			    Class *const filterDecl);
+static void		AddPrivatesFromClassChainToCallContext(Class *classPtr,
+			    Class *const contextCls,
 			    Tcl_Obj *const methodNameObj,
 			    struct ChainBuilder *const cbPtr,
 			    Tcl_HashTable *const doneFilters, int flags,
@@ -703,6 +710,12 @@ AddClassMethodNames(
 static inline void
 AddSimpleChainToCallContext(
     Object *const oPtr,		/* Object to add call chain entries for. */
+    Object *const contextObj,	/* Context object; when equal to oPtr, it
+				 * means that private methods may also be
+				 * added. [TIP 500] */
+    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. */
@@ -720,7 +733,7 @@ AddSimpleChainToCallContext(
     Tcl_HashEntry *hPtr;
     Method *mPtr;
 
-    if (flags & OBJECT_PRIVATE_METHOD && oPtr->methodsPtr) {
+    if ((oPtr == contextObj) && oPtr->methodsPtr) {
 	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj);
 
 	if (hPtr != NULL) {
@@ -730,7 +743,6 @@ AddSimpleChainToCallContext(
 			flags);
 	    }
 	}
-	flags &= ~OBJECT_PRIVATE_METHOD;
 	flags |= DEFINITE_PROTECTED;
     } else if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
 	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj);
@@ -752,6 +764,11 @@ AddSimpleChainToCallContext(
 	Class *mixinPtr;
 
 	FOREACH(mixinPtr, oPtr->mixins) {
+	    if (contextCls) {
+		AddPrivatesFromClassChainToCallContext(mixinPtr, contextCls,
+			methodNameObj, cbPtr, doneFilters,
+			flags|TRAVERSED_MIXIN, filterDecl);
+	    }
 	    AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr,
 		    doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
 	}
@@ -766,6 +783,10 @@ AddSimpleChainToCallContext(
 	    }
 	}
     }
+    if (contextCls) {
+	AddPrivatesFromClassChainToCallContext(oPtr->selfCls, contextCls,
+		methodNameObj, cbPtr, doneFilters, flags, filterDecl);
+    }
     AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr,
 	    doneFilters, flags, filterDecl);
 }
@@ -971,6 +992,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. */
@@ -1070,10 +1097,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, NULL,
+		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
+		NULL);
+	AddSimpleChainToCallContext(oPtr, NULL, NULL,
+		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
 	callPtr->flags |= OO_UNKNOWN_METHOD;
 	callPtr->epoch = -1;
 	if (callPtr->numChain == 0) {
@@ -1102,10 +1130,10 @@ TclOOGetCallContext(
 		    OBJECT_MIXIN);
 	}
 	FOREACH(filterObj, oPtr->filters) {
-	    AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters,
-		    BUILDING_MIXINS, NULL);
-	    AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0,
-		    NULL);
+	    AddSimpleChainToCallContext(oPtr, contextObj, contextCls,
+		    filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL);
+	    AddSimpleChainToCallContext(oPtr, contextObj, contextCls,
+		    filterObj, &cb, &doneFilters, 0, NULL);
 	}
 	AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters,
 		BUILDING_MIXINS);
@@ -1120,9 +1148,10 @@ TclOOGetCallContext(
      * handle class mixins right.
      */
 
-    AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL,
-	    flags|BUILDING_MIXINS, NULL);
-    AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL);
+    AddSimpleChainToCallContext(oPtr, contextObj, contextCls, methodNameObj,
+	    &cb, NULL, flags|BUILDING_MIXINS, NULL);
+    AddSimpleChainToCallContext(oPtr, contextObj, contextCls, methodNameObj,
+	    &cb, NULL, flags, NULL);
 
     /*
      * Check to see if the method has no implementation. If so, we probably
@@ -1140,10 +1169,11 @@ 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, NULL,
+		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
+		NULL);
+	AddSimpleChainToCallContext(oPtr, NULL, NULL,
+		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
 	callPtr->flags |= OO_UNKNOWN_METHOD;
 	callPtr->epoch = -1;
 	if (count == callPtr->numChain) {
@@ -1301,9 +1331,10 @@ TclOOGetStereotypeCallChain(
      * Add the actual method implementations.
      */
 
-    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL,
+    AddSimpleChainToCallContext(&obj, NULL, NULL, methodNameObj, &cb, NULL,
 	    flags|BUILDING_MIXINS, NULL);
-    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL);
+    AddSimpleChainToCallContext(&obj, NULL, NULL, methodNameObj, &cb, NULL,
+	    flags, NULL);
 
     /*
      * Check to see if the method has no implementation. If so, we probably
@@ -1312,10 +1343,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, NULL,
+		fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, NULL);
+	AddSimpleChainToCallContext(&obj, NULL, NULL,
+		fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
 	callPtr->flags |= OO_UNKNOWN_METHOD;
 	callPtr->epoch = -1;
 	if (count == callPtr->numChain) {
@@ -1395,9 +1426,9 @@ AddClassFiltersToCallContext(
 	    (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj,
 		    &isNew);
 	    if (isNew) {
-		AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
+		AddSimpleChainToCallContext(oPtr, NULL, NULL, filterObj, cbPtr,
 			doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr);
-		AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
+		AddSimpleChainToCallContext(oPtr, NULL, NULL, filterObj, cbPtr,
 			doneFilters, clearedFlags, clsPtr);
 	    }
 	}
@@ -1432,8 +1463,11 @@ AddClassFiltersToCallContext(
  */
 
 static void
-AddSimpleClassChainToCallContext(
+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. [TIP 500] */
     Tcl_Obj *const methodNameObj,
 				/* Name of method to add the call chain
 				 * entries for. */
@@ -1447,10 +1481,70 @@ AddSimpleClassChainToCallContext(
 				 * NULL, either the filter was declared by the
 				 * object or this isn't a filter. */
 {
-    int i, private = (flags & CLASS_PRIVATE_METHOD);
+    int i;
     Class *superPtr;
 
-    flags &= ~CLASS_PRIVATE_METHOD;
+    /*
+     * 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) {
+	AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
+		methodNameObj, cbPtr, doneFilters, flags|TRAVERSED_MIXIN,
+		filterDecl);
+    }
+
+    if (classPtr == contextCls) {
+	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
+		(char *) methodNameObj);
+
+	if (hPtr != NULL) {
+	    register Method *mPtr = Tcl_GetHashValue(hPtr);
+
+	    if (mPtr->flags & TRUE_PRIVATE_METHOD) {
+		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
+			flags);
+	    }
+	}
+    }
+
+    switch (classPtr->superclasses.num) {
+    case 1:
+	classPtr = classPtr->superclasses.list[0];
+	goto tailRecurse;
+    default:
+	FOREACH(superPtr, classPtr->superclasses) {
+	    AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
+		    methodNameObj, cbPtr, doneFilters, flags, filterDecl);
+	}
+    case 0:
+	return;
+    }
+}
+
+static void
+AddSimpleClassChainToCallContext(
+    Class *classPtr,		/* Class to add the call chain entries for. */
+    Tcl_Obj *const methodNameObj,
+				/* 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
@@ -1480,9 +1574,7 @@ AddSimpleClassChainToCallContext(
 	if (hPtr != NULL) {
 	    register Method *mPtr = Tcl_GetHashValue(hPtr);
 
-	    if (private && mPtr->flags & TRUE_PRIVATE_METHOD) {
-		flags |= DEFINITE_PROTECTED;
-	    } else if (!(flags & KNOWN_STATE)) {
+	    if (!(flags & KNOWN_STATE)) {
 		if (flags & PUBLIC_METHOD) {
 		    if (mPtr->flags & PUBLIC_METHOD) {
 			flags |= DEFINITE_PUBLIC;
@@ -1493,7 +1585,7 @@ AddSimpleClassChainToCallContext(
 		    flags |= DEFINITE_PROTECTED;
 		}
 	    }
-	    if (private || !(mPtr->flags & TRUE_PRIVATE_METHOD)) {
+	    if (!(mPtr->flags & TRUE_PRIVATE_METHOD)) {
 		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
 			flags);
 	    }
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index d189528..30cf8af 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -1597,7 +1597,8 @@ InfoObjectCallCmd(
      * Get the call context and render its call chain.
      */
 
-    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
+    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
+	    NULL);
     if (contextPtr == NULL) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"cannot construct any call chain", -1));
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 55847ca..1937680 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -403,16 +403,6 @@ typedef struct CallContext {
 				/* This is a private method only accessible
 				 * from other methods defined on this class
 				 * or instance. [TIP #500] */
-#define OBJECT_PRIVATE_METHOD 0x40
-				/* This is a call of a method on an object
-				 * that may include TRUE_PRIVATE_METHOD
-				 * instance method implementations in its call
-				 * chain. */
-#define CLASS_PRIVATE_METHOD 0x80
-				/* This is a call of a method on an object
-				 * that may include TRUE_PRIVATE_METHOD class
-				 * method implementations in its call
-				 * chain. */
 
 /*
  * Structure containing definition information about basic class methods.
@@ -546,6 +536,7 @@ MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
 MODULE_SCOPE void	TclOODelMethodRef(Method *method);
 MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
 			    Tcl_Obj *methodNameObj, int flags,
+			    Object *contextObjPtr, Class *contextClsPtr,
 			    Tcl_Obj *cacheInThisObj);
 MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
 			    Tcl_Obj *methodNameObj, int flags);