diff options
Diffstat (limited to 'generic/tclOOCall.c')
| -rw-r--r-- | generic/tclOOCall.c | 2368 |
1 files changed, 0 insertions, 2368 deletions
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c deleted file mode 100644 index 85ca995..0000000 --- a/generic/tclOOCall.c +++ /dev/null @@ -1,2368 +0,0 @@ -/* - * 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. - */ - - return (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); - TclNewObj(result); - 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); - TclNewObj(result); - 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: - */ |