Implementation of TIP #320.#320.#320.

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)
 {