1 files changed, 269 insertions, 33 deletions

diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 8c6c15b..26fd09f 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -4,12 +4,10 @@
  *	This file contains the method call chain management code for the
  *	object-system core.
  *
- * Copyright (c) 2005-2008 by Donal K. Fellows
+ * Copyright (c) 2005-2012 by Donal K. Fellows
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclOOCall.c,v 1.12 2008/09/25 10:15:04 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -39,7 +37,7 @@ struct ChainBuilder {
 #define DEFINITE_PROTECTED 0x100000
 #define DEFINITE_PUBLIC    0x200000
 #define KNOWN_STATE	   (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
-#define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR)
+#define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)
 
 /*
  * Function declarations for things defined in this file.
@@ -81,7 +79,7 @@ static inline void	StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);
  * Object type used to manage type caches attached to method names.
  */
 
-static Tcl_ObjType methodNameType = {
+static const Tcl_ObjType methodNameType = {
     "TclOO method name",
     FreeMethodNameRep,
     DupMethodNameRep,
@@ -103,8 +101,13 @@ void
 TclOODeleteContext(
     CallContext *contextPtr)
 {
+    register Object *oPtr = contextPtr->oPtr;
+
     TclOODeleteChain(contextPtr->callPtr);
-    TclStackFree(contextPtr->oPtr->fPtr->interp, contextPtr);
+    if (oPtr != NULL) {
+	TclStackFree(oPtr->fPtr->interp, contextPtr);
+	DelRef(oPtr);
+    }
 }
 
 /*
@@ -130,7 +133,7 @@ TclOODeleteChainCache(
 	}
     }
     Tcl_DeleteHashTable(tablePtr);
-    ckfree((char *) tablePtr);
+    ckfree(tablePtr);
 }
 
 /*
@@ -151,9 +154,9 @@ TclOODeleteChain(
 	return;
     }
     if (callPtr->chain != callPtr->staticChain) {
-	ckfree((char *) callPtr->chain);
+	ckfree(callPtr->chain);
     }
-    ckfree((char *) callPtr);
+    ckfree(callPtr);
 }
 
 /*
@@ -173,11 +176,9 @@ StashCallChain(
     CallChain *callPtr)
 {
     callPtr->refCount++;
-    if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc) {
-	objPtr->typePtr->freeIntRepProc(objPtr);
-    }
+    TclFreeIntRep(objPtr);
     objPtr->typePtr = &methodNameType;
-    objPtr->internalRep.otherValuePtr = callPtr;
+    objPtr->internalRep.twoPtrValue.ptr1 = callPtr;
 }
 
 void
@@ -204,10 +205,10 @@ DupMethodNameRep(
     Tcl_Obj *srcPtr,
     Tcl_Obj *dstPtr)
 {
-    register CallChain *callPtr = srcPtr->internalRep.otherValuePtr;
+    register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1;
 
     dstPtr->typePtr = &methodNameType;
-    dstPtr->internalRep.otherValuePtr = callPtr;
+    dstPtr->internalRep.twoPtrValue.ptr1 = callPtr;
     callPtr->refCount++;
 }
 
@@ -215,10 +216,9 @@ static void
 FreeMethodNameRep(
     Tcl_Obj *objPtr)
 {
-    register CallChain *callPtr = objPtr->internalRep.otherValuePtr;
+    register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1;
 
     TclOODeleteChain(callPtr);
-    objPtr->internalRep.otherValuePtr = NULL;
     objPtr->typePtr = NULL;
 }
 
@@ -452,7 +452,7 @@ TclOOGetSortedMethodList(
 	 * heavily sorted when it is long enough to matter.
 	 */
 
-	strings = (const char **) ckalloc(sizeof(char *) * names.numEntries);
+	strings = ckalloc(sizeof(char *) * names.numEntries);
 	FOREACH_HASH(namePtr, isWanted, &names) {
 	    if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
 		if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
@@ -473,7 +473,7 @@ TclOOGetSortedMethodList(
 	    }
 	    *stringsPtr = strings;
 	} else {
-	    ckfree((char *) strings);
+	    ckfree(strings);
 	}
     }
 
@@ -519,7 +519,7 @@ TclOOGetSortedClassMethodList(
 	 * heavily sorted when it is long enough to matter.
 	 */
 
-	strings = (const char **) ckalloc(sizeof(char *) * names.numEntries);
+	strings = ckalloc(sizeof(char *) * names.numEntries);
 	FOREACH_HASH(namePtr, isWanted, &names) {
 	    if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
 		if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
@@ -540,7 +540,7 @@ TclOOGetSortedClassMethodList(
 	    }
 	    *stringsPtr = strings;
 	} else {
-	    ckfree((char *) strings);
+	    ckfree(strings);
 	}
     }
 
@@ -802,12 +802,12 @@ AddMethodToCallChain(
      */
 
     if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
-	callPtr->chain = (struct MInvoke *)
-		ckalloc(sizeof(struct MInvoke)*(callPtr->numChain+1));
+	callPtr->chain =
+		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) {
-	callPtr->chain = (struct MInvoke *) ckrealloc((char *) callPtr->chain,
+	callPtr->chain = ckrealloc(callPtr->chain,
 		sizeof(struct MInvoke) * (callPtr->numChain + 1));
     }
     callPtr->chain[i].mPtr = mPtr;
@@ -897,10 +897,13 @@ TclOOGetCallContext(
     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.
+    int flags,			/* What sort of context are we looking for.
 				 * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
 				 * PRIVATE_METHOD, DESTRUCTOR and
 				 * FILTER_HANDLING are useful. */
+    Tcl_Obj *cacheInThisObj)	/* What object to cache in, or NULL if it is
+				 * to be in the same object as the
+				 * methodNameObj. */
 {
     CallContext *contextPtr;
     CallChain *callPtr;
@@ -909,6 +912,9 @@ TclOOGetCallContext(
     Tcl_HashEntry *hPtr;
     Tcl_HashTable doneFilters;
 
+    if (cacheInThisObj == NULL) {
+	cacheInThisObj = methodNameObj;
+    }
     if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
 	hPtr = NULL;
 	doFilters = 0;
@@ -944,13 +950,13 @@ TclOOGetCallContext(
 
 	const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
 
-	if (methodNameObj->typePtr == &methodNameType) {
-	    callPtr = methodNameObj->internalRep.otherValuePtr;
+	if (cacheInThisObj->typePtr == &methodNameType) {
+	    callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1;
 	    if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
 		callPtr->refCount++;
 		goto returnContext;
 	    }
-	    methodNameObj->typePtr->freeIntRepProc(methodNameObj);
+	    FreeMethodNameRep(cacheInThisObj);
 	}
 
 	if (oPtr->flags & USE_CLASS_CACHE) {
@@ -982,7 +988,7 @@ TclOOGetCallContext(
 	doFilters = 1;
     }
 
-    callPtr = (CallChain *) ckalloc(sizeof(CallChain));
+    callPtr = ckalloc(sizeof(CallChain));
     InitCallChain(callPtr, oPtr, flags);
 
     cb.callChainPtr = callPtr;
@@ -990,6 +996,22 @@ TclOOGetCallContext(
     cb.oPtr = oPtr;
 
     /*
+     * If we're working with a forced use of unknown, do that now.
+     */
+
+    if (flags & FORCE_UNKNOWN) {
+	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
+		&cb, NULL, 0, NULL);
+	callPtr->flags |= OO_UNKNOWN_METHOD;
+	callPtr->epoch = -1;
+	if (callPtr->numChain == 0) {
+	    TclOODeleteChain(callPtr);
+	    return NULL;
+	}
+	goto returnContext;
+    }
+
+    /*
      * 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).
@@ -1047,7 +1069,7 @@ TclOOGetCallContext(
 	if (hPtr == NULL) {
 	    if (oPtr->flags & USE_CLASS_CACHE) {
 		if (oPtr->selfCls->classChainCache == NULL) {
-		    oPtr->selfCls->classChainCache = (Tcl_HashTable *)
+		    oPtr->selfCls->classChainCache =
 			    ckalloc(sizeof(Tcl_HashTable));
 
 		    Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
@@ -1056,8 +1078,7 @@ TclOOGetCallContext(
 			(char *) methodNameObj, &i);
 	    } else {
 		if (oPtr->chainCache == NULL) {
-		    oPtr->chainCache = (Tcl_HashTable *)
-			    ckalloc(sizeof(Tcl_HashTable));
+		    oPtr->chainCache = ckalloc(sizeof(Tcl_HashTable));
 
 		    Tcl_InitObjHashTable(oPtr->chainCache);
 		}
@@ -1067,7 +1088,7 @@ TclOOGetCallContext(
 	}
 	callPtr->refCount++;
 	Tcl_SetHashValue(hPtr, callPtr);
-	StashCallChain(methodNameObj, callPtr);
+	StashCallChain(cacheInThisObj, callPtr);
     } else if (flags & CONSTRUCTOR) {
 	if (oPtr->selfCls->constructorChainPtr) {
 	    TclOODeleteChain(oPtr->selfCls->constructorChainPtr);
@@ -1085,6 +1106,7 @@ TclOOGetCallContext(
   returnContext:
     contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
     contextPtr->oPtr = oPtr;
+    AddRef(oPtr);
     contextPtr->callPtr = callPtr;
     contextPtr->skip = 2;
     contextPtr->index = 0;
@@ -1094,6 +1116,135 @@ 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 = 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 = 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
@@ -1251,6 +1402,91 @@ 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);
+    }
+
+    /*
+     * 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