path: root/generic/tclOOCall.c

/*
 * tclOOCall.c --
 *
 *	This file contains the method call chain management code for the
 *	object-system core. It also contains everything else that does
 *	inheritance hierarchy traversal.
 *
 * Copyright © 2005-2019 Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
#include <assert.h>

/*
 * Structure containing a CallContext and any other values needed only during
 * the construction of the CallContext.
 */

struct ChainBuilder {
    CallChain *callChainPtr;	/* The call chain being built. */
    int filterLength;		/* Number of entries in the call chain that
				 * are due to processing filters and not the
				 * main call chain. */
    Object *oPtr;		/* The object that we are building the chain
				 * for. */
};

/*
 * Structures used for traversing the class hierarchy to find out where
 * definitions are supposed to be done.
 */

typedef struct {
    Class *definerCls;
    Tcl_Obj *namespaceName;
} DefineEntry;

typedef struct {
    DefineEntry *list;
    int num;
    int size;
} DefineChain;

/*
 * Extra flags used for call chain management.
 */

#define DEFINITE_PROTECTED 0x100000
#define DEFINITE_PUBLIC    0x200000
#define KNOWN_STATE	   (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
#define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)
#define BUILDING_MIXINS	   0x400000
#define TRAVERSED_MIXIN	   0x800000
#define OBJECT_MIXIN	   0x1000000
#define DEFINE_FOR_CLASS   0x2000000
#define MIXIN_CONSISTENT(flags) \
    (((flags) & OBJECT_MIXIN) ||					\
	!((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.
 */

static void		AddClassFiltersToCallContext(Object *const oPtr,
			    Class *clsPtr, struct ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags);
static void		AddClassMethodNames(Class *clsPtr, int flags,
			    Tcl_HashTable *const namesPtr,
			    Tcl_HashTable *const examinedClassesPtr);
static inline void	AddDefinitionNamespaceToChain(Class *const definerCls,
			    Tcl_Obj *const namespaceName,
			    DefineChain *const definePtr, int flags);
static inline void	AddMethodToCallChain(Method *const mPtr,
			    struct ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters,
			    Class *const filterDecl, int flags);
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 int		AddSimpleClassChainToCallContext(Class *classPtr,
			    Tcl_Obj *const methodNameObj,
			    struct ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static void		AddSimpleClassDefineNamespaces(Class *classPtr,
			    DefineChain *const definePtr, int flags);
static inline void	AddSimpleDefineNamespaces(Object *const oPtr,
			    DefineChain *const definePtr, int flags);
static int		CmpStr(const void *ptr1, const void *ptr2);
static void		DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
static Tcl_NRPostProc	FinalizeMethodRefs;
static void		FreeMethodNameRep(Tcl_Obj *objPtr);
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);

/*
 * Object type used to manage type caches attached to method names.
 */

static const Tcl_ObjType methodNameType = {
    "TclOO method name",
    FreeMethodNameRep,
    DupMethodNameRep,
    NULL,
    NULL
};


/*
 * ----------------------------------------------------------------------
 *
 * TclOODeleteContext --
 *
 *	Destroys a method call-chain context, which should not be in use.
 *
 * ----------------------------------------------------------------------
 */

void
TclOODeleteContext(
    CallContext *contextPtr)
{
    Object *oPtr = contextPtr->oPtr;

    TclOODeleteChain(contextPtr->callPtr);
    if (oPtr != NULL) {
	TclStackFree(oPtr->fPtr->interp, contextPtr);

	/*
	 * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore
	 */

	TclOODecrRefCount(oPtr);
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODeleteChainCache --
 *
 *	Destroy the cache of method call-chains.
 *
 * ----------------------------------------------------------------------
 */

void
TclOODeleteChainCache(
    Tcl_HashTable *tablePtr)
{
    FOREACH_HASH_DECLS;
    CallChain *callPtr;

    FOREACH_HASH_VALUE(callPtr, tablePtr) {
	if (callPtr) {
	    TclOODeleteChain(callPtr);
	}
    }
    Tcl_DeleteHashTable(tablePtr);
    ckfree(tablePtr);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODeleteChain --
 *
 *	Destroys a method call-chain.
 *
 * ----------------------------------------------------------------------
 */

void
TclOODeleteChain(
    CallChain *callPtr)
{
    if (callPtr == NULL || callPtr->refCount-- > 1) {
	return;
    }
    if (callPtr->chain != callPtr->staticChain) {
	ckfree(callPtr->chain);
    }
    ckfree(callPtr);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOStashContext --
 *
 *	Saves a reference to a method call context in a Tcl_Obj's internal
 *	representation.
 *
 * ----------------------------------------------------------------------
 */

static inline void
StashCallChain(
    Tcl_Obj *objPtr,
    CallChain *callPtr)
{
    Tcl_ObjInternalRep ir;

    callPtr->refCount++;
    TclGetString(objPtr);
    ir.twoPtrValue.ptr1 = callPtr;
    Tcl_StoreInternalRep(objPtr, &methodNameType, &ir);
}

void
TclOOStashContext(
    Tcl_Obj *objPtr,
    CallContext *contextPtr)
{
    StashCallChain(objPtr, contextPtr->callPtr);
}

/*
 * ----------------------------------------------------------------------
 *
 * DupMethodNameRep, FreeMethodNameRep --
 *
 *	Functions to implement the required parts of the Tcl_Obj guts needed
 *	for caching of method contexts in Tcl_Objs.
 *
 * ----------------------------------------------------------------------
 */

static void
DupMethodNameRep(
    Tcl_Obj *srcPtr,
    Tcl_Obj *dstPtr)
{
    StashCallChain(dstPtr,
	    (CallChain *)TclFetchInternalRep(srcPtr, &methodNameType)->twoPtrValue.ptr1);
}

static void
FreeMethodNameRep(
    Tcl_Obj *objPtr)
{
    TclOODeleteChain(
	    (CallChain *)TclFetchInternalRep(objPtr, &methodNameType)->twoPtrValue.ptr1);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOInvokeContext --
 *
 *	Invokes a single step along a method call-chain context. Note that the
 *	invocation of a step along the chain can cause further steps along the
 *	chain to be invoked. Note that this function is written to be as light
 *	in stack usage as possible.
 *
 * ----------------------------------------------------------------------
 */

int
TclOOInvokeContext(
    void *clientData,	/* The method call context. */
    Tcl_Interp *interp,		/* Interpreter for error reporting, and many
				 * other sorts of context handling (e.g.,
				 * commands, variables) depending on method
				 * implementation. */
    int objc,			/* The number of arguments. */
    Tcl_Obj *const objv[])	/* The arguments as actually seen. */
{
    CallContext *const contextPtr = (CallContext *)clientData;
    Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    const int isFilter =
	    contextPtr->callPtr->chain[contextPtr->index].isFilter;

    /*
     * If this is the first step along the chain, we preserve the method
     * entries in the chain so that they do not get deleted out from under our
     * feet.
     */

    if (contextPtr->index == 0) {
	int i;

	for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
	    AddRef(contextPtr->callPtr->chain[i].mPtr);
	}

	/*
	 * Ensure that the method name itself is part of the arguments when
	 * we're doing unknown processing.
	 */

	if (contextPtr->callPtr->flags & OO_UNKNOWN_METHOD) {
	    contextPtr->skip--;
	}

	/*
	 * Add a callback to ensure that method references are dropped once
	 * this call is finished.
	 */

	TclNRAddCallback(interp, FinalizeMethodRefs, contextPtr, NULL, NULL,
		NULL);
    }

    /*
     * Save whether we were in a filter and set up whether we are now.
     */

    if (contextPtr->oPtr->flags & FILTER_HANDLING) {
	TclNRAddCallback(interp, SetFilterFlags, contextPtr, NULL,NULL,NULL);
    } else {
	TclNRAddCallback(interp, ResetFilterFlags,contextPtr,NULL,NULL,NULL);
    }
    if (isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) {
	contextPtr->oPtr->flags |= FILTER_HANDLING;
    } else {
	contextPtr->oPtr->flags &= ~FILTER_HANDLING;
    }

    /*
     * Run the method implementation.
     */

    if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
	return (mPtr->typePtr->callProc)(mPtr->clientData, interp,
		(Tcl_ObjectContext) contextPtr, objc, objv);
    }
    return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
	    (Tcl_ObjectContext) contextPtr, objc, objv);
}

static int
SetFilterFlags(
    void *data[],
    TCL_UNUSED(Tcl_Interp *),
    int result)
{
    CallContext *contextPtr = (CallContext *)data[0];

    contextPtr->oPtr->flags |= FILTER_HANDLING;
    return result;
}

static int
ResetFilterFlags(
    void *data[],
    TCL_UNUSED(Tcl_Interp *),
    int result)
{
    CallContext *contextPtr = (CallContext *)data[0];

    contextPtr->oPtr->flags &= ~FILTER_HANDLING;
    return result;
}

static int
FinalizeMethodRefs(
    void *data[],
    TCL_UNUSED(Tcl_Interp *),
    int result)
{
    CallContext *contextPtr = (CallContext *)data[0];
    int i;

    for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
	TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
    }
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOGetSortedMethodList, TclOOGetSortedClassMethodList --
 *
 *	Discovers the list of method names supported by an object or class.
 *
 * ----------------------------------------------------------------------
 */

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
				 * strings to. */
{
    Tcl_HashTable names;	/* Tcl_Obj* method name to "wanted in list"
				 * mapping. */
    Tcl_HashTable examinedClasses;
				/* 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, numStrings;
    Class *mixinPtr;
    Tcl_Obj *namePtr;
    Method *mPtr;

    Tcl_InitObjHashTable(&names);
    Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);

    /*
     * Name the bits used in the names table values.
     */
#define IN_LIST 1
#define NO_IMPLEMENTATION 2

    /*
     * Process method names due to the object.
     */

    if (oPtr->methodsPtr) {
	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
	    if (IS_PRIVATE(mPtr)) {
		continue;
	    }
	    if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) {
		continue;
	    }
	    AddStandardMethodName(flags, namePtr, mPtr, &names);
	}
    }

    /*
     * Process method names due to private methods on the object's class.
     */

    if (WANT_UNEXPORTED(flags)) {
	FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) {
	    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,
		&examinedClasses);
    }

    /*
     * Tidy up, sort the names and resolve finally whether we really want
     * them (processing export layering).
     */

    Tcl_DeleteHashTable(&examinedClasses);
    numStrings = SortMethodNames(&names, flags, stringsPtr);
    Tcl_DeleteHashTable(&names);
    return numStrings;
}

int
TclOOGetSortedClassMethodList(
    Class *clsPtr,		/* The class to get the method names for. */
    int flags,			/* Whether we just want the public method
				 * names. */
    const char ***stringsPtr)	/* Where to write a pointer to the array of
				 * strings to. */
{
    Tcl_HashTable names;	/* Tcl_Obj* method name to "wanted in list"
				 * mapping. */
    Tcl_HashTable examinedClasses;
				/* Used to track what classes have been looked
				 * at. Is set-like in nature and keyed by
				 * pointer to class. */
    int numStrings;

    Tcl_InitObjHashTable(&names);
    Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);

    /*
     * Process method names from the class hierarchy and the mixin hierarchy.
     */

    AddClassMethodNames(clsPtr, flags, &names, &examinedClasses);
    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.
     */

    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.
     */

    strings = (const char **)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. We don't sort unless there's at least
     * two method names.
     */

    if (i > 0) {
	if (i > 1) {
	    qsort((void *) strings, i, sizeof(char *), CmpStr);
	}
	*stringsPtr = strings;
    } else {
	ckfree(strings);
	*stringsPtr = NULL;
    }
    return i;
}

/*
 * Comparator for SortMethodNames
 */

static int
CmpStr(
    const void *ptr1,
    const void *ptr2)
{
    const char **strPtr1 = (const char **) ptr1;
    const char **strPtr2 = (const char **) ptr2;

    return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1) + 1);
}

/*
 * ----------------------------------------------------------------------
 *
 * AddClassMethodNames --
 *
 *	Adds the method names defined by a class (or its superclasses) to the
 *	collection being built. The collection is built in a hash table to
 *	ensure that duplicates are excluded. Helper for GetSortedMethodList().
 *
 * ----------------------------------------------------------------------
 */

static void
AddClassMethodNames(
    Class *clsPtr,		/* Class to get method names from. */
    int flags,		/* Whether we are interested in just the
				 * public method names. */
    Tcl_HashTable *const namesPtr,
				/* Reference to the hash table to put the
				 * information in. The hash table maps the
				 * Tcl_Obj * method name to an integral value
				 * describing whether the method is wanted.
				 * This ensures that public/private override
				 * semantics are handled correctly. */
    Tcl_HashTable *const examinedClassesPtr)
				/* Hash table that tracks what classes have
				 * already been looked at. The keys are the
				 * 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.
     */

    if (Tcl_FindHashEntry(examinedClassesPtr, (char *) clsPtr)) {
	return;
    }

    /*
     * Scope all declarations so that the compiler can stand a good chance of
     * making the recursive step highly efficient. We also hand-implement the
     * tail-recursive case using a while loop; C compilers typically cannot do
     * tail-recursion optimization usefully.
     */

    while (1) {
	FOREACH_HASH_DECLS;
	Tcl_Obj *namePtr;
	Method *mPtr;
	int isNew;

	(void) Tcl_CreateHashEntry(examinedClassesPtr, (char *) clsPtr,
		&isNew);
	if (!isNew) {
	    break;
	}

	if (clsPtr->mixins.num != 0) {
	    Class *mixinPtr;

	    FOREACH(mixinPtr, clsPtr->mixins) {
		if (mixinPtr != clsPtr) {
		    AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN,
			    namesPtr, examinedClassesPtr);
		}
	    }
	}

	FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
	    AddStandardMethodName(flags, namePtr, mPtr, namesPtr);
	}

	if (clsPtr->superclasses.num != 1) {
	    break;
	}
	clsPtr = clsPtr->superclasses.list[0];
    }
    if (clsPtr->superclasses.num != 0) {
	Class *superPtr;

	FOREACH(superPtr, clsPtr->superclasses) {
	    AddClassMethodNames(superPtr, flags, namesPtr,
		    examinedClassesPtr);
	}
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * 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 = (Method *)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. Returns true if a private method was one of those found.
 *
 * ----------------------------------------------------------------------
 */

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. */
    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, foundPrivate = 0, blockedUnexported = 0;
    Tcl_HashEntry *hPtr;
    Method *mPtr;

    if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj);

	if (hPtr != NULL) {
	    mPtr = (Method *)Tcl_GetHashValue(hPtr);
	    if (!IS_PRIVATE(mPtr)) {
		if (WANT_PUBLIC(flags)) {
		    if (!IS_PUBLIC(mPtr)) {
			blockedUnexported = 1;
		    } else {
			flags |= DEFINITE_PUBLIC;
		    }
		} else {
		    flags |= DEFINITE_PROTECTED;
		}
	    }
	}
    }
    if (!(flags & SPECIAL)) {
	Class *mixinPtr;

	FOREACH(mixinPtr, oPtr->mixins) {
	    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 && !blockedUnexported) {
	    hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
	    if (hPtr != NULL) {
		mPtr = (Method *)Tcl_GetHashValue(hPtr);
		if (!IS_PRIVATE(mPtr)) {
		    AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
			    flags);
		}
	    }
	}
    }
    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;
}

/*
 * ----------------------------------------------------------------------
 *
 * AddMethodToCallChain --
 *
 *	Utility method that manages the adding of a particular method
 *	implementation to a call-chain.
 *
 * ----------------------------------------------------------------------
 */

static inline void
AddMethodToCallChain(
    Method *const mPtr,		/* Actual method implementation to add to call
				 * chain (or NULL, a no-op). */
    struct ChainBuilder *const cbPtr,
				/* The call chain to add the method
				 * implementation to. */
    Tcl_HashTable *const doneFilters,
				/* Where to record what filters have been
				 * processed. If NULL, not processing filters.
				 * Note that this function does not update
				 * this hashtable. */
    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 flags)			/* Used to check if we're mixin-consistent
				 * only. Mixin-consistent means that either
				 * we're looking to add things from a mixin
				 * and we have passed a mixin, or we're not
				 * looking to add things from a mixin and have
				 * not passed a mixin. */
{
    CallChain *callPtr = cbPtr->callChainPtr;
    int i;

    /*
     * Return if this is just an entry used to record whether this is a public
     * method. If so, there's nothing real to call and so nothing to add to
     * the call chain.
     *
     * This is also where we enforce mixin-consistency.
     */

    if (mPtr == NULL || mPtr->typePtr == NULL || !MIXIN_CONSISTENT(flags)) {
	return;
    }

    /*
     * Enforce real private method handling here. We will skip adding this
     * method IF
     *  1) we are not allowing private methods, AND
     *  2) this is a private method, AND
     *  3) this is a class method, AND
     *  4) this method was not declared by the class of the current object.
     *
     * This does mean that only classes really handle private methods. This
     * should be sufficient for [incr Tcl] support though.
     */

    if (!WANT_UNEXPORTED(callPtr->flags)
	    && IS_UNEXPORTED(mPtr)
	    && (mPtr->declaringClassPtr != NULL)
	    && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) {
	return;
    }

    /*
     * First test whether the method is already in the call chain. Skip over
     * any leading filters.
     */

    for (i = cbPtr->filterLength ; i < callPtr->numChain ; i++) {
	if (callPtr->chain[i].mPtr == mPtr &&
		callPtr->chain[i].isFilter == (doneFilters != NULL)) {
	    /*
	     * Call chain semantics states that methods come as *late* in the
	     * call chain as possible. This is done by copying down the
	     * following methods. Note that this does not change the number of
	     * method invocations in the call chain; it just rearranges them.
	     */

	    Class *declCls = callPtr->chain[i].filterDeclarer;

	    for (; i + 1 < callPtr->numChain ; i++) {
		callPtr->chain[i] = callPtr->chain[i + 1];
	    }
	    callPtr->chain[i].mPtr = mPtr;
	    callPtr->chain[i].isFilter = (doneFilters != NULL);
	    callPtr->chain[i].filterDeclarer = declCls;
	    return;
	}
    }

    /*
     * Need to really add the method. This is made a bit more complex by the
     * fact that we are using some "static" space initially, and only start
     * realloc-ing if the chain gets long.
     */

    if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
	callPtr->chain =
		(struct MInvoke *)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(callPtr->chain,
		sizeof(struct MInvoke) * (callPtr->numChain + 1));
    }
    callPtr->chain[i].mPtr = mPtr;
    callPtr->chain[i].isFilter = (doneFilters != NULL);
    callPtr->chain[i].filterDeclarer = filterDecl;
    callPtr->numChain++;
}

/*
 * ----------------------------------------------------------------------
 *
 * InitCallChain --
 *	Encoding of the policy of how to set up a call chain. Doesn't populate
 *	the chain with the method implementation data.
 *
 * ----------------------------------------------------------------------
 */

static inline void
InitCallChain(
    CallChain *callPtr,
    Object *oPtr,
    int flags)
{
    callPtr->flags = flags &
	    (PUBLIC_METHOD | PRIVATE_METHOD | SPECIAL | FILTER_HANDLING);
    if (oPtr->flags & USE_CLASS_CACHE) {
	oPtr = oPtr->selfCls->thisPtr;
	callPtr->flags |= USE_CLASS_CACHE;
    }
    callPtr->epoch = oPtr->fPtr->epoch;
    callPtr->objectCreationEpoch = oPtr->creationEpoch;
    callPtr->objectEpoch = oPtr->epoch;
    callPtr->refCount = 1;
    callPtr->numChain = 0;
    callPtr->chain = callPtr->staticChain;
}

/*
 * ----------------------------------------------------------------------
 *
 * IsStillValid --
 *
 *	Calculates whether the given call chain can be used for executing a
 *	method for the given object. The condition on a chain from a cached
 *	location being reusable is:
 *	- Refers to the same object (same creation epoch), and
 *	- Still across the same class structure (same global epoch), and
 *	- Still across the same object structure (same local epoch), and
 *	- No public/private/filter magic leakage (same flags, modulo the fact
 *	  that a public chain will satisfy a non-public call).
 *
 * ----------------------------------------------------------------------
 */

static inline int
IsStillValid(
    CallChain *callPtr,
    Object *oPtr,
    int flags,
    int mask)
{
    if ((oPtr->flags & USE_CLASS_CACHE)) {
	oPtr = oPtr->selfCls->thisPtr;
	flags |= USE_CLASS_CACHE;
    }
    return ((callPtr->objectCreationEpoch == oPtr->creationEpoch)
	    && (callPtr->epoch == oPtr->fPtr->epoch)
	    && (callPtr->objectEpoch == oPtr->epoch)
	    && ((callPtr->flags & mask) == (flags & mask)));
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOGetCallContext --
 *
 *	Responsible for constructing the call context, an ordered list of all
 *	method implementations to be called as part of a method invocation.
 *	This method is central to the whole operation of the OO system.
 *
 * ----------------------------------------------------------------------
 */

CallContext *
TclOOGetCallContext(
    Object *oPtr,		/* 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. */
    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. */
{
    CallContext *contextPtr;
    CallChain *callPtr;
    struct ChainBuilder cb;
    int i, count;
    int doFilters, donePrivate = 0;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable doneFilters;

    if (cacheInThisObj == NULL) {
	cacheInThisObj = methodNameObj;
    }
    if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
	hPtr = NULL;
	doFilters = 0;

	/*
	 * Check if we have a cached valid constructor or destructor.
	 */

	if (flags & CONSTRUCTOR) {
	    callPtr = oPtr->selfCls->constructorChainPtr;
	    if ((callPtr != NULL)
		    && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch)
		    && (callPtr->epoch == oPtr->fPtr->epoch)) {
		callPtr->refCount++;
		goto returnContext;
	    }
	} else if (flags & DESTRUCTOR) {
	    callPtr = oPtr->selfCls->destructorChainPtr;
	    if ((oPtr->mixins.num == 0) && (callPtr != NULL)
		    && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch)
		    && (callPtr->epoch == oPtr->fPtr->epoch)) {
		callPtr->refCount++;
		goto returnContext;
	    }
	}
    } else {
	/*
	 * 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).
	 */

	const Tcl_ObjInternalRep *irPtr;
	const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);

	if ((irPtr = TclFetchInternalRep(cacheInThisObj, &methodNameType))) {
	    callPtr = (CallChain *)irPtr->twoPtrValue.ptr1;
	    if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
		callPtr->refCount++;
		goto returnContext;
	    }
	    Tcl_StoreInternalRep(cacheInThisObj, &methodNameType, NULL);
	}

	if (oPtr->flags & USE_CLASS_CACHE) {
	    if (oPtr->selfCls->classChainCache != NULL) {
		hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache,
			(char *) methodNameObj);
	    } else {
		hPtr = NULL;
	    }
	} else {
	    if (oPtr->chainCache != NULL) {
		hPtr = Tcl_FindHashEntry(oPtr->chainCache,
			(char *) methodNameObj);
	    } else {
		hPtr = NULL;
	    }
	}

	if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
	    callPtr = (CallChain *)Tcl_GetHashValue(hPtr);
	    if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
		callPtr->refCount++;
		goto returnContext;
	    }
	    Tcl_SetHashValue(hPtr, NULL);
	    TclOODeleteChain(callPtr);
	}

	doFilters = 1;
    }

    callPtr = (CallChain *)ckalloc(sizeof(CallChain));
    InitCallChain(callPtr, oPtr, flags);

    cb.callChainPtr = callPtr;
    cb.filterLength = 0;
    cb.oPtr = oPtr;

    /*
     * If we're working with a forced use of unknown, do that now.
     */

    if (flags & FORCE_UNKNOWN) {
	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) {
	    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).
     */

    if (doFilters) {
	Tcl_Obj *filterObj;
	Class *mixinPtr;

	doFilters = 1;
	Tcl_InitObjHashTable(&doneFilters);
	FOREACH(mixinPtr, oPtr->mixins) {
	    AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters,
		    TRAVERSED_MIXIN|BUILDING_MIXINS|OBJECT_MIXIN);
	    AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters,
		    OBJECT_MIXIN);
	}
	FOREACH(filterObj, oPtr->filters) {
	    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);
	AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters,
		0);
	Tcl_DeleteHashTable(&doneFilters);
    }
    count = cb.filterLength = callPtr->numChain;

    /*
     * Add the actual method implementations. We have to do this twice to
     * handle class mixins right.
     */

    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
     * 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) {
	/*
	 * Method does not actually exist. If we're dealing with constructors
	 * or destructors, this isn't a problem.
	 */

	if (flags & SPECIAL) {
	    TclOODeleteChain(callPtr);
	    return 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 && !donePrivate) {
	if (hPtr == NULL) {
	    if (oPtr->flags & USE_CLASS_CACHE) {
		if (oPtr->selfCls->classChainCache == NULL) {
		    oPtr->selfCls->classChainCache =
			    (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));

		    Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
		}
		hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache,
			(char *) methodNameObj, &i);
	    } else {
		if (oPtr->chainCache == NULL) {
		    oPtr->chainCache = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));

		    Tcl_InitObjHashTable(oPtr->chainCache);
		}
		hPtr = Tcl_CreateHashEntry(oPtr->chainCache,
			(char *) methodNameObj, &i);
	    }
	}
	callPtr->refCount++;
	Tcl_SetHashValue(hPtr, callPtr);
	StashCallChain(cacheInThisObj, callPtr);
    } else if (flags & CONSTRUCTOR) {
	if (oPtr->selfCls->constructorChainPtr) {
	    TclOODeleteChain(oPtr->selfCls->constructorChainPtr);
	}
	oPtr->selfCls->constructorChainPtr = callPtr;
	callPtr->refCount++;
    } else if ((flags & DESTRUCTOR) && oPtr->mixins.num == 0) {
	if (oPtr->selfCls->destructorChainPtr) {
	    TclOODeleteChain(oPtr->selfCls->destructorChainPtr);
	}
	oPtr->selfCls->destructorChainPtr = callPtr;
	callPtr->refCount++;
    }

  returnContext:
    contextPtr = (CallContext *)TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
    contextPtr->oPtr = oPtr;

    /*
     * Corresponding TclOODecrRefCount() in TclOODeleteContext
     */

    AddRef(oPtr);
    contextPtr->callPtr = callPtr;
    contextPtr->skip = 2;
    contextPtr->index = 0;
    return contextPtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * 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 = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);

	    callPtr = (CallChain *)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,
	    BUILDING_MIXINS);
    AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters, 0);
    Tcl_DeleteHashTable(&doneFilters);
    count = cb.filterLength = callPtr->numChain;

    /*
     * Add the actual method implementations.
     */

    AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL,
	    flags|BUILDING_MIXINS, NULL);
    AddSimpleChainToCallContext(&obj, NULL, 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
     * caching of the method implementation (if relevant).
     */

    if (count == callPtr->numChain) {
	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) {
	    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
 *	easier.
 *
 * ----------------------------------------------------------------------
 */

static void
AddClassFiltersToCallContext(
    Object *const oPtr,		/* Object that the filters operate on. */
    Class *clsPtr,		/* Class to get the filters from. */
    struct ChainBuilder *const cbPtr,
				/* Context to fill with call chain entries. */
    Tcl_HashTable *const doneFilters,
				/* Where to record what filters have been
				 * processed. Keys are objects, values are
				 * ignored. */
    int flags)			/* Whether we've gone along a mixin link
				 * yet. */
{
    int i;
    int clearedFlags =
	    flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS);
    Class *superPtr, *mixinPtr;
    Tcl_Obj *filterObj;

  tailRecurse:
    if (clsPtr == NULL) {
	return;
    }

    /*
     * Add all the filters defined by classes mixed into the main class
     * hierarchy.
     */

    FOREACH(mixinPtr, clsPtr->mixins) {
	AddClassFiltersToCallContext(oPtr, mixinPtr, cbPtr, doneFilters,
		flags|TRAVERSED_MIXIN);
    }

    /*
     * Add all the class filters from the current class. Note that the filters
     * are added starting at the object root, as this allows the object to
     * override how filters work to extend their behaviour.
     */

    if (MIXIN_CONSISTENT(flags)) {
	FOREACH(filterObj, clsPtr->filters) {
	    int isNew;

	    (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj,
		    &isNew);
	    if (isNew) {
		AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
			doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr);
		AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
			doneFilters, clearedFlags, clsPtr);
	    }
	}
    }

    /*
     * Now process the recursive case. Notice the tail-call optimization.
     */

    switch (clsPtr->superclasses.num) {
    case 1:
	clsPtr = clsPtr->superclasses.list[0];
	goto tailRecurse;
    default:
	FOREACH(superPtr, clsPtr->superclasses) {
	    AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters,
		    flags);
	}
    case 0:
	return;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * 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,
		methodName);

	if (hPtr != NULL) {
	    Method *mPtr = (Method *)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;
	    }
	}
	/* FALLTHRU */
    case 0:
	return 0;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * AddSimpleClassChainToCallContext --
 *
 *	Construct a call-chain from a class hierarchy.
 *
 * ----------------------------------------------------------------------
 */

static int
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, privateDanger = 0;
    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) {
	privateDanger |= AddSimpleClassChainToCallContext(superPtr,
		methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN,
		filterDecl);
    }

    if (flags & CONSTRUCTOR) {
	AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters,
		filterDecl, flags);
    } else if (flags & DESTRUCTOR) {
	AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters,
		filterDecl, flags);
    } else {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
		(char *) methodNameObj);

	if (classPtr->flags & HAS_PRIVATE_METHODS) {
	    privateDanger |= 1;
	}
	if (hPtr != NULL) {
	    Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);

	    if (!IS_PRIVATE(mPtr)) {
		if (!(flags & KNOWN_STATE)) {
		    if (flags & PUBLIC_METHOD) {
			if (!IS_PUBLIC(mPtr)) {
			    return privateDanger;
			}
			flags |= DEFINITE_PUBLIC;
		    } else {
			flags |= DEFINITE_PROTECTED;
		    }
		}
		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
			flags);
	    }
	}
    }

    switch (classPtr->superclasses.num) {
    case 1:
	classPtr = classPtr->superclasses.list[0];
	goto tailRecurse;
    default:
	FOREACH(superPtr, classPtr->superclasses) {
	    privateDanger |= AddSimpleClassChainToCallContext(superPtr,
		    methodNameObj, cbPtr, doneFilters, flags, filterDecl);
	}
	/* FALLTHRU */
    case 0:
	return privateDanger;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * 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, *privateLiteral;
    Tcl_Obj *resultObj, *descObjs[4], **objv;
    Foundation *fPtr = TclOOGetFoundation(interp);
    int i;

    /*
     * Allocate the literals (potentially) used in our description.
     */

    TclNewLiteralStringObj(filterLiteral, "filter");
    Tcl_IncrRefCount(filterLiteral);
    TclNewLiteralStringObj(methodLiteral, "method");
    Tcl_IncrRefCount(methodLiteral);
    TclNewLiteralStringObj(objectLiteral, "object");
    Tcl_IncrRefCount(objectLiteral);
    TclNewLiteralStringObj(privateLiteral, "private");
    Tcl_IncrRefCount(privateLiteral);

    /*
     * 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 invocation ("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 = (Tcl_Obj **)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 :
	    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)
		: 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);
    Tcl_DecrRefCount(privateLiteral);

    /*
     * Finish building the description and return it.
     */

    resultObj = Tcl_NewListObj(callPtr->numChain, objv);
    TclStackFree(interp, objv);
    return resultObj;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOGetDefineContextNamespace --
 *
 *	Responsible for determining which namespace to use for definitions.
 *	This is done by building a define chain, which models (strongly!) the
 *	way that a call chain works but with a different internal model.
 *
 *	Then it walks the chain to find the first namespace name that actually
 *	resolves to an existing namespace.
 *
 * Returns:
 *	Name of namespace, or NULL if none can be found. Note that this
 *	function does *not* set an error message in the interpreter on failure.
 *
 * ----------------------------------------------------------------------
 */

#define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */

Tcl_Namespace *
TclOOGetDefineContextNamespace(
    Tcl_Interp *interp,		/* In what interpreter should namespace names
				 * actually be resolved. */
    Object *oPtr,		/* The object to get the context for. */
    int forClass)		/* What sort of context are we looking for.
				 * If true, we are going to use this for
				 * [oo::define], otherwise, we are going to
				 * use this for [oo::objdefine]. */
{
    DefineChain define;
    DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
    DefineEntry *entryPtr;
    Tcl_Namespace *nsPtr = NULL;
    int i, flags = (forClass ? DEFINE_FOR_CLASS : 0);

    define.list = staticSpace;
    define.num = 0;
    define.size = DEFINE_CHAIN_STATIC_SIZE;

    /*
     * Add the actual define locations. We have to do this twice to handle
     * class mixins right.
     */

    AddSimpleDefineNamespaces(oPtr, &define, flags | BUILDING_MIXINS);
    AddSimpleDefineNamespaces(oPtr, &define, flags);

    /*
     * Go through the list until we find a namespace whose name we can
     * resolve.
     */

    FOREACH_STRUCT(entryPtr, define) {
	if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName,
		&nsPtr) == TCL_OK) {
	    break;
	}
	Tcl_ResetResult(interp);
    }
    if (define.list != staticSpace) {
	ckfree(define.list);
    }
    return nsPtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * AddSimpleDefineNamespaces --
 *
 *	Adds to the definition chain all the definitions provided by an
 *	object's class and its mixins, taking into account everything they
 *	inherit from.
 *
 * ----------------------------------------------------------------------
 */

static inline void
AddSimpleDefineNamespaces(
    Object *const oPtr,		/* Object to add define chain entries for. */
    DefineChain *const definePtr,
				/* Where to add the define chain entries. */
    int flags)			/* What sort of define chain are we
				 * building. */
{
    Class *mixinPtr;
    int i;

    FOREACH(mixinPtr, oPtr->mixins) {
	AddSimpleClassDefineNamespaces(mixinPtr, definePtr,
		flags | TRAVERSED_MIXIN);
    }

    AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags);
}

/*
 * ----------------------------------------------------------------------
 *
 * AddSimpleClassDefineNamespaces --
 *
 *	Adds to the definition chain all the definitions provided by a class
 *	and its superclasses and its class mixins.
 *
 * ----------------------------------------------------------------------
 */

static void
AddSimpleClassDefineNamespaces(
    Class *classPtr,		/* Class to add the define chain entries for. */
    DefineChain *const definePtr,
				/* Where to add the define chain entries. */
    int flags)			/* What sort of define chain are we
				 * building. */
{
    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.
     */

  tailRecurse:
    FOREACH(superPtr, classPtr->mixins) {
	AddSimpleClassDefineNamespaces(superPtr, definePtr,
		flags | TRAVERSED_MIXIN);
    }

    if (flags & DEFINE_FOR_CLASS) {
	AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs,
		definePtr, flags);
    } else {
	AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs,
		definePtr, flags);
    }

    switch (classPtr->superclasses.num) {
    case 1:
	classPtr = classPtr->superclasses.list[0];
	goto tailRecurse;
    default:
	FOREACH(superPtr, classPtr->superclasses) {
	    AddSimpleClassDefineNamespaces(superPtr, definePtr, flags);
	}
    case 0:
	return;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * AddDefinitionNamespaceToChain --
 *
 *	Adds a single item to the definition chain (if it is meaningful),
 *	reallocating the space for the chain if necessary.
 *
 * ----------------------------------------------------------------------
 */

static inline void
AddDefinitionNamespaceToChain(
    Class *const definerCls,		/* What class defines this entry. */
    Tcl_Obj *const namespaceName,	/* The name for this entry (or NULL, a
				 * no-op). */
    DefineChain *const definePtr,
				/* The define chain to add the method
				 * implementation to. */
    int flags)			/* Used to check if we're mixin-consistent
				 * only. Mixin-consistent means that either
				 * we're looking to add things from a mixin
				 * and we have passed a mixin, or we're not
				 * looking to add things from a mixin and have
				 * not passed a mixin. */
{
    int i;

    /*
     * Return if this entry is blank. This is also where we enforce
     * mixin-consistency.
     */

    if (namespaceName == NULL || !MIXIN_CONSISTENT(flags)) {
	return;
    }

    /*
     * First test whether the method is already in the call chain.
     */

    for (i=0 ; i<definePtr->num ; i++) {
	if (definePtr->list[i].definerCls == definerCls) {
	    /*
	     * Call chain semantics states that methods come as *late* in the
	     * call chain as possible. This is done by copying down the
	     * following methods. Note that this does not change the number of
	     * method invocations in the call chain; it just rearranges them.
	     *
	     * We skip changing anything if the place we found was already at
	     * the end of the list.
	     */

	    if (i < definePtr->num - 1) {
		memmove(&definePtr->list[i], &definePtr->list[i + 1],
			sizeof(DefineEntry) * (definePtr->num - i - 1));
		definePtr->list[i].definerCls = definerCls;
		definePtr->list[i].namespaceName = namespaceName;
	    }
	    return;
	}
    }

    /*
     * Need to really add the define. This is made a bit more complex by the
     * fact that we are using some "static" space initially, and only start
     * realloc-ing if the chain gets long.
     */

    if (definePtr->num == definePtr->size) {
	definePtr->size *= 2;
	if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) {
	    DefineEntry *staticList = definePtr->list;

	    definePtr->list =
		    (DefineEntry *)ckalloc(sizeof(DefineEntry) * definePtr->size);
	    memcpy(definePtr->list, staticList,
		    sizeof(DefineEntry) * definePtr->num);
	} else {
	    definePtr->list = (DefineEntry *)ckrealloc(definePtr->list,
		    sizeof(DefineEntry) * definePtr->size);
	}
    }
    definePtr->list[i].definerCls = definerCls;
    definePtr->list[i].namespaceName = namespaceName;
    definePtr->num++;
}

/*
 * ----------------------------------------------------------------------
 *
 * FindClassProps --
 *
 *	Discover the properties known to a class and its superclasses.
 *	The property names become the keys in the accumulator hash table
 *	(which is used as a set).
 *
 * ----------------------------------------------------------------------
 */

static void
FindClassProps(
    Class *clsPtr,		/* The object to inspect. Must exist. */
    int writable,		/* Whether we're after the readable or writable
				 * property set. */
    Tcl_HashTable *accumulator)	/* Where to gather the names. */
{
    int i, dummy;
    Tcl_Obj *propName;
    Class *mixin, *sup;

  tailRecurse:
    if (writable) {
	FOREACH(propName, clsPtr->properties.writable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    } else {
	FOREACH(propName, clsPtr->properties.readable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    }
    if (clsPtr->thisPtr->flags & ROOT_OBJECT) {
	/*
	 * We do *not* traverse upwards from the root!
	 */
	return;
    }
    FOREACH(mixin, clsPtr->mixins) {
	FindClassProps(mixin, writable, accumulator);
    }
    if (clsPtr->superclasses.num == 1) {
	clsPtr = clsPtr->superclasses.list[0];
	goto tailRecurse;
    }
    FOREACH(sup, clsPtr->superclasses) {
	FindClassProps(sup, writable, accumulator);
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * FindObjectProps --
 *
 *	Discover the properties known to an object and all its classes.
 *	The property names become the keys in the accumulator hash table
 *	(which is used as a set).
 *
 * ----------------------------------------------------------------------
 */

static void
FindObjectProps(
    Object *oPtr,		/* The object to inspect. Must exist. */
    int writable,		/* Whether we're after the readable or writable
				 * property set. */
    Tcl_HashTable *accumulator)	/* Where to gather the names. */
{
    int i, dummy;
    Tcl_Obj *propName;
    Class *mixin;

    if (writable) {
	FOREACH(propName, oPtr->properties.writable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    } else {
	FOREACH(propName, oPtr->properties.readable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    }
    FOREACH(mixin, oPtr->mixins) {
	FindClassProps(mixin, writable, accumulator);
    }
    FindClassProps(oPtr->selfCls, writable, accumulator);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOGetAllClassProperties --
 *
 *	Get the list of all properties known to a class, including to its
 *	superclasses. Manages a cache so this operation is usually cheap.
 *	The order of properties in the resulting list is undefined.
 *
 * ----------------------------------------------------------------------
 */

Tcl_Obj *
TclOOGetAllClassProperties(
    Class *clsPtr,		/* The class to inspect. Must exist. */
    int writable,		/* Whether to get writable properties. If
				 * false, readable properties will be returned
				 * instead. */
    int *allocated)		/* Address of variable to set to true if a
				 * Tcl_Obj was allocated and may be safely
				 * modified by the caller. */
{
    Tcl_HashTable hashTable;
    FOREACH_HASH_DECLS;
    Tcl_Obj *propName, *result;
    void *dummy;

    /*
     * Look in the cache.
     */

    if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) {
	if (writable) {
	    if (clsPtr->properties.allWritableCache) {
		*allocated = 0;
		return clsPtr->properties.allWritableCache;
	    }
	} else {
	    if (clsPtr->properties.allReadableCache) {
		*allocated = 0;
		return clsPtr->properties.allReadableCache;
	    }
	}
    }

    /*
     * Gather the information. Unsorted! (Caller will sort.)
     */

    *allocated = 1;
    Tcl_InitObjHashTable(&hashTable);
    FindClassProps(clsPtr, writable, &hashTable);
    result = Tcl_NewObj();
    FOREACH_HASH(propName, dummy, &hashTable) {
	Tcl_ListObjAppendElement(NULL, result, propName);
    }
    Tcl_DeleteHashTable(&hashTable);

    /*
     * Cache the information. Also purges the cache.
     */

    if (clsPtr->properties.epoch != clsPtr->thisPtr->fPtr->epoch) {
	if (clsPtr->properties.allWritableCache) {
	    Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
	    clsPtr->properties.allWritableCache = NULL;
	}
	if (clsPtr->properties.allReadableCache) {
	    Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
	    clsPtr->properties.allReadableCache = NULL;
	}
    }
    clsPtr->properties.epoch = clsPtr->thisPtr->fPtr->epoch;
    if (writable) {
	clsPtr->properties.allWritableCache = result;
    } else {
	clsPtr->properties.allReadableCache = result;
    }
    Tcl_IncrRefCount(result);
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOGetAllObjectProperties --
 *
 *	Get the list of all properties known to a object, including to its
 *	classes. Manages a cache so this operation is usually cheap.
 *	The order of properties in the resulting list is undefined.
 *
 * ----------------------------------------------------------------------
 */

Tcl_Obj *
TclOOGetAllObjectProperties(
    Object *oPtr,		/* The object to inspect. Must exist. */
    int writable,		/* Whether to get writable properties. If
				 * false, readable properties will be returned
				 * instead. */
    int *allocated)		/* Address of variable to set to true if a
				 * Tcl_Obj was allocated and may be safely
				 * modified by the caller. */
{
    Tcl_HashTable hashTable;
    FOREACH_HASH_DECLS;
    Tcl_Obj *propName, *result;
    void *dummy;

    /*
     * Look in the cache.
     */

    if (oPtr->properties.epoch == oPtr->fPtr->epoch) {
	if (writable) {
	    if (oPtr->properties.allWritableCache) {
		*allocated = 0;
		return oPtr->properties.allWritableCache;
	    }
	} else {
	    if (oPtr->properties.allReadableCache) {
		*allocated = 0;
		return oPtr->properties.allReadableCache;
	    }
	}
    }

    /*
     * Gather the information. Unsorted! (Caller will sort.)
     */

    *allocated = 1;
    Tcl_InitObjHashTable(&hashTable);
    FindObjectProps(oPtr, writable, &hashTable);
    result = Tcl_NewObj();
    FOREACH_HASH(propName, dummy, &hashTable) {
	Tcl_ListObjAppendElement(NULL, result, propName);
    }
    Tcl_DeleteHashTable(&hashTable);

    /*
     * Cache the information.
     */

    if (oPtr->properties.epoch != oPtr->fPtr->epoch) {
	if (oPtr->properties.allWritableCache) {
	    Tcl_DecrRefCount(oPtr->properties.allWritableCache);
	    oPtr->properties.allWritableCache = NULL;
	}
	if (oPtr->properties.allReadableCache) {
	    Tcl_DecrRefCount(oPtr->properties.allReadableCache);
	    oPtr->properties.allReadableCache = NULL;
	}
    }
    oPtr->properties.epoch = oPtr->fPtr->epoch;
    if (writable) {
	oPtr->properties.allWritableCache = result;
    } else {
	oPtr->properties.allReadableCache = result;
    }
    Tcl_IncrRefCount(result);
    return result;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */