diff options
Diffstat (limited to 'generic/tclOOMethod.c')
| -rw-r--r-- | generic/tclOOMethod.c | 266 |
1 files changed, 262 insertions, 4 deletions
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 5371719..dfd2d14 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOOMethod.c,v 1.18 2008/09/01 00:35:42 dkf Exp $ + * RCS: @(#) $Id: tclOOMethod.c,v 1.19 2008/09/23 05:05:54 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -18,6 +18,12 @@ #include "tclOOInt.h" #include "tclCompile.h" +#if 0 +#define DBPRINT(format, ...) (fprintf(stderr, "DEBUG:" format "\n", __VA_ARGS__)) +#else +#define DBPRINT(format, ...) ((void) 0) +#endif + /* * Structure used to help delay computing names of objects or classes for * [info frame] until needed, making invokation faster in the normal case. @@ -46,6 +52,20 @@ typedef struct { } PMFrameData; /* + * Structure used to pass information about variable resolution to the + * on-the-ground resolvers used when working with resolved compiled variables. + */ + +typedef struct { + Tcl_ResolvedVarInfo info; /* "Type" information so that the compiled + * variable can be linked to the namespace + * variable at the right time. */ + Tcl_Obj *variableObj; /* The name of the variable. */ + Tcl_Var cachedObjectVar; /* TODO: When to flush this cache? Can class + * variables be cached? */ +} OOResVarInfo; + +/* * Function declarations for things defined in this file. */ @@ -81,6 +101,13 @@ static int InvokeForwardMethod(ClientData clientData, static void DeleteForwardMethod(ClientData clientData); static int CloneForwardMethod(Tcl_Interp *interp, ClientData clientData, ClientData *newClientData); +static int ProcedureMethodVarResolver(Tcl_Interp *interp, + const char *varName, Tcl_Namespace *contextNs, + int flags, Tcl_Var *varPtr); +static int ProcedureMethodCompiledVarResolver(Tcl_Interp *interp, + const char *varName, int length, + Tcl_Namespace *contextNs, + Tcl_ResolvedVarInfo **rPtrPtr); /* * The types of methods defined by the core OO system. @@ -94,6 +121,15 @@ static const Tcl_MethodType fwdMethodType = { TCL_OO_METHOD_VERSION_CURRENT, "forward", InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod }; + +/* + * Helper macros (derived from things private to tclVar.c) + */ + +#define TclVarTable(contextNs) \ + ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable)) +#define TclVarHashGetValue(hPtr) \ + ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry))) /* * ---------------------------------------------------------------------- @@ -319,6 +355,7 @@ TclOONewProcInstanceMethod( pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; pmPtr->refCount = 1; + method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (method == NULL) { @@ -380,9 +417,8 @@ TclOONewProcMethod( pmPtr->flags = flags & USE_DECLARER_NS; pmPtr->refCount = 1; - method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, - procName, argsObj, bodyObj, &procMethodType, pmPtr, - &pmPtr->procPtr); + method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName, + argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (argsLen == -1) { Tcl_DecrRefCount(argsObj); @@ -866,6 +902,213 @@ PushMethodCallFrame( /* * ---------------------------------------------------------------------- * + * TclOOSetupVariableResolver, etc. -- + * + * Variable resolution engine used to connect declared variables to local + * variables used in methods. The compiled variable resolver is more + * important, but both are needed as it is possible to have a variable + * that is only referred to in ways that aren't compilable and we can't + * force LVT presence. [TIP #320] + * + * ---------------------------------------------------------------------- + */ + +void +TclOOSetupVariableResolver( + Tcl_Namespace *nsPtr) +{ + Tcl_ResolverInfo info; + + Tcl_GetNamespaceResolvers(nsPtr, &info); + if (info.compiledVarResProc == NULL) { + Tcl_SetNamespaceResolvers(nsPtr, NULL, ProcedureMethodVarResolver, + ProcedureMethodCompiledVarResolver); + } +} + +static int +ProcedureMethodVarResolver( + Tcl_Interp *interp, + const char *varName, + Tcl_Namespace *contextNs, + int flags, + Tcl_Var *varPtr) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + CallContext *contextPtr; + Tcl_Obj *variableObj; + Tcl_HashEntry *hPtr; + int i, isNew; + + /* + * Check that the variable is being requested in a context that is also a + * method call; if not (i.e. we're evaluating in the object's namespace or + * in a procedure of that namespace) then we do nothing. + */ + + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + return TCL_CONTINUE; + } + contextPtr = framePtr->clientData; + + /* + * Check if the variable is one we want to resolve at all (i.e. whether it + * is in the list provided by the user). If not, we mustn't do anything + * either. + */ + + if (contextPtr->callPtr->chain[contextPtr->index] + .mPtr->declaringClassPtr != NULL) { + FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] + .mPtr->declaringClassPtr->variables) { + if (!strcmp(Tcl_GetString(variableObj), varName)) { + goto gotMatch; + } + } + } else { + FOREACH(variableObj, contextPtr->oPtr->variables) { + if (!strcmp(Tcl_GetString(variableObj), varName)) { + goto gotMatch; + } + } + } + return TCL_CONTINUE; + + /* + * It is a variable we want to resolve, so resolve it. + */ + + gotMatch: + hPtr = Tcl_CreateHashEntry(TclVarTable(contextNs), (char *) variableObj, + &isNew); + if (isNew) { + TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr)); + } + *varPtr = TclVarHashGetValue(hPtr); + return TCL_OK; +} + +static Tcl_Var +ProcedureMethodCompiledVarConnect( + Tcl_Interp *interp, + Tcl_ResolvedVarInfo *rPtr) +{ + OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr; + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + CallContext *contextPtr; + Tcl_Obj *variableObj; + Tcl_HashEntry *hPtr; + int i, isNew, cacheIt; + const char *varName = Tcl_GetString(infoPtr->variableObj); + + /* + * Check that the variable is being requested in a context that is also a + * method call; if not (i.e. we're evaluating in the object's namespace or + * in a procedure of that namespace) then we do nothing. + */ + + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + return NULL; + } + contextPtr = framePtr->clientData; + + /* + * If we've done the work before (in a comparable context) then reuse that + * rather than performing resolution ourselves. + */ + + if (infoPtr->cachedObjectVar) { + return infoPtr->cachedObjectVar; + } + + /* + * Check if the variable is one we want to resolve at all (i.e. whether it + * is in the list provided by the user). If not, we mustn't do anything + * either. + */ + + if (contextPtr->callPtr->chain[contextPtr->index] + .mPtr->declaringClassPtr != NULL) { + FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] + .mPtr->declaringClassPtr->variables) { + if (!strcmp(Tcl_GetString(variableObj), varName)) { + cacheIt = 0; + goto gotMatch; + } + } + } else { + FOREACH(variableObj, contextPtr->oPtr->variables) { + if (!strcmp(Tcl_GetString(variableObj), varName)) { + cacheIt = 1; + goto gotMatch; + } + } + } + return NULL; + + /* + * It is a variable we want to resolve, so resolve it. + */ + + gotMatch: + hPtr = Tcl_CreateHashEntry(TclVarTable(contextPtr->oPtr->namespacePtr), + (char *) variableObj, &isNew); + if (isNew) { + TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr)); + } + if (cacheIt) { + infoPtr->cachedObjectVar = TclVarHashGetValue(hPtr); + } + return TclVarHashGetValue(hPtr); +} + +static void +ProcedureMethodCompiledVarDelete( + Tcl_ResolvedVarInfo *rPtr) +{ + OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr; + + Tcl_DecrRefCount(infoPtr->variableObj); + ckfree((char *) infoPtr); +} + +static int +ProcedureMethodCompiledVarResolver( + Tcl_Interp *interp, + const char *varName, + int length, + Tcl_Namespace *contextNs, + Tcl_ResolvedVarInfo **rPtrPtr) +{ + OOResVarInfo *infoPtr; + Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length); + + /* + * Do not create resolvers for cases that contain namespace separators or + * which look like array accesses. Both will lead us astray. + */ + + if (strstr(Tcl_GetString(variableObj), "::") != NULL || + Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) { + Tcl_DecrRefCount(variableObj); + return TCL_CONTINUE; + } + + infoPtr = (OOResVarInfo *) ckalloc(sizeof(OOResVarInfo)); + infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect; + infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete; + infoPtr->cachedObjectVar = NULL; + infoPtr->variableObj = variableObj; + Tcl_IncrRefCount(variableObj); + *rPtrPtr = &infoPtr->info; + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * RenderDeclarerName -- * * Returns the name of the entity (object or class) which declared a @@ -1244,6 +1487,21 @@ TclOOGetProcFromMethod( } Tcl_Obj * +TclOOGetMethodBody( + Method *mPtr) +{ + if (mPtr->typePtr == &procMethodType) { + ProcedureMethod *pmPtr = mPtr->clientData; + + if (pmPtr->procPtr->bodyPtr->bytes == NULL) { + (void) Tcl_GetString(pmPtr->procPtr->bodyPtr); + } + return pmPtr->procPtr->bodyPtr; + } + return NULL; +} + +Tcl_Obj * TclOOGetFwdFromMethod( Method *mPtr) { |