summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclOO.c22
-rw-r--r--generic/tclOODefineCmds.c96
-rw-r--r--generic/tclOOInfo.c116
-rw-r--r--generic/tclOOInt.h9
-rw-r--r--generic/tclOOMethod.c266
5 files changed, 473 insertions, 36 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c
index b25f070..11a7cbd 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.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: tclOO.c,v 1.16 2008/09/01 00:35:42 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.17 2008/09/23 05:05:48 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -38,6 +38,7 @@ static const struct {
{"self", TclOODefineSelfObjCmd, 0},
{"superclass", TclOODefineSuperclassObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 0},
+ {"variable", TclOODefineVariablesObjCmd, 0},
{NULL, NULL, 0}
}, objdefCmds[] = {
{"class", TclOODefineClassObjCmd, 1},
@@ -49,6 +50,7 @@ static const struct {
{"mixin", TclOODefineMixinObjCmd, 1},
{"renamemethod", TclOODefineRenameMethodObjCmd, 1},
{"unexport", TclOODefineUnexportObjCmd, 1},
+ {"variable", TclOODefineVariablesObjCmd, 1},
{NULL, NULL, 0}
};
@@ -453,6 +455,7 @@ AllocObject(
configNamespace:
TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
+ TclOOSetupVariableResolver(oPtr->namespacePtr);
/*
* Suppress use of compiled versions of the commands in this object's
@@ -761,7 +764,7 @@ ObjectNamespaceDeleted(
FOREACH_HASH_DECLS;
Class *clsPtr = oPtr->classPtr, *mixinPtr;
Method *mPtr;
- Tcl_Obj *filterObj;
+ Tcl_Obj *filterObj, *variableObj;
int i, preserved = !(oPtr->flags & OBJECT_DELETED);
/*
@@ -808,6 +811,13 @@ ObjectNamespaceDeleted(
ckfree((char *) oPtr->methodsPtr);
}
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i) {
+ ckfree((char *) oPtr->variables.list);
+ }
+
if (oPtr->chainCache) {
TclOODeleteChainCache(oPtr->chainCache);
}
@@ -889,6 +899,14 @@ ObjectNamespaceDeleted(
Tcl_DeleteHashTable(&clsPtr->classMethods);
TclOODelMethodRef(clsPtr->constructorPtr);
TclOODelMethodRef(clsPtr->destructorPtr);
+
+ FOREACH(variableObj, clsPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i) {
+ ckfree((char *) clsPtr->variables.list);
+ }
+
DelRef(clsPtr);
}
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 77f9970..fe7e8de 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOODefineCmds.c,v 1.4 2008/05/31 11:42:18 dkf Exp $
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.5 2008/09/23 05:05:54 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -1792,6 +1792,100 @@ TclOODefineUnexportObjCmd(
return TCL_OK;
}
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineVariablesObjCmd --
+ * Implementation of the "variable" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineVariablesObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceVars = (clientData != NULL);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *variableObj;
+ int i;
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceVars && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i=1 ; i<objc ; i++) {
+ const char *varName = Tcl_GetString(objv[i]);
+
+ if (strstr(varName, "::") != NULL) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not contain namespace separators",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_StringMatch(varName, "*(*)")) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not refer to an array element", NULL);
+ return TCL_ERROR;
+ }
+ }
+ for (i=1 ; i<objc ; i++) {
+ Tcl_IncrRefCount(objv[i]);
+ }
+
+ if (!isInstanceVars) {
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != objc-1) {
+ if (objc == 1) {
+ ckfree((char *) oPtr->classPtr->variables.list);
+ } else if (i) {
+ oPtr->classPtr->variables.list = (Tcl_Obj **)
+ ckrealloc((char *) oPtr->classPtr->variables.list,
+ sizeof(Tcl_Obj *) * (objc-1));
+ } else {
+ oPtr->classPtr->variables.list = (Tcl_Obj **)
+ ckalloc(sizeof(Tcl_Obj *) * (objc-1));
+ }
+ }
+ if (objc > 1) {
+ memcpy(oPtr->classPtr->variables.list, objv+1,
+ sizeof(Tcl_Obj *) * (objc-1));
+ }
+ oPtr->classPtr->variables.num = objc-1;
+ } else {
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != objc-1) {
+ if (objc == 1) {
+ ckfree((char *) oPtr->variables.list);
+ } else if (i) {
+ oPtr->variables.list = (Tcl_Obj **)
+ ckrealloc((char *) oPtr->variables.list,
+ sizeof(Tcl_Obj *) * (objc-1));
+ } else {
+ oPtr->variables.list = (Tcl_Obj **)
+ ckalloc(sizeof(Tcl_Obj *) * (objc-1));
+ }
+ }
+ if (objc > 1) {
+ memcpy(oPtr->variables.list, objv+1, sizeof(Tcl_Obj *)*(objc-1));
+ }
+ oPtr->variables.num = objc-1;
+ }
+ return TCL_OK;
+}
+
void
Tcl_ClassSetConstructor(
Tcl_Interp *interp,
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index bc7b4fb..41d90a4 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOInfo.c,v 1.6 2008/08/12 23:19:15 hobbs Exp $
+ * RCS: @(#) $Id: tclOOInfo.c,v 1.7 2008/09/23 05:05:54 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -26,6 +26,7 @@ static Tcl_ObjCmdProc InfoObjectIsACmd;
static Tcl_ObjCmdProc InfoObjectMethodsCmd;
static Tcl_ObjCmdProc InfoObjectMixinsCmd;
static Tcl_ObjCmdProc InfoObjectVarsCmd;
+static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassConstrCmd;
static Tcl_ObjCmdProc InfoClassDefnCmd;
static Tcl_ObjCmdProc InfoClassDestrCmd;
@@ -36,6 +37,7 @@ static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
+static Tcl_ObjCmdProc InfoClassVariablesCmd;
struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
@@ -51,6 +53,7 @@ static const struct NameProcMap infoObjectCmds[] = {
{"::oo::InfoObject::isa", InfoObjectIsACmd},
{"::oo::InfoObject::methods", InfoObjectMethodsCmd},
{"::oo::InfoObject::mixins", InfoObjectMixinsCmd},
+ {"::oo::InfoObject::variables", InfoObjectVariablesCmd},
{"::oo::InfoObject::vars", InfoObjectVarsCmd},
{NULL, NULL}
};
@@ -70,6 +73,7 @@ static const struct NameProcMap infoClassCmds[] = {
{"::oo::InfoClass::mixins", InfoClassMixinsCmd},
{"::oo::InfoClass::subclasses", InfoClassSubsCmd},
{"::oo::InfoClass::superclasses", InfoClassSupersCmd},
+ {"::oo::InfoClass::variables", InfoClassVariablesCmd},
{NULL, NULL}
};
@@ -268,18 +272,8 @@ InfoObjectDefnCmd(
}
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
-
- /*
- * This is copied from the [info body] implementation. See the comments
- * there for why this copy has to be done here.
- */
-
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
+ TclOOGetMethodBody(Tcl_GetHashValue(hPtr)));
return TCL_OK;
}
@@ -617,6 +611,42 @@ InfoObjectMixinsCmd(
/*
* ----------------------------------------------------------------------
*
+ * InfoObjectVariablesCmd --
+ *
+ * Implements [info object variables $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectVariablesCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Tcl_Obj *variableObj;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), variableObj);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* InfoObjectVarsCmd --
*
* Implements [info object vars $objName ?$pattern?]
@@ -739,12 +769,8 @@ InfoClassConstrCmd(
}
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
+ TclOOGetMethodBody(clsPtr->constructorPtr));
return TCL_OK;
}
@@ -816,12 +842,8 @@ InfoClassDefnCmd(
}
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
+ TclOOGetMethodBody(Tcl_GetHashValue(hPtr)));
return TCL_OK;
}
@@ -871,12 +893,7 @@ InfoClassDestrCmd(
return TCL_ERROR;
}
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
+ Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr));
return TCL_OK;
}
@@ -1263,6 +1280,49 @@ InfoClassSupersCmd(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassVariablesCmd --
+ *
+ * Implements [info class variables $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassVariablesCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Class *clsPtr;
+ Tcl_Obj *variableObj;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ FOREACH(variableObj, clsPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), variableObj);
+ }
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 056091d..dbd7df2 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOInt.h,v 1.7 2008/08/23 18:53:11 msofer Exp $
+ * RCS: @(#) $Id: tclOOInt.h,v 1.8 2008/09/23 05:05:54 dkf Exp $
*/
#include <tclInt.h>
@@ -175,6 +175,7 @@ typedef struct Object {
Tcl_ObjectMapMethodNameProc mapMethodNameProc;
/* Function to allow remapping of method
* names. For itcl-ng. */
+ LIST_STATIC(Tcl_Obj *) variables;
} Object;
#define OBJECT_DELETED 1 /* Flag to say that an object has been
@@ -248,6 +249,7 @@ typedef struct Class {
* object doesn't override with its own mixins
* (and filters and method implementations for
* when getting method chains). */
+ LIST_STATIC(Tcl_Obj *) variables;
} Class;
/*
@@ -422,6 +424,9 @@ MODULE_SCOPE int TclOODefineSuperclassObjCmd(ClientData clientData,
MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineVariablesObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
@@ -492,6 +497,7 @@ MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr);
MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr);
+MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr);
MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr,
int flags, const char ***stringsPtr);
MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags,
@@ -514,6 +520,7 @@ MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr,
Class *superPtr);
MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr,
CallContext *contextPtr);
+MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
/*
* Include all the private API, generated from tclOO.decls.
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)
{
generated by cgit v0.12 at 2024-07-01 08:31:21 (GMT)