riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/generic/tclOOCall.c

1589 lines
44 KiB
C
Raw Normal View History

adding Tcl interface to vpr
2022-06-07 11:15:20 -05:00
/*
* tclOOCall.c --
*
* This file contains the method call chain management code for the
* object-system core.
*
* Copyright (c) 2005-2012 by Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.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. */
};
/*
* 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 MIXIN_CONSISTENT(flags) \
(((flags) & OBJECT_MIXIN) || \
!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))
/*
* 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, const int flags,
Tcl_HashTable *const namesPtr,
Tcl_HashTable *const examinedClassesPtr);
static inline void AddMethodToCallChain(Method *const mPtr,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters,
Class *const filterDecl, int flags);
static inline void AddSimpleChainToCallContext(Object *const oPtr,
Tcl_Obj *const methodNameObj,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags,
Class *const filterDecl);
static void AddSimpleClassChainToCallContext(Class *classPtr,
Tcl_Obj *const methodNameObj,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags,
Class *const filterDecl);
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 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)
{
callPtr->refCount++;
TclGetString(objPtr);
TclFreeIntRep(objPtr);
objPtr->typePtr = &methodNameType;
objPtr->internalRep.twoPtrValue.ptr1 = callPtr;
}
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)
{
CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1;
dstPtr->typePtr = &methodNameType;
dstPtr->internalRep.twoPtrValue.ptr1 = callPtr;
callPtr->refCount++;
}
static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1;
TclOODeleteChain(callPtr);
objPtr->typePtr = NULL;
}
/*
* ----------------------------------------------------------------------
*
* 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(
ClientData 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 = 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(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = data[0];
contextPtr->oPtr->flags |= FILTER_HANDLING;
return result;
}
static int
ResetFilterFlags(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = data[0];
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
return result;
}
static int
FinalizeMethodRefs(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = 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. */
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;
Class *mixinPtr;
Tcl_Obj *namePtr;
Method *mPtr;
int isWantedIn;
void *isWanted;
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) {
int isNew;
if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) {
continue;
}
hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
if (isNew) {
isWantedIn = ((!(flags & PUBLIC_METHOD)
|| mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0);
isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
}
}
}
/*
* Process method names due to private methods on the object's class.
*/
if (flags & PRIVATE_METHOD) {
FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) {
if (mPtr->flags & PRIVATE_METHOD) {
int isNew;
hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
if (isNew) {
isWantedIn = IN_LIST;
if (mPtr->typePtr == NULL) {
isWantedIn |= NO_IMPLEMENTATION;
}
Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
} else if (mPtr->typePtr != NULL) {
isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr));
if (isWantedIn & NO_IMPLEMENTATION) {
isWantedIn &= ~NO_IMPLEMENTATION;
Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
}
}
}
}
}
/*
* 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);
}
Tcl_DeleteHashTable(&examinedClasses);
/*
* See how many (visible) method names there are. If none, we do not (and
* should not) try to sort the list of them.
*/
i = 0;
if (names.numEntries != 0) {
const char **strings;
/*
* We need to build the list of methods to sort. We will be using
* qsort() for this, because it is very unlikely that the list will be
* heavily sorted when it is long enough to matter.
*/
strings = ckalloc(sizeof(char *) * names.numEntries);
FOREACH_HASH(namePtr, isWanted, &names) {
if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
continue;
}
strings[i++] = TclGetString(namePtr);
}
}
/*
* Note that 'i' may well be less than names.numEntries when we are
* dealing with public method names.
*/
if (i > 0) {
if (i > 1) {
qsort((void *) strings, i, sizeof(char *), CmpStr);
}
*stringsPtr = strings;
} else {
ckfree(strings);
}
}
Tcl_DeleteHashTable(&names);
return i;
}
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. */
FOREACH_HASH_DECLS;
int i;
Tcl_Obj *namePtr;
void *isWanted;
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);
/*
* See how many (visible) method names there are. If none, we do not (and
* should not) try to sort the list of them.
*/
i = 0;
if (names.numEntries != 0) {
const char **strings;
/*
* We need to build the list of methods to sort. We will be using
* qsort() for this, because it is very unlikely that the list will be
* heavily sorted when it is long enough to matter.
*/
strings = ckalloc(sizeof(char *) * names.numEntries);
FOREACH_HASH(namePtr, isWanted, &names) {
if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
continue;
}
strings[i++] = TclGetString(namePtr);
}
}
/*
* Note that 'i' may well be less than names.numEntries when we are
* dealing with public method names.
*/
if (i > 0) {
if (i > 1) {
qsort((void *) strings, i, sizeof(char *), CmpStr);
}
*stringsPtr = strings;
} else {
ckfree(strings);
}
}
Tcl_DeleteHashTable(&names);
return i;
}
/*
* Comparator for GetSortedMethodList
*/
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. */
const 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. */
{
/*
* 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;
int i;
FOREACH(mixinPtr, clsPtr->mixins) {
if (mixinPtr != clsPtr) {
AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN,
namesPtr, examinedClassesPtr);
}
}
}
FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
if (isNew) {
int isWanted = (!(flags & PUBLIC_METHOD)
|| (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0;
isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
} else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
&& mPtr->typePtr != NULL) {
int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));
isWanted &= ~NO_IMPLEMENTATION;
Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
}
}
if (clsPtr->superclasses.num != 1) {
break;
}
clsPtr = clsPtr->superclasses.list[0];
}
if (clsPtr->superclasses.num != 0) {
Class *superPtr;
int i;
FOREACH(superPtr, clsPtr->superclasses) {
AddClassMethodNames(superPtr, flags, namesPtr,
examinedClassesPtr);
}
}
}
/*
* ----------------------------------------------------------------------
*
* 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.
*
* ----------------------------------------------------------------------
*/
static inline void
AddSimpleChainToCallContext(
Object *const oPtr, /* Object to add 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;
if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr,
(char *) methodNameObj);
if (hPtr != NULL) {
Method *mPtr = Tcl_GetHashValue(hPtr);
if (flags & PUBLIC_METHOD) {
if (!(mPtr->flags & PUBLIC_METHOD)) {
return;
} else {
flags |= DEFINITE_PUBLIC;
}
} else {
flags |= DEFINITE_PROTECTED;
}
}
}
if (!(flags & SPECIAL)) {
Tcl_HashEntry *hPtr;
Class *mixinPtr;
FOREACH(mixinPtr, oPtr->mixins) {
AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr,
doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
}
if (oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
if (hPtr != NULL) {
AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr,
doneFilters, filterDecl, flags);
}
}
}
AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr,
doneFilters, flags, filterDecl);
}
/*
* ----------------------------------------------------------------------
*
* 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 (!(callPtr->flags & PRIVATE_METHOD)
&& (mPtr->flags & PRIVATE_METHOD)
&& (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 =
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 = 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 strucutre (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. */
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, doFilters;
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 int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
if (cacheInThisObj->typePtr == &methodNameType) {
callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
FreeMethodNameRep(cacheInThisObj);
}
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 = Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
Tcl_SetHashValue(hPtr, NULL);
TclOODeleteChain(callPtr);
}
doFilters = 1;
}
callPtr = 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, oPtr->fPtr->unknownMethodNameObj,
&cb, NULL, BUILDING_MIXINS, NULL);
AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
&cb, NULL, 0, NULL);
callPtr->flags |= OO_UNKNOWN_METHOD;
callPtr->epoch = -1;
if (callPtr->numChain == 0) {
TclOODeleteChain(callPtr);
return NULL;
}
goto returnContext;
}
/*
* Add all defined filters (if any, and if we're going to be processing
* them; they're not processed for constructors, destructors or when we're
* in the middle of processing a filter).
*/
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) {
AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters,
BUILDING_MIXINS, NULL);
AddSimpleChainToCallContext(oPtr, 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.
*/
AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL,
flags|BUILDING_MIXINS, NULL);
AddSimpleChainToCallContext(oPtr, 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, oPtr->fPtr->unknownMethodNameObj,
&cb, NULL, BUILDING_MIXINS, NULL);
AddSimpleChainToCallContext(oPtr, 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) {
if (hPtr == NULL) {
if (oPtr->flags & USE_CLASS_CACHE) {
if (oPtr->selfCls->classChainCache == NULL) {
oPtr->selfCls->classChainCache =
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 = 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 = 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 =
((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
callPtr = Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
callPtr->refCount++;
return callPtr;
}
Tcl_SetHashValue(hPtr, NULL);
TclOODeleteChain(callPtr);
}
} else {
hPtr = NULL;
}
callPtr = ckalloc(sizeof(CallChain));
memset(callPtr, 0, sizeof(CallChain));
callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING);
callPtr->epoch = fPtr->epoch;
callPtr->objectCreationEpoch = fPtr->tsdPtr->nsCount;
callPtr->objectEpoch = clsPtr->thisPtr->epoch;
callPtr->refCount = 1;
callPtr->chain = callPtr->staticChain;
cb.callChainPtr = callPtr;
cb.filterLength = 0;
cb.oPtr = &obj;
/*
* Add all defined filters (if any, and if we're going to be processing
* them; they're not processed for constructors, destructors or when we're
* in the middle of processing a filter).
*/
Tcl_InitObjHashTable(&doneFilters);
AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters,
BUILDING_MIXINS);
AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters, 0);
Tcl_DeleteHashTable(&doneFilters);
count = cb.filterLength = callPtr->numChain;
/*
* Add the actual method implementations.
*/
AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL,
flags|BUILDING_MIXINS, NULL);
AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL);
/*
* Check to see if the method has no implementation. If so, we probably
* need to add in a call to the unknown method. Otherwise, set up the
* cacheing of the method implementation (if relevant).
*/
if (count == callPtr->numChain) {
AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
NULL, BUILDING_MIXINS, NULL);
AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
NULL, 0, NULL);
callPtr->flags |= OO_UNKNOWN_METHOD;
callPtr->epoch = -1;
if (count == callPtr->numChain) {
TclOODeleteChain(callPtr);
return NULL;
}
} else {
if (hPtr == NULL) {
if (clsPtr->classChainCache == NULL) {
clsPtr->classChainCache = ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(clsPtr->classChainCache);
}
hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
(char *) methodNameObj, &i);
}
callPtr->refCount++;
Tcl_SetHashValue(hPtr, callPtr);
StashCallChain(methodNameObj, callPtr);
}
return callPtr;
}
/*
* ----------------------------------------------------------------------
*
* AddClassFiltersToCallContext --
*
* Logic to make extracting all the filters from the class context much
* 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, 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, filterObj, cbPtr,
doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr);
AddSimpleChainToCallContext(oPtr, 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;
}
}
/*
* ----------------------------------------------------------------------
*
* AddSimpleClassChainToCallContext --
*
* Construct a call-chain from a class hierarchy.
*
* ----------------------------------------------------------------------
*/
static void
AddSimpleClassChainToCallContext(
Class *classPtr, /* Class to add the call chain entries for. */
Tcl_Obj *const methodNameObj,
/* Name of method to add the call chain
* entries for. */
struct ChainBuilder *const cbPtr,
/* Where to add the call chain entries. */
Tcl_HashTable *const doneFilters,
/* Where to record what call chain entries
* have been processed. */
int flags, /* What sort of call chain are we building. */
Class *const filterDecl) /* The class that declared the filter. If
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
int i;
Class *superPtr;
/*
* We hard-code the tail-recursive form. It's by far the most common case
* *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) {
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 (hPtr != NULL) {
Method *mPtr = Tcl_GetHashValue(hPtr);
if (!(flags & KNOWN_STATE)) {
if (flags & PUBLIC_METHOD) {
if (mPtr->flags & PUBLIC_METHOD) {
flags |= DEFINITE_PUBLIC;
} else {
return;
}
} 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) {
AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
doneFilters, flags, filterDecl);
}
case 0:
return;
}
}
/*
* ----------------------------------------------------------------------
*
* TclOORenderCallChain --
*
* Create a description of a call chain. Used in [info object call],
* [info class call], and [self call].
*
* ----------------------------------------------------------------------
*/
Tcl_Obj *
TclOORenderCallChain(
Tcl_Interp *interp,
CallChain *callPtr)
{
Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral;
Tcl_Obj *resultObj, *descObjs[4], **objv;
Foundation *fPtr = TclOOGetFoundation(interp);
int i;
/*
* Allocate the literals (potentially) used in our description.
*/
filterLiteral = Tcl_NewStringObj("filter", -1);
Tcl_IncrRefCount(filterLiteral);
methodLiteral = Tcl_NewStringObj("method", -1);
Tcl_IncrRefCount(methodLiteral);
objectLiteral = Tcl_NewStringObj("object", -1);
Tcl_IncrRefCount(objectLiteral);
/*
* Do the actual construction of the descriptions. They consist of a list
* of triples that describe the details of how a method is understood. For
* each triple, the first word is the type of 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 = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
for (i = 0 ; i < callPtr->numChain ; i++) {
struct MInvoke *miPtr = &callPtr->chain[i];
descObjs[0] = miPtr->isFilter
? filterLiteral
: callPtr->flags & OO_UNKNOWN_METHOD
? fPtr->unknownMethodNameObj
: methodLiteral;
descObjs[1] = callPtr->flags & CONSTRUCTOR
? fPtr->constructorName
: callPtr->flags & DESTRUCTOR
? fPtr->destructorName
: miPtr->mPtr->namePtr;
descObjs[2] = miPtr->mPtr->declaringClassPtr
? Tcl_GetObjectName(interp,
(Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr)
: objectLiteral;
descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1);
objv[i] = Tcl_NewListObj(4, descObjs);
}
/*
* Drop the local references to the literals; if they're actually used,
* they'll live on the description itself.
*/
Tcl_DecrRefCount(filterLiteral);
Tcl_DecrRefCount(methodLiteral);
Tcl_DecrRefCount(objectLiteral);
/*
* Finish building the description and return it.
*/
resultObj = Tcl_NewListObj(callPtr->numChain, objv);
TclStackFree(interp, objv);
return resultObj;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/