summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2024-08-06 09:16:40 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2024-08-06 09:16:40 (GMT)
commit4f6b2bf1de9936257d1ab9e842b13d3359ad8a28 (patch)
tree1a9c76f69c7df0cf206a20415812023f86e5ed24
parent43af80512d30d82b5e3cfb384c322feaa13b0568 (diff)
parent85a7228bbfd49a9b78fbb4925362673f33db39ab (diff)
downloadtcl-4f6b2bf1de9936257d1ab9e842b13d3359ad8a28.zip
tcl-4f6b2bf1de9936257d1ab9e842b13d3359ad8a28.tar.gz
tcl-4f6b2bf1de9936257d1ab9e842b13d3359ad8a28.tar.bz2
Implementation of almost all of oo::configurable in C, for better performance.
Diffstat
-rw-r--r--generic/tclOO.c357
-rw-r--r--generic/tclOO.h29
-rw-r--r--generic/tclOOBasic.c172
-rw-r--r--generic/tclOOCall.c434
-rw-r--r--generic/tclOODefineCmds.c870
-rw-r--r--generic/tclOOInfo.c386
-rw-r--r--generic/tclOOInt.h290
-rw-r--r--generic/tclOOMethod.c307
-rw-r--r--generic/tclOOProp.c1354
-rw-r--r--generic/tclOOScript.h204
-rw-r--r--tests/compile.test17
-rw-r--r--tests/oo.test70
-rw-r--r--tools/tclOOScript.tcl273
-rw-r--r--unix/Makefile.in6
-rw-r--r--win/Makefile.in21
-rw-r--r--win/makefile.vc1
16 files changed, 2692 insertions, 2099 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 1376d4e..b314df7 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -17,7 +17,7 @@
#include "tclOOInt.h"
/*
- * Commands in oo::define.
+ * Commands in oo::define and oo::objdefine.
*/
static const struct {
@@ -67,8 +67,6 @@ static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
Method **newMPtrPtr);
static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
Method *mPtr, Tcl_Obj *namePtr);
-static void DeletedDefineNamespace(void *clientData);
-static void DeletedObjdefNamespace(void *clientData);
static void DeletedHelpersNamespace(void *clientData);
static Tcl_NRPostProc FinalizeAlloc;
static Tcl_NRPostProc FinalizeNext;
@@ -120,6 +118,9 @@ static const DeclaredClassMethod objMethods[] = {
DCM("new", 1, TclOO_Class_New),
DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
{NULL, 0, {0, NULL, NULL, NULL, NULL}}
+}, cfgMethods[] = {
+ DCM("configure", 1, TclOO_Configurable_Configure),
+ {NULL, 0, {0, NULL, NULL, NULL, NULL}}
};
/*
@@ -288,6 +289,37 @@ TclOOGetFoundation(
/*
* ----------------------------------------------------------------------
*
+ * CreateCmdInNS --
+ *
+ * Create a command in a namespace. Supports setting various
+ * implementation functions, but not a deletion callback or a clientData;
+ * it's suitable for use-cases in this file, no more.
+ *
+ * ----------------------------------------------------------------------
+ */
+static inline void
+CreateCmdInNS(
+ Tcl_Interp *interp,
+ Tcl_Namespace *namespacePtr,
+ const char *name,
+ Tcl_ObjCmdProc *cmdProc,
+ Tcl_ObjCmdProc *nreProc,
+ CompileProc *compileProc)
+{
+ Command *cmdPtr;
+
+ if (cmdProc == NULL && nreProc == NULL) {
+ Tcl_Panic("must supply at least one implementation function");
+ }
+ cmdPtr = (Command *) TclCreateObjCommandInNs(interp, name,
+ namespacePtr, cmdProc, NULL, NULL);
+ cmdPtr->nreProc = nreProc;
+ cmdPtr->compileProc = compileProc;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* InitFoundation --
*
* Set up the core of the OO core class system. This is a structure
@@ -302,12 +334,11 @@ InitFoundation(
Tcl_Interp *interp)
{
static Tcl_ThreadDataKey tsdKey;
- ThreadLocalData *tsdPtr =
- (ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
- Foundation *fPtr = (Foundation *)Tcl_Alloc(sizeof(Foundation));
+ ThreadLocalData *tsdPtr = (ThreadLocalData *)
+ Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
+ Foundation *fPtr = (Foundation *) Tcl_Alloc(sizeof(Foundation));
+ Tcl_Namespace *define, *objdef;
Tcl_Obj *namePtr;
- Tcl_DString buffer;
- Command *cmdPtr;
size_t i;
/*
@@ -321,49 +352,45 @@ InitFoundation(
fPtr->interp = interp;
fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL);
Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
- fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
- DeletedDefineNamespace);
- fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
- DeletedObjdefNamespace);
+ define = Tcl_CreateNamespace(interp, "::oo::define", fPtr, NULL);
+ objdef = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr, NULL);
fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
DeletedHelpersNamespace);
Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL);
fPtr->epoch = 1;
fPtr->tsdPtr = tsdPtr;
+
TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
+ TclNewLiteralStringObj(fPtr->myName, "my");
Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
Tcl_IncrRefCount(fPtr->constructorName);
Tcl_IncrRefCount(fPtr->destructorName);
Tcl_IncrRefCount(fPtr->clonedName);
Tcl_IncrRefCount(fPtr->defineName);
- Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
+ Tcl_IncrRefCount(fPtr->myName);
+
+ TclCreateObjCommandInNs(interp, "UnknownDefinition", fPtr->ooNs,
TclOOUnknownDefinition, NULL, NULL);
TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
- Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
- Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
+ Tcl_SetNamespaceUnknownHandler(interp, define, namePtr);
+ Tcl_SetNamespaceUnknownHandler(interp, objdef, namePtr);
+ Tcl_BounceRefCount(namePtr);
/*
* Create the subcommands in the oo::define and oo::objdefine spaces.
*/
- Tcl_DStringInit(&buffer);
for (i = 0 ; defineCmds[i].name ; i++) {
- TclDStringAppendLiteral(&buffer, "::oo::define::");
- Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
- Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+ TclCreateObjCommandInNs(interp, defineCmds[i].name, define,
defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
- Tcl_DStringFree(&buffer);
}
for (i = 0 ; objdefCmds[i].name ; i++) {
- TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
- Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
- Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+ TclCreateObjCommandInNs(interp, objdefCmds[i].name, objdef,
objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
- Tcl_DStringFree(&buffer);
}
Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
@@ -379,10 +406,10 @@ InitFoundation(
*/
for (i = 0 ; objMethods[i].name ; i++) {
- TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
+ TclOONewBasicMethod(fPtr->objectCls, &objMethods[i]);
}
for (i = 0 ; clsMethods[i].name ; i++) {
- TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
+ TclOONewBasicMethod(fPtr->classCls, &clsMethods[i]);
}
/*
@@ -394,7 +421,8 @@ InitFoundation(
TclNewLiteralStringObj(namePtr, "new");
TclNewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
- fPtr->classCls->constructorPtr = (Method *) TclNewMethod(interp,
+ Tcl_BounceRefCount(namePtr);
+ fPtr->classCls->constructorPtr = (Method *) TclNewMethod(
(Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
/*
@@ -402,20 +430,17 @@ InitFoundation(
* ensemble.
*/
- cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
- NULL, TclOONextObjCmd, NULL, NULL);
- cmdPtr->compileProc = TclCompileObjectNextCmd;
- cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
- NULL, TclOONextToObjCmd, NULL, NULL);
- cmdPtr->compileProc = TclCompileObjectNextToCmd;
- cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
- TclOOSelfObjCmd, NULL, NULL);
- cmdPtr->compileProc = TclCompileObjectSelfCmd;
- Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
- NULL);
- Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
- NULL);
- Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
+ CreateCmdInNS(interp, fPtr->helpersNs, "next",
+ NULL, TclOONextObjCmd, TclCompileObjectNextCmd);
+ CreateCmdInNS(interp, fPtr->helpersNs, "nextto",
+ NULL, TclOONextToObjCmd, TclCompileObjectNextToCmd);
+ CreateCmdInNS(interp, fPtr->helpersNs, "self",
+ TclOOSelfObjCmd, NULL, TclCompileObjectSelfCmd);
+
+ CreateCmdInNS(interp, fPtr->ooNs, "define", TclOODefineObjCmd, NULL, NULL);
+ CreateCmdInNS(interp, fPtr->ooNs, "objdefine", TclOOObjDefObjCmd, NULL, NULL);
+ CreateCmdInNS(interp, fPtr->ooNs, "copy", TclOOCopyObjectCmd, NULL, NULL);
+
TclOOInitInfo(interp);
/*
@@ -427,6 +452,28 @@ InitFoundation(
}
/*
+ * Make the configurable class and install its standard defined method.
+ */
+
+ Tcl_Object cfgCls = Tcl_NewObjectInstance(interp,
+ (Tcl_Class) fPtr->classCls,
+ "::oo::configuresupport::configurable", NULL, -1, NULL, 0);
+ for (i = 0 ; cfgMethods[i].name ; i++) {
+ TclOONewBasicMethod(((Object *) cfgCls)->classPtr, &cfgMethods[i]);
+ }
+
+ /*
+ * Don't have handles to these namespaces, so use Tcl_CreateObjCommand.
+ */
+
+ Tcl_CreateObjCommand(interp,
+ "::oo::configuresupport::configurableobject::property",
+ TclOODefinePropertyCmd, (void *) 1, NULL);
+ Tcl_CreateObjCommand(interp,
+ "::oo::configuresupport::configurableclass::property",
+ TclOODefinePropertyCmd, (void *) 0, NULL);
+
+ /*
* Evaluate the remaining definitions, which are a compiled-in Tcl script.
*/
@@ -457,11 +504,11 @@ InitClassSystemRoots(
fPtr->objectCls = &fakeCls;
/* referenced in TclOOAllocClass to increment the refCount. */
fakeCls.thisPtr = &fakeObject;
- fakeObject.refCount = 0; /* Do not increment an uninitialized value. */
+ fakeObject.refCount = 0; // Do not increment an uninitialized value.
fPtr->objectCls = TclOOAllocClass(interp,
- AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
- /* Corresponding TclOODecrRefCount in KillFoudation */
+ AllocObject(interp, "object", (Namespace *) fPtr->ooNs, NULL));
+ // Corresponding TclOODecrRefCount in KillFoundation
AddRef(fPtr->objectCls->thisPtr);
/*
@@ -485,8 +532,8 @@ InitClassSystemRoots(
Tcl_IncrRefCount(defNsName);
fPtr->classCls = TclOOAllocClass(interp,
- AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
- /* Corresponding TclOODecrRefCount in KillFoudation */
+ AllocObject(interp, "class", (Namespace *) fPtr->ooNs, NULL));
+ // Corresponding TclOODecrRefCount in KillFoundation
AddRef(fPtr->classCls->thisPtr);
/*
@@ -527,37 +574,19 @@ InitClassSystemRoots(
/*
* ----------------------------------------------------------------------
*
- * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace --
+ * DeletedHelpersNamespace --
*
- * Simple helpers used to clear fields of the foundation when they no
+ * Simple helper used to clear fields of the foundation when they no
* longer hold useful information.
*
* ----------------------------------------------------------------------
*/
static void
-DeletedDefineNamespace(
- void *clientData)
-{
- Foundation *fPtr = (Foundation *)clientData;
-
- fPtr->defineNs = NULL;
-}
-
-static void
-DeletedObjdefNamespace(
- void *clientData)
-{
- Foundation *fPtr = (Foundation *)clientData;
-
- fPtr->objdefNs = NULL;
-}
-
-static void
DeletedHelpersNamespace(
void *clientData)
{
- Foundation *fPtr = (Foundation *)clientData;
+ Foundation *fPtr = (Foundation *) clientData;
fPtr->helpersNs = NULL;
}
@@ -576,8 +605,8 @@ DeletedHelpersNamespace(
static void
KillFoundation(
TCL_UNUSED(void *),
- Tcl_Interp *interp) /* The interpreter containing the OO system
- * foundation. */
+ Tcl_Interp *interp) /* The interpreter containing the OO system
+ * foundation. */
{
Foundation *fPtr = GetFoundation(interp);
@@ -586,10 +615,17 @@ KillFoundation(
TclDecrRefCount(fPtr->destructorName);
TclDecrRefCount(fPtr->clonedName);
TclDecrRefCount(fPtr->defineName);
+ TclDecrRefCount(fPtr->myName);
TclOODecrRefCount(fPtr->objectCls->thisPtr);
TclOODecrRefCount(fPtr->classCls->thisPtr);
Tcl_Free(fPtr);
+
+ /*
+ * Don't leave the interpreter field pointing to freed data.
+ */
+
+ ((Interp *) interp)->objectFoundation = NULL;
}
/*
@@ -629,7 +665,7 @@ AllocObject(
CommandTrace *tracePtr;
size_t creationEpoch;
- oPtr = (Object *)Tcl_Alloc(sizeof(Object));
+ oPtr = (Object *) Tcl_Alloc(sizeof(Object));
memset(oPtr, 0, sizeof(Object));
/*
@@ -656,7 +692,8 @@ AllocObject(
while (1) {
char objName[10 + TCL_INTEGER_SPACE];
- snprintf(objName, sizeof(objName), "::oo::Obj%" TCL_Z_MODIFIER "u", ++fPtr->tsdPtr->nsCount);
+ snprintf(objName, sizeof(objName), "::oo::Obj%" TCL_Z_MODIFIER "u",
+ ++fPtr->tsdPtr->nsCount);
oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL);
if (oPtr->namespacePtr != NULL) {
creationEpoch = fPtr->tsdPtr->nsCount;
@@ -725,13 +762,13 @@ AllocObject(
if (!nameStr) {
nameStr = oPtr->namespacePtr->name;
- nsPtr = (Namespace *)oPtr->namespacePtr;
+ nsPtr = (Namespace *) oPtr->namespacePtr;
if (nsPtr->parentPtr != NULL) {
nsPtr = nsPtr->parentPtr;
}
}
oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
- (Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL);
+ (Tcl_Namespace *) nsPtr, TclOOPublicObjectCmd, oPtr, NULL);
/*
* Add the NRE command and trace directly. While this breaks a number of
@@ -740,7 +777,8 @@ AllocObject(
cmdPtr = (Command *) oPtr->command;
cmdPtr->nreProc = PublicNRObjectCmd;
- cmdPtr->tracePtr = tracePtr = (CommandTrace *)Tcl_Alloc(sizeof(CommandTrace));
+ cmdPtr->tracePtr = tracePtr = (CommandTrace *)
+ Tcl_Alloc(sizeof(CommandTrace));
tracePtr->traceProc = ObjectRenamedTrace;
tracePtr->clientData = oPtr;
tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
@@ -791,10 +829,10 @@ SquelchCachedName(
static void
MyDeleted(
- void *clientData) /* Reference to the object whose [my] has been
+ void *clientData) /* Reference to the object whose [my] has been
* squelched. */
{
- Object *oPtr = (Object *)clientData;
+ Object *oPtr = (Object *) clientData;
oPtr->myCommand = NULL;
}
@@ -803,7 +841,7 @@ static void
MyClassDeleted(
void *clientData)
{
- Object *oPtr = (Object *)clientData;
+ Object *oPtr = (Object *) clientData;
oPtr->myclassCommand = NULL;
}
@@ -822,13 +860,13 @@ MyClassDeleted(
static void
ObjectRenamedTrace(
- void *clientData, /* The object being deleted. */
+ void *clientData, /* The object being deleted. */
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(const char *) /*oldName*/,
TCL_UNUSED(const char *) /*newName*/,
int flags) /* Why was the object deleted? */
{
- Object *oPtr = (Object *)clientData;
+ Object *oPtr = (Object *) clientData;
/*
* If this is a rename and not a delete of the object, we just flush the
@@ -966,7 +1004,7 @@ TclOOReleaseClassContents(
Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
- Tcl_Obj *variableObj, *propertyObj;
+ Tcl_Obj *variableObj;
PrivateVariableMapping *privateVariable;
/*
@@ -1023,24 +1061,7 @@ TclOOReleaseClassContents(
* Squelch the property lists.
*/
- if (clsPtr->properties.allReadableCache) {
- Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
- }
- if (clsPtr->properties.allWritableCache) {
- Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
- }
- if (clsPtr->properties.readable.num) {
- FOREACH(propertyObj, clsPtr->properties.readable) {
- Tcl_DecrRefCount(propertyObj);
- }
- Tcl_Free(clsPtr->properties.readable.list);
- }
- if (clsPtr->properties.writable.num) {
- FOREACH(propertyObj, clsPtr->properties.writable) {
- Tcl_DecrRefCount(propertyObj);
- }
- Tcl_Free(clsPtr->properties.writable.list);
- }
+ TclOOReleasePropertyStorage(&clsPtr->properties);
/*
* Squelch our filter list.
@@ -1135,15 +1156,15 @@ TclOOReleaseClassContents(
static void
ObjectNamespaceDeleted(
- void *clientData) /* Pointer to the class whose namespace is
+ void *clientData) /* Pointer to the class whose namespace is
* being deleted. */
{
- Object *oPtr = (Object *)clientData;
+ Object *oPtr = (Object *) clientData;
Foundation *fPtr = oPtr->fPtr;
FOREACH_HASH_DECLS;
Class *mixinPtr;
Method *mPtr;
- Tcl_Obj *filterObj, *variableObj, *propertyObj;
+ Tcl_Obj *filterObj, *variableObj;
PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = oPtr->fPtr->interp;
Tcl_Size i;
@@ -1220,14 +1241,14 @@ ObjectNamespaceDeleted(
* as well.
*/
- Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
}
if (oPtr->myclassCommand) {
- Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand);
+ Tcl_DeleteCommandFromToken(interp, oPtr->myclassCommand);
}
if (oPtr->myCommand) {
- Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
+ Tcl_DeleteCommandFromToken(interp, oPtr->myCommand);
}
/*
@@ -1235,7 +1256,7 @@ ObjectNamespaceDeleted(
* methods on the object.
*/
- /* TODO: Should this be protected with a !IsRoot() condition? */
+ // TODO: Should this be protected with a !IsRoot() condition?
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
if (oPtr->mixins.num > 0) {
@@ -1300,24 +1321,7 @@ ObjectNamespaceDeleted(
* Squelch the property lists.
*/
- if (oPtr->properties.allReadableCache) {
- Tcl_DecrRefCount(oPtr->properties.allReadableCache);
- }
- if (oPtr->properties.allWritableCache) {
- Tcl_DecrRefCount(oPtr->properties.allWritableCache);
- }
- if (oPtr->properties.readable.num) {
- FOREACH(propertyObj, oPtr->properties.readable) {
- Tcl_DecrRefCount(propertyObj);
- }
- Tcl_Free(oPtr->properties.readable.list);
- }
- if (oPtr->properties.writable.num) {
- FOREACH(propertyObj, oPtr->properties.writable) {
- Tcl_DecrRefCount(propertyObj);
- }
- Tcl_Free(oPtr->properties.writable.list);
- }
+ TclOOReleasePropertyStorage(&oPtr->properties);
/*
* Because an object can be a class that is an instance of itself, the
@@ -1344,7 +1348,7 @@ ObjectNamespaceDeleted(
* Delete the object structure itself.
*/
- TclNsDecrRefCount((Namespace *)oPtr->namespacePtr);
+ TclNsDecrRefCount((Namespace *) oPtr->namespacePtr);
oPtr->namespacePtr = NULL;
TclOODecrRefCount(oPtr->selfCls->thisPtr);
oPtr->selfCls = NULL;
@@ -1449,10 +1453,12 @@ TclOOAddToInstances(
if (clsPtr->instances.num >= clsPtr->instances.size) {
clsPtr->instances.size += ALLOC_CHUNK;
if (clsPtr->instances.size == ALLOC_CHUNK) {
- clsPtr->instances.list = (Object **)Tcl_Alloc(sizeof(Object *) * ALLOC_CHUNK);
+ clsPtr->instances.list = (Object **)
+ Tcl_Alloc(sizeof(Object *) * ALLOC_CHUNK);
} else {
- clsPtr->instances.list = (Object **)Tcl_Realloc(clsPtr->instances.list,
- sizeof(Object *) * clsPtr->instances.size);
+ clsPtr->instances.list = (Object **)
+ Tcl_Realloc(clsPtr->instances.list,
+ sizeof(Object *) * clsPtr->instances.size);
}
}
clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
@@ -1550,10 +1556,12 @@ TclOOAddToSubclasses(
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
- superPtr->subclasses.list = (Class **)Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK);
+ superPtr->subclasses.list = (Class **)
+ Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
- superPtr->subclasses.list = (Class **)Tcl_Realloc(superPtr->subclasses.list,
- sizeof(Class *) * superPtr->subclasses.size);
+ superPtr->subclasses.list = (Class **)
+ Tcl_Realloc(superPtr->subclasses.list,
+ sizeof(Class *) * superPtr->subclasses.size);
}
}
superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
@@ -1616,10 +1624,12 @@ TclOOAddToMixinSubs(
if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
superPtr->mixinSubs.size += ALLOC_CHUNK;
if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
- superPtr->mixinSubs.list = (Class **)Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK);
+ superPtr->mixinSubs.list = (Class **)
+ Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
- superPtr->mixinSubs.list = (Class **)Tcl_Realloc(superPtr->mixinSubs.list,
- sizeof(Class *) * superPtr->mixinSubs.size);
+ superPtr->mixinSubs.list = (Class **)
+ Tcl_Realloc(superPtr->mixinSubs.list,
+ sizeof(Class *) * superPtr->mixinSubs.size);
}
}
superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
@@ -1664,7 +1674,7 @@ TclOOAllocClass(
* representation. */
{
Foundation *fPtr = GetFoundation(interp);
- Class *clsPtr = (Class *)Tcl_Alloc(sizeof(Class));
+ Class *clsPtr = (Class *) Tcl_Alloc(sizeof(Class));
memset(clsPtr, 0, sizeof(Class));
clsPtr->thisPtr = useThisObj;
@@ -1681,7 +1691,7 @@ TclOOAllocClass(
*/
clsPtr->superclasses.num = 1;
- clsPtr->superclasses.list = (Class **)Tcl_Alloc(sizeof(Class *));
+ clsPtr->superclasses.list = (Class **) Tcl_Alloc(sizeof(Class *));
clsPtr->superclasses.list[0] = fPtr->objectCls;
AddRef(fPtr->objectCls->thisPtr);
@@ -1718,10 +1728,10 @@ Tcl_NewObjectInstance(
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
- Tcl_Size objc, /* Number of arguments. Negative value means
+ Tcl_Size objc, /* Number of arguments. Negative value means
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
- Tcl_Size skip) /* Number of arguments to _not_ pass to the
+ Tcl_Size skip) /* Number of arguments to _not_ pass to the
* constructor. */
{
Class *classPtr = (Class *) cls;
@@ -1786,10 +1796,10 @@ TclNRNewObjectInstance(
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
- Tcl_Size objc, /* Number of arguments. Negative value means
+ Tcl_Size objc, /* Number of arguments. Negative value means
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
- Tcl_Size skip, /* Number of arguments to _not_ pass to the
+ Tcl_Size skip, /* Number of arguments to _not_ pass to the
* constructor. */
Tcl_Object *objectPtr) /* Place to write the object reference upon
* successful allocation. */
@@ -1909,10 +1919,10 @@ FinalizeAlloc(
Tcl_Interp *interp,
int result)
{
- CallContext *contextPtr = (CallContext *)data[0];
- Object *oPtr = (Object *)data[1];
- Tcl_InterpState state = (Tcl_InterpState)data[2];
- Tcl_Object *objectPtr = (Tcl_Object *)data[3];
+ CallContext *contextPtr = (CallContext *) data[0];
+ Object *oPtr = (Object *) data[1];
+ Tcl_InterpState state = (Tcl_InterpState) data[2];
+ Tcl_Object *objectPtr = (Tcl_Object *) data[3];
/*
* Ensure an error if the object was deleted in the constructor. Don't
@@ -2133,11 +2143,12 @@ Tcl_CopyObjectInstance(
TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
- cls2Ptr->superclasses.list = (Class **)Tcl_Realloc(cls2Ptr->superclasses.list,
- sizeof(Class *) * clsPtr->superclasses.num);
+ cls2Ptr->superclasses.list = (Class **)
+ Tcl_Realloc(cls2Ptr->superclasses.list,
+ sizeof(Class *) * clsPtr->superclasses.num);
} else {
- cls2Ptr->superclasses.list =
- (Class **)Tcl_Alloc(sizeof(Class *) * clsPtr->superclasses.num);
+ cls2Ptr->superclasses.list = (Class **)
+ Tcl_Alloc(sizeof(Class *) * clsPtr->superclasses.num);
}
memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
@@ -2331,7 +2342,7 @@ CloneClassMethod(
Method *m2Ptr;
if (mPtr->typePtr == NULL) {
- m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod((Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
void *newClientData;
@@ -2340,11 +2351,11 @@ CloneClassMethod(
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
- m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod((Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
newClientData);
} else {
- m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod((Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
mPtr->clientData);
}
@@ -2431,7 +2442,8 @@ Tcl_ClassSetMetadata(
if (metadata == NULL) {
return;
}
- clsPtr->metadataPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
+ clsPtr->metadataPtr = (Tcl_HashTable *)
+ Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
@@ -2511,7 +2523,7 @@ Tcl_ObjectSetMetadata(
if (metadata == NULL) {
return;
}
- oPtr->metadataPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
+ oPtr->metadataPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
@@ -2560,7 +2572,7 @@ TclOOPublicObjectCmd(
int objc,
Tcl_Obj *const *objv)
{
- return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv);
+ return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData, objc, objv);
}
static int
@@ -2570,8 +2582,8 @@ PublicNRObjectCmd(
int objc,
Tcl_Obj *const *objv)
{
- return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, PUBLIC_METHOD,
- NULL);
+ return TclOOObjectCmdCore((Object *) clientData, interp, objc, objv,
+ PUBLIC_METHOD, NULL);
}
int
@@ -2581,7 +2593,7 @@ TclOOPrivateObjectCmd(
int objc,
Tcl_Obj *const *objv)
{
- return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv);
+ return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd, clientData, objc, objv);
}
static int
@@ -2591,7 +2603,7 @@ PrivateNRObjectCmd(
int objc,
Tcl_Obj *const *objv)
{
- return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, 0, NULL);
+ return TclOOObjectCmdCore((Object *) clientData, interp, objc, objv, 0, NULL);
}
int
@@ -2607,7 +2619,7 @@ TclOOInvokeObject(
* (PRIVATE_METHOD), or a *really* private
* context (any other value; conventionally
* 0). */
- Tcl_Size objc, /* Number of arguments. */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Array of argument objects. It is assumed
* that the name of the method to invoke will
* be at index 1. */
@@ -2652,7 +2664,7 @@ MyClassNRObjCmd(
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *)clientData;
+ Object *oPtr = (Object *) clientData;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?");
@@ -2678,7 +2690,7 @@ int
TclOOObjectCmdCore(
Object *oPtr, /* The object being invoked. */
Tcl_Interp *interp, /* The interpreter containing the object. */
- Tcl_Size objc, /* How many arguments are being passed in. */
+ Tcl_Size objc, /* How many arguments are being passed in. */
Tcl_Obj *const *objv, /* The array of arguments. */
int flags, /* Whether this is an invocation through the
* public or the private command interface. */
@@ -2711,7 +2723,7 @@ TclOOObjectCmdCore(
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
- CallContext *callerContextPtr = (CallContext *)framePtr->clientData;
+ CallContext *callerContextPtr = (CallContext *) framePtr->clientData;
Method *callerMethodPtr =
callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr;
@@ -2788,8 +2800,7 @@ TclOOObjectCmdCore(
if (startCls != NULL) {
for (; contextPtr->index < contextPtr->callPtr->numChain;
contextPtr->index++) {
- struct MInvoke *miPtr =
- &contextPtr->callPtr->chain[contextPtr->index];
+ MInvoke *miPtr = &contextPtr->callPtr->chain[contextPtr->index];
if (miPtr->isFilter) {
continue;
@@ -2828,7 +2839,7 @@ FinalizeObjectCall(
* structure.
*/
- TclOODeleteContext((CallContext *)data[0]);
+ TclOODeleteContext((CallContext *) data[0]);
return result;
}
@@ -2984,7 +2995,7 @@ FinalizeNext(
TCL_UNUSED(Tcl_Interp *),
int result)
{
- CallContext *contextPtr = (CallContext *)data[0];
+ CallContext *contextPtr = (CallContext *) data[0];
/*
* Restore the call chain context index as we've finished the inner invoke
@@ -3025,7 +3036,7 @@ Tcl_GetObjectFromObj(
goto notAnObject;
}
}
- return (Tcl_Object)cmdPtr->objClientData;
+ return (Tcl_Object) cmdPtr->objClientData;
notAnObject:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -3141,49 +3152,49 @@ Tcl_Object
Tcl_ObjectContextObject(
Tcl_ObjectContext context)
{
- return (Tcl_Object) ((CallContext *)context)->oPtr;
+ return (Tcl_Object) ((CallContext *) context)->oPtr;
}
Tcl_Size
Tcl_ObjectContextSkippedArgs(
Tcl_ObjectContext context)
{
- return ((CallContext *)context)->skip;
+ return ((CallContext *) context)->skip;
}
Tcl_Namespace *
Tcl_GetObjectNamespace(
Tcl_Object object)
{
- return ((Object *)object)->namespacePtr;
+ return ((Object *) object)->namespacePtr;
}
Tcl_Command
Tcl_GetObjectCommand(
Tcl_Object object)
{
- return ((Object *)object)->command;
+ return ((Object *) object)->command;
}
Tcl_Class
Tcl_GetObjectAsClass(
Tcl_Object object)
{
- return (Tcl_Class) ((Object *)object)->classPtr;
+ return (Tcl_Class) ((Object *) object)->classPtr;
}
int
Tcl_ObjectDeleted(
Tcl_Object object)
{
- return ((Object *)object)->command == NULL;
+ return ((Object *) object)->command == NULL;
}
Tcl_Object
Tcl_GetClassAsObject(
Tcl_Class clazz)
{
- return (Tcl_Object) ((Class *)clazz)->thisPtr;
+ return (Tcl_Object) ((Class *) clazz)->thisPtr;
}
Tcl_ObjectMapMethodNameProc *
diff --git a/generic/tclOO.h b/generic/tclOO.h
index 7cda876..7adf559 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -81,7 +81,7 @@ typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp,
* how to create a clone of it (when the object or class is copied).
*/
-typedef struct {
+typedef struct Tcl_MethodType {
int version; /* Structure version field. Always to be equal
* to TCL_OO_METHOD_VERSION_(1|CURRENT) in
* declarations. */
@@ -99,7 +99,7 @@ typedef struct {
} Tcl_MethodType;
#if TCL_MAJOR_VERSION > 8
-typedef struct {
+typedef struct Tcl_MethodType2 {
int version; /* Structure version field. Always to be equal
* to TCL_OO_METHOD_VERSION_2 in
* declarations. */
@@ -124,19 +124,21 @@ typedef struct {
* This allows new versions of the structure to be introduced without breaking
* binary compatibility.
*/
-
-#define TCL_OO_METHOD_VERSION_1 1
-#define TCL_OO_METHOD_VERSION_2 2
-#define TCL_OO_METHOD_VERSION_CURRENT 1
+enum TclOOMethodVersion {
+ TCL_OO_METHOD_VERSION_1 = 1,
+ TCL_OO_METHOD_VERSION_2 = 2
+};
+#define TCL_OO_METHOD_VERSION_CURRENT TCL_OO_METHOD_VERSION_1
/*
* Visibility constants for the flags parameter to Tcl_NewMethod and
* Tcl_NewInstanceMethod.
*/
-
-#define TCL_OO_METHOD_PUBLIC 1
-#define TCL_OO_METHOD_UNEXPORTED 0
-#define TCL_OO_METHOD_PRIVATE 0x20
+enum TclOOMethodVisibilityFlags {
+ TCL_OO_METHOD_PUBLIC = 1,
+ TCL_OO_METHOD_UNEXPORTED = 0,
+ TCL_OO_METHOD_PRIVATE = 0x20
+};
/*
* The type of some object (or class) metadata. This describes how to delete
@@ -144,7 +146,7 @@ typedef struct {
* clone of it (when the object or class is copied).
*/
-typedef struct {
+typedef struct Tcl_ObjectMetadataType {
int version; /* Structure version field. Always to be equal
* to TCL_OO_METADATA_VERSION_CURRENT in
* declarations. */
@@ -163,7 +165,10 @@ typedef struct {
* without breaking binary compatibility.
*/
-#define TCL_OO_METADATA_VERSION_CURRENT 1
+enum TclOOMetadataVersion {
+ TCL_OO_METADATA_VERSION_1 = 1
+};
+#define TCL_OO_METADATA_VERSION_CURRENT TCL_OO_METADATA_VERSION_1
/*
* Include all the public API, generated from tclOO.decls.
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index a3cccc7..1506a34 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -56,7 +56,7 @@ FinalizeConstruction(
Tcl_Interp *interp,
int result)
{
- Object *oPtr = (Object *)data[0];
+ Object *oPtr = (Object *) data[0];
if (result != TCL_OK) {
return result;
@@ -87,11 +87,11 @@ TclOO_Class_Constructor(
Tcl_Obj **invoke, *nameObj;
size_t skip = Tcl_ObjectContextSkippedArgs(context);
- if ((size_t)objc > skip + 1) {
+ if ((size_t) objc > skip + 1) {
Tcl_WrongNumArgs(interp, skip, objv,
"?definitionScript?");
return TCL_ERROR;
- } else if ((size_t)objc == skip) {
+ } else if ((size_t) objc == skip) {
return TCL_OK;
}
@@ -100,17 +100,17 @@ TclOO_Class_Constructor(
* here (and the class definition delegate doesn't run any constructors).
*/
- nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
- Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
+ nameObj = Tcl_ObjPrintf("%s:: oo ::delegate",
+ oPtr->namespacePtr->fullName);
Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
TclGetString(nameObj), NULL, -1, NULL, -1);
- Tcl_DecrRefCount(nameObj);
+ Tcl_BounceRefCount(nameObj);
/*
* Delegate to [oo::define] to do the work.
*/
- invoke = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *));
+ invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *));
invoke[0] = oPtr->fPtr->defineName;
invoke[1] = TclOOObjectName(interp, oPtr);
invoke[2] = objv[objc-1];
@@ -140,8 +140,8 @@ DecrRefsPostClassConstructor(
Tcl_Interp *interp,
int result)
{
- Tcl_Obj **invoke = (Tcl_Obj **)data[0];
- Object *oPtr = (Object *)data[1];
+ Tcl_Obj **invoke = (Tcl_Obj **) data[0];
+ Object *oPtr = (Object *) data[1];
Tcl_InterpState saved;
int code;
@@ -156,7 +156,7 @@ DecrRefsPostClassConstructor(
code = Tcl_EvalObjv(interp, 2, invoke, 0);
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
- Tcl_Free(invoke);
+ TclStackFree(interp, invoke);
if (code != TCL_OK) {
Tcl_DiscardInterpState(saved);
return code;
@@ -368,7 +368,7 @@ TclOO_Object_Destroy(
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
CallContext *contextPtr;
- if (objc != (int)Tcl_ObjectContextSkippedArgs(context)) {
+ if (objc != (int) Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
@@ -398,7 +398,7 @@ AfterNRDestructor(
Tcl_Interp *interp,
int result)
{
- CallContext *contextPtr = (CallContext *)data[0];
+ CallContext *contextPtr = (CallContext *) data[0];
if (contextPtr->oPtr->command) {
Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
@@ -433,7 +433,7 @@ TclOO_Object_Eval(
Tcl_Obj *scriptPtr;
CmdFrame *invoker;
- if ((size_t)objc < skip + 1) {
+ if ((size_t) objc < skip + 1) {
Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?");
return TCL_ERROR;
}
@@ -462,7 +462,7 @@ TclOO_Object_Eval(
* object when it decrements its refcount after eval'ing it.
*/
- if ((size_t)objc != skip+1) {
+ if ((size_t) objc != skip+1) {
scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip);
invoker = NULL;
} else {
@@ -486,7 +486,7 @@ FinalizeEval(
int result)
{
if (result == TCL_ERROR) {
- Object *oPtr = (Object *)data[0];
+ Object *oPtr = (Object *) data[0];
const char *namePtr;
if (oPtr) {
@@ -544,7 +544,7 @@ TclOO_Object_Unknown(
* name without an error).
*/
- if ((size_t)objc < skip+1) {
+ if ((size_t) objc < skip + 1) {
Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
return TCL_ERROR;
}
@@ -555,7 +555,7 @@ TclOO_Object_Unknown(
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
- CallContext *callerContext = (CallContext *)framePtr->clientData;
+ CallContext *callerContext = (CallContext *) framePtr->clientData;
Method *mPtr = callerContext->callPtr->chain[
callerContext->index].mPtr;
@@ -609,7 +609,7 @@ TclOO_Object_Unknown(
Tcl_AppendToObj(errorMsg, " or ", -1);
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
- Tcl_Free((void *)methodNames);
+ Tcl_Free((void *) methodNames);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), (char *)NULL);
@@ -721,34 +721,21 @@ TclOO_Object_LinkVar(
/*
* ----------------------------------------------------------------------
*
- * TclOO_Object_VarName --
+ * TclOOLookupObjectVar --
*
- * Implementation of the oo::object->varname method.
+ * Look up a variable in an object. Tricky because of private variables.
*
* ----------------------------------------------------------------------
*/
-
-int
-TclOO_Object_VarName(
- TCL_UNUSED(void *),
- Tcl_Interp *interp, /* Interpreter in which to create the object;
- * also used for error reporting. */
- Tcl_ObjectContext context, /* The object/call context. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* The actual arguments. */
+Tcl_Var
+TclOOLookupObjectVar(
+ Tcl_Interp *interp,
+ Tcl_Object object,
+ Tcl_Obj *varName,
+ Tcl_Var *aryPtr)
{
- Var *varPtr, *aryVar;
- Tcl_Obj *varNamePtr, *argPtr;
- CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
- const char *arg;
-
- if ((int)Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
- Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
- "varName");
- return TCL_ERROR;
- }
- argPtr = objv[objc-1];
- arg = TclGetString(argPtr);
+ const char *arg = TclGetString(varName);
+ Tcl_Obj *varNamePtr;
/*
* Convert the variable name to fully-qualified form if it wasn't already.
@@ -760,10 +747,10 @@ TclOO_Object_VarName(
*/
if (arg[0] == ':' && arg[1] == ':') {
- varNamePtr = argPtr;
+ varNamePtr = varName;
} else {
- Tcl_Namespace *namespacePtr =
- Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
+ Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(object);
+ CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
/*
* Private method handling. [TIP 500]
@@ -776,8 +763,8 @@ TclOO_Object_VarName(
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
- Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- CallContext *callerContext = (CallContext *)framePtr->clientData;
+ Object *oPtr = (Object *) object;
+ CallContext *callerContext = (CallContext *) framePtr->clientData;
Method *mPtr = callerContext->callPtr->chain[
callerContext->index].mPtr;
PrivateVariableMapping *pvPtr;
@@ -785,9 +772,9 @@ TclOO_Object_VarName(
if (mPtr->declaringObjectPtr == oPtr) {
FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
- if (!strcmp(TclGetString(pvPtr->variableObj),
- TclGetString(argPtr))) {
- argPtr = pvPtr->fullNameObj;
+ if (!TclStringCmp(pvPtr->variableObj, varName, 1, 0,
+ TCL_INDEX_NONE)) {
+ varName = pvPtr->fullNameObj;
break;
}
}
@@ -807,9 +794,9 @@ TclOO_Object_VarName(
}
if (isInstance) {
FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
- if (!strcmp(TclGetString(pvPtr->variableObj),
- TclGetString(argPtr))) {
- argPtr = pvPtr->fullNameObj;
+ if (!TclStringCmp(pvPtr->variableObj, varName, 1, 0,
+ TCL_INDEX_NONE)) {
+ varName = pvPtr->fullNameObj;
break;
}
}
@@ -817,23 +804,59 @@ TclOO_Object_VarName(
}
}
- varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
- Tcl_AppendToObj(varNamePtr, "::", 2);
- Tcl_AppendObjToObj(varNamePtr, argPtr);
+ // The namespace isn't the global one; necessarily true for any object!
+ varNamePtr = Tcl_ObjPrintf("%s::%s",
+ namespacePtr->fullName, TclGetString(varName));
}
Tcl_IncrRefCount(varNamePtr);
- varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
- TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
+ Tcl_Var var = (Tcl_Var) TclObjLookupVar(interp, varNamePtr, NULL,
+ TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1,
+ (Var **) aryPtr);
Tcl_DecrRefCount(varNamePtr);
+ if (var == NULL) {
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (void *) NULL);
+ }
+ return var;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_VarName --
+ *
+ * Implementation of the oo::object->varname method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_VarName(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Tcl_Var varPtr, aryVar;
+ Tcl_Obj *varNamePtr;
+
+ if ((int) Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "varName");
+ return TCL_ERROR;
+ }
+
+ varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
+ objv[objc - 1], &aryVar);
if (varPtr == NULL) {
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (char *)NULL);
return TCL_ERROR;
}
/*
* The variable reference must not disappear too soon. [Bug 74b6110204]
*/
- TclSetVarNamespaceVar(varPtr);
+ TclSetVarNamespaceVar((Var *) varPtr);
/*
* Now that we've pinned down what variable we're really talking about
@@ -842,18 +865,16 @@ TclOO_Object_VarName(
TclNewObj(varNamePtr);
if (aryVar != NULL) {
- Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
+ Tcl_GetVariableFullName(interp, aryVar, varNamePtr);
/*
* WARNING! This code pokes inside the implementation of hash tables!
*/
- Tcl_AppendToObj(varNamePtr, "(", -1);
- Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
- varPtr)->entry.key.objPtr);
- Tcl_AppendToObj(varNamePtr, ")", -1);
+ Tcl_AppendPrintfToObj(varNamePtr, "(%s)", Tcl_GetString(
+ ((VarInHash *) varPtr)->entry.key.objPtr));
} else {
- Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+ Tcl_GetVariableFullName(interp, varPtr, varNamePtr);
}
Tcl_SetObjResult(interp, varNamePtr);
return TCL_OK;
@@ -895,7 +916,7 @@ TclOONextObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
return TCL_ERROR;
}
- context = (Tcl_ObjectContext)framePtr->clientData;
+ context = (Tcl_ObjectContext) framePtr->clientData;
/*
* Invoke the (advanced) method call context in the caller context. Note
@@ -935,7 +956,7 @@ TclOONextToObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
return TCL_ERROR;
}
- contextPtr = (CallContext *)framePtr->clientData;
+ contextPtr = (CallContext *) framePtr->clientData;
/*
* Sanity check the arguments; we need the first one to refer to a class.
@@ -949,7 +970,7 @@ TclOONextToObjCmd(
if (object == NULL) {
return TCL_ERROR;
}
- classPtr = ((Object *)object)->classPtr;
+ classPtr = ((Object *) object)->classPtr;
if (classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[1])));
@@ -964,7 +985,7 @@ TclOONextToObjCmd(
*/
for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
- struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+ MInvoke *miPtr = &contextPtr->callPtr->chain[i];
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
/*
@@ -995,7 +1016,7 @@ TclOONextToObjCmd(
}
for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) {
- struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+ MInvoke *miPtr = &contextPtr->callPtr->chain[i];
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -1020,9 +1041,9 @@ NextRestoreFrame(
int result)
{
Interp *iPtr = (Interp *) interp;
- CallContext *contextPtr = (CallContext *)data[1];
+ CallContext *contextPtr = (CallContext *) data[1];
- iPtr->varFramePtr = (CallFrame *)data[0];
+ iPtr->varFramePtr = (CallFrame *) data[0];
if (contextPtr != NULL) {
contextPtr->index = PTR2UINT(data[2]);
}
@@ -1075,7 +1096,7 @@ TclOOSelfObjCmd(
return TCL_ERROR;
}
- contextPtr = (CallContext*)framePtr->clientData;
+ contextPtr = (CallContext *) framePtr->clientData;
/*
* Now we do "conventional" argument parsing for a while. Note that no
@@ -1130,7 +1151,7 @@ TclOOSelfObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL);
return TCL_ERROR;
} else {
- struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
+ MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
Object *oPtr;
const char *type;
@@ -1156,7 +1177,8 @@ TclOOSelfObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
return TCL_ERROR;
} else {
- CallContext *callerPtr = (CallContext *)framePtr->callerVarPtr->clientData;
+ CallContext *callerPtr = (CallContext *)
+ framePtr->callerVarPtr->clientData;
Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
Object *declarerPtr;
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index a65ce5e..6ce1ef3 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -19,30 +19,29 @@
#include <assert.h>
/*
- * Structure containing a CallContext and any other values needed only during
- * the construction of the CallContext.
+ * Structure containing a CallChain and any other values needed only during
+ * the construction of the CallChain.
*/
-
-struct ChainBuilder {
+typedef struct ChainBuilder {
CallChain *callChainPtr; /* The call chain being built. */
- size_t filterLength; /* Number of entries in the call chain that
+ size_t 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. */
-};
+} ChainBuilder;
/*
* Structures used for traversing the class hierarchy to find out where
* definitions are supposed to be done.
*/
-typedef struct {
+typedef struct DefineEntry {
Class *definerCls;
Tcl_Obj *namespaceName;
} DefineEntry;
-typedef struct {
+typedef struct DefineChain {
DefineEntry *list;
int num;
int size;
@@ -51,15 +50,17 @@ typedef struct {
/*
* Extra flags used for call chain management.
*/
+enum CallChainFlags {
+ DEFINITE_PROTECTED = 0x100000,
+ DEFINITE_PUBLIC = 0x200000,
+ KNOWN_STATE = (DEFINITE_PROTECTED | DEFINITE_PUBLIC),
+ SPECIAL = (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN),
+ BUILDING_MIXINS = 0x400000,
+ TRAVERSED_MIXIN = 0x800000,
+ OBJECT_MIXIN = 0x1000000,
+ DEFINE_FOR_CLASS = 0x2000000
+};
-#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))
@@ -87,11 +88,19 @@ typedef struct {
(((flags) & TRUE_PRIVATE_METHOD) != 0)
/*
+ * Name the bits used in the names table values.
+ */
+enum NameTableValues {
+ IN_LIST = 1, /* Seen an implementation. */
+ NO_IMPLEMENTATION = 2 /* Seen, but not implemented yet. */
+};
+
+/*
* Function declarations for things defined in this file.
*/
static void AddClassFiltersToCallContext(Object *const oPtr,
- Class *clsPtr, struct ChainBuilder *const cbPtr,
+ Class *clsPtr, ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags);
static void AddClassMethodNames(Class *clsPtr, int flags,
Tcl_HashTable *const namesPtr,
@@ -100,12 +109,12 @@ 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,
+ 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);
+ 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,
@@ -113,18 +122,18 @@ static inline void AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr,
static inline int AddSimpleChainToCallContext(Object *const oPtr,
Class *const contextCls,
Tcl_Obj *const methodNameObj,
- struct ChainBuilder *const cbPtr,
+ 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,
+ 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,
+ ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags,
Class *const filterDecl);
static void AddSimpleClassDefineNamespaces(Class *classPtr,
@@ -281,16 +290,16 @@ DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
- StashCallChain(dstPtr,
- (CallChain *)TclFetchInternalRep(srcPtr, &methodNameType)->twoPtrValue.ptr1);
+ StashCallChain(dstPtr, (CallChain *)
+ TclFetchInternalRep(srcPtr, &methodNameType)->twoPtrValue.ptr1);
}
static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
- TclOODeleteChain(
- (CallChain *)TclFetchInternalRep(objPtr, &methodNameType)->twoPtrValue.ptr1);
+ TclOODeleteChain((CallChain *)
+ TclFetchInternalRep(objPtr, &methodNameType)->twoPtrValue.ptr1);
}
/*
@@ -308,7 +317,7 @@ FreeMethodNameRep(
int
TclOOInvokeContext(
- void *clientData, /* The method call context. */
+ 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
@@ -316,7 +325,7 @@ TclOOInvokeContext(
int objc, /* The number of arguments. */
Tcl_Obj *const objv[]) /* The arguments as actually seen. */
{
- CallContext *const contextPtr = (CallContext *)clientData;
+ CallContext *const contextPtr = (CallContext *) clientData;
Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
const int isFilter =
contextPtr->callPtr->chain[contextPtr->index].isFilter;
@@ -375,7 +384,7 @@ TclOOInvokeContext(
return (mPtr->typePtr->callProc)(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
- return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
+ return (mPtr->type2Ptr->callProc)(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
@@ -385,7 +394,7 @@ SetFilterFlags(
TCL_UNUSED(Tcl_Interp *),
int result)
{
- CallContext *contextPtr = (CallContext *)data[0];
+ CallContext *contextPtr = (CallContext *) data[0];
contextPtr->oPtr->flags |= FILTER_HANDLING;
return result;
@@ -397,7 +406,7 @@ ResetFilterFlags(
TCL_UNUSED(Tcl_Interp *),
int result)
{
- CallContext *contextPtr = (CallContext *)data[0];
+ CallContext *contextPtr = (CallContext *) data[0];
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
return result;
@@ -409,7 +418,7 @@ FinalizeMethodRefs(
TCL_UNUSED(Tcl_Interp *),
int result)
{
- CallContext *contextPtr = (CallContext *)data[0];
+ CallContext *contextPtr = (CallContext *) data[0];
Tcl_Size i;
for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
@@ -460,12 +469,6 @@ TclOOGetSortedMethodList(
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.
*/
@@ -619,7 +622,7 @@ SortMethodNames(
* sorted when it is long enough to matter.
*/
- strings = (const char **)Tcl_Alloc(sizeof(char *) * namesPtr->numEntries);
+ strings = (const char **) Tcl_Alloc(sizeof(char *) * namesPtr->numEntries);
FOREACH_HASH(namePtr, isWanted, namesPtr) {
if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) {
if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
@@ -641,7 +644,7 @@ SortMethodNames(
}
*stringsPtr = strings;
} else {
- Tcl_Free((void *)strings);
+ Tcl_Free((void *) strings);
*stringsPtr = NULL;
}
return i;
@@ -677,7 +680,7 @@ CmpStr(
static void
AddClassMethodNames(
Class *clsPtr, /* Class to get method names from. */
- int flags, /* Whether we are interested in just the
+ int flags, /* Whether we are interested in just the
* public method names. */
Tcl_HashTable *const namesPtr,
/* Reference to the hash table to put the
@@ -808,9 +811,6 @@ AddStandardMethodName(
}
}
}
-
-#undef IN_LIST
-#undef NO_IMPLEMENTATION
/*
* ----------------------------------------------------------------------
@@ -830,8 +830,7 @@ 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. */
+ ChainBuilder *const cbPtr, /* Where to add the call chain entries. */
int flags) /* What sort of call chain are we building. */
{
Tcl_HashEntry *hPtr;
@@ -841,7 +840,7 @@ AddInstancePrivateToCallContext(
if (oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodName);
if (hPtr != NULL) {
- mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
donePrivate = 1;
@@ -873,8 +872,7 @@ AddSimpleChainToCallContext(
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. */
+ ChainBuilder *const cbPtr, /* Where to add the call chain entries. */
Tcl_HashTable *const doneFilters,
/* Where to record what call chain entries
* have been processed. */
@@ -892,7 +890,7 @@ AddSimpleChainToCallContext(
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);
if (hPtr != NULL) {
- mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
if (WANT_PUBLIC(flags)) {
if (!IS_PUBLIC(mPtr)) {
@@ -922,7 +920,7 @@ AddSimpleChainToCallContext(
if (oPtr->methodsPtr && !blockedUnexported) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);
if (hPtr != NULL) {
- mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
flags);
@@ -960,8 +958,7 @@ 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
+ ChainBuilder *const cbPtr, /* The call chain to add the method
* implementation to. */
Tcl_HashTable *const doneFilters,
/* Where to record what filters have been
@@ -1046,13 +1043,13 @@ AddMethodToCallChain(
*/
if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
- callPtr->chain =
- (struct MInvoke *)Tcl_Alloc(sizeof(struct MInvoke) * (callPtr->numChain + 1));
+ callPtr->chain = (MInvoke *)
+ Tcl_Alloc(sizeof(MInvoke) * (callPtr->numChain + 1));
memcpy(callPtr->chain, callPtr->staticChain,
- sizeof(struct MInvoke) * callPtr->numChain);
+ sizeof(MInvoke) * callPtr->numChain);
} else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
- callPtr->chain = (struct MInvoke *)Tcl_Realloc(callPtr->chain,
- sizeof(struct MInvoke) * (callPtr->numChain + 1));
+ callPtr->chain = (MInvoke *) Tcl_Realloc(callPtr->chain,
+ sizeof(MInvoke) * (callPtr->numChain + 1));
}
callPtr->chain[i].mPtr = mPtr;
callPtr->chain[i].isFilter = (doneFilters != NULL);
@@ -1178,7 +1175,7 @@ TclOOGetCallContext(
{
CallContext *contextPtr;
CallChain *callPtr;
- struct ChainBuilder cb;
+ ChainBuilder cb;
Tcl_Size i, count;
int doFilters, donePrivate = 0;
Tcl_HashEntry *hPtr;
@@ -1224,7 +1221,7 @@ TclOOGetCallContext(
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
if ((irPtr = TclFetchInternalRep(cacheInThisObj, &methodNameType))) {
- callPtr = (CallChain *)irPtr->twoPtrValue.ptr1;
+ callPtr = (CallChain *) irPtr->twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
@@ -1257,7 +1254,7 @@ TclOOGetCallContext(
}
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
- callPtr = (CallChain *)Tcl_GetHashValue(hPtr);
+ callPtr = (CallChain *) Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
@@ -1269,7 +1266,7 @@ TclOOGetCallContext(
doFilters = 1;
}
- callPtr = (CallChain *)Tcl_Alloc(sizeof(CallChain));
+ callPtr = (CallChain *) Tcl_Alloc(sizeof(CallChain));
InitCallChain(callPtr, oPtr, flags);
cb.callChainPtr = callPtr;
@@ -1374,8 +1371,8 @@ TclOOGetCallContext(
int isNew;
if (oPtr->flags & USE_CLASS_CACHE) {
if (oPtr->selfCls->classChainCache == NULL) {
- oPtr->selfCls->classChainCache =
- (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
+ oPtr->selfCls->classChainCache = (Tcl_HashTable *)
+ Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
}
@@ -1383,7 +1380,8 @@ TclOOGetCallContext(
methodNameObj, &isNew);
} else {
if (oPtr->chainCache == NULL) {
- oPtr->chainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
+ oPtr->chainCache = (Tcl_HashTable *)
+ Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->chainCache);
}
@@ -1409,7 +1407,8 @@ TclOOGetCallContext(
}
returnContext:
- contextPtr = (CallContext *)TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
+ contextPtr = (CallContext *)
+ TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
contextPtr->oPtr = oPtr;
/*
@@ -1447,7 +1446,7 @@ TclOOGetStereotypeCallChain(
* FILTER_HANDLING are useful. */
{
CallChain *callPtr;
- struct ChainBuilder cb;
+ ChainBuilder cb;
Tcl_Size count;
Foundation *fPtr = clsPtr->thisPtr->fPtr;
Tcl_HashEntry *hPtr;
@@ -1489,7 +1488,7 @@ TclOOGetStereotypeCallChain(
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
- callPtr = (CallChain *)Tcl_GetHashValue(hPtr);
+ callPtr = (CallChain *) Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
callPtr->refCount++;
return callPtr;
@@ -1501,7 +1500,7 @@ TclOOGetStereotypeCallChain(
hPtr = NULL;
}
- callPtr = (CallChain *)Tcl_Alloc(sizeof(CallChain));
+ callPtr = (CallChain *) Tcl_Alloc(sizeof(CallChain));
memset(callPtr, 0, sizeof(CallChain));
callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING);
callPtr->epoch = fPtr->epoch;
@@ -1557,7 +1556,8 @@ TclOOGetStereotypeCallChain(
if (hPtr == NULL) {
int isNew;
if (clsPtr->classChainCache == NULL) {
- clsPtr->classChainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
+ clsPtr->classChainCache = (Tcl_HashTable *)
+ Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(clsPtr->classChainCache);
}
hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
@@ -1585,8 +1585,7 @@ 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. */
+ 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
@@ -1673,8 +1672,7 @@ AddPrivatesFromClassChainToCallContext(
* 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. */
+ ChainBuilder *const cbPtr, /* Where to add the call chain entries. */
Tcl_HashTable *const doneFilters,
/* Where to record what call chain entries
* have been processed. */
@@ -1715,7 +1713,7 @@ AddPrivatesFromClassChainToCallContext(
methodName);
if (hPtr != NULL) {
- Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
@@ -1758,8 +1756,7 @@ AddSimpleClassChainToCallContext(
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. */
+ ChainBuilder *const cbPtr, /* Where to add the call chain entries. */
Tcl_HashTable *const doneFilters,
/* Where to record what call chain entries
* have been processed. */
@@ -1804,7 +1801,7 @@ AddSimpleClassChainToCallContext(
privateDanger |= 1;
}
if (hPtr != NULL) {
- Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
if (!(flags & KNOWN_STATE)) {
@@ -1864,13 +1861,9 @@ TclOORenderCallChain(
*/
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
@@ -1884,9 +1877,10 @@ TclOORenderCallChain(
* method (or "object" if it is declared on the instance).
*/
- objv = (Tcl_Obj **)TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
+ objv = (Tcl_Obj **)
+ TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
for (i = 0 ; i < callPtr->numChain ; i++) {
- struct MInvoke *miPtr = &callPtr->chain[i];
+ MInvoke *miPtr = &callPtr->chain[i];
descObjs[0] =
miPtr->isFilter ? filterLiteral :
@@ -1911,10 +1905,10 @@ TclOORenderCallChain(
* they'll live on the description itself.
*/
- Tcl_DecrRefCount(filterLiteral);
- Tcl_DecrRefCount(methodLiteral);
- Tcl_DecrRefCount(objectLiteral);
- Tcl_DecrRefCount(privateLiteral);
+ Tcl_BounceRefCount(filterLiteral);
+ Tcl_BounceRefCount(methodLiteral);
+ Tcl_BounceRefCount(objectLiteral);
+ Tcl_BounceRefCount(privateLiteral);
/*
* Finish building the description and return it.
@@ -2090,8 +2084,9 @@ AddSimpleClassDefineNamespaces(
static inline void
AddDefinitionNamespaceToChain(
- Class *const definerCls, /* What class defines this entry. */
- Tcl_Obj *const namespaceName, /* The name for this entry (or NULL, a
+ 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
@@ -2151,12 +2146,12 @@ AddDefinitionNamespaceToChain(
if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) {
DefineEntry *staticList = definePtr->list;
- definePtr->list =
- (DefineEntry *)Tcl_Alloc(sizeof(DefineEntry) * definePtr->size);
+ definePtr->list = (DefineEntry *)
+ Tcl_Alloc(sizeof(DefineEntry) * definePtr->size);
memcpy(definePtr->list, staticList,
sizeof(DefineEntry) * definePtr->num);
} else {
- definePtr->list = (DefineEntry *)Tcl_Realloc(definePtr->list,
+ definePtr->list = (DefineEntry *) Tcl_Realloc(definePtr->list,
sizeof(DefineEntry) * definePtr->size);
}
}
@@ -2166,259 +2161,6 @@ AddDefinitionNamespaceToChain(
}
/*
- * ----------------------------------------------------------------------
- *
- * 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
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 7bee39b..70f0381 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -32,13 +32,12 @@
/*
* Some things that make it easier to declare a slot.
*/
-
-struct DeclaredSlot {
+typedef struct DeclaredSlot {
const char *name;
const Tcl_MethodType getterType;
const Tcl_MethodType setterType;
const Tcl_MethodType resolverType;
-};
+} DeclaredSlot;
#define SLOT(name,getter,setter,resolver) \
{"::oo::" name, \
@@ -79,52 +78,72 @@ static inline void RecomputeClassCacheFlag(Object *oPtr);
static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
int useClass, Tcl_Obj *const fromPtr,
Tcl_Obj *const toPtr);
-static int ClassFilterGet(void *clientData,
+static int ClassFilter_Get(void *clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassFilter_Set(void *clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassMixin_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ClassFilterSet(void *clientData,
+static int ClassMixin_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ClassMixinGet(void *clientData,
+static int ClassSuper_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ClassMixinSet(void *clientData,
+static int ClassSuper_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ClassSuperGet(void *clientData,
+static int ClassVars_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ClassSuperSet(void *clientData,
+static int ClassVars_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ClassVarsGet(void *clientData,
+static int ObjFilter_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ClassVarsSet(void *clientData,
+static int ObjFilter_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet;
-static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet;
-static int ObjFilterGet(void *clientData,
+static int ObjMixin_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ObjFilterSet(void *clientData,
+static int ObjMixin_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ObjMixinGet(void *clientData,
+static int ObjVars_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ObjMixinSet(void *clientData,
+static int ObjVars_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ObjVarsGet(void *clientData,
+static int Configurable_ClassReadableProps_Get(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static int ObjVarsSet(void *clientData,
+static int Configurable_ClassReadableProps_Set(void *clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Configurable_ClassWritableProps_Get(void *clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Configurable_ClassWritableProps_Set(void *clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Configurable_ObjectReadableProps_Get(void *clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Configurable_ObjectReadableProps_Set(void *clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Configurable_ObjectWritableProps_Get(void *clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Configurable_ObjectWritableProps_Set(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
-static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet;
-static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet;
static int ResolveClass(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
@@ -133,22 +152,26 @@ static int ResolveClass(void *clientData,
* Now define the slots used in declarations.
*/
-static const struct DeclaredSlot slots[] = {
- SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL),
- SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass),
- SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass),
- SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL),
- SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL),
- SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass),
- SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL),
+static const DeclaredSlot slots[] = {
+ SLOT("define::filter", ClassFilter_Get, ClassFilter_Set, NULL),
+ SLOT("define::mixin", ClassMixin_Get, ClassMixin_Set, ResolveClass),
+ SLOT("define::superclass", ClassSuper_Get, ClassSuper_Set, ResolveClass),
+ SLOT("define::variable", ClassVars_Get, ClassVars_Set, NULL),
+ SLOT("objdefine::filter", ObjFilter_Get, ObjFilter_Set, NULL),
+ SLOT("objdefine::mixin", ObjMixin_Get, ObjMixin_Set, ResolveClass),
+ SLOT("objdefine::variable", ObjVars_Get, ObjVars_Set, NULL),
SLOT("configuresupport::readableproperties",
- ClassRPropsGet, ClassRPropsSet, NULL),
+ Configurable_ClassReadableProps_Get,
+ Configurable_ClassReadableProps_Set, NULL),
SLOT("configuresupport::writableproperties",
- ClassWPropsGet, ClassWPropsSet, NULL),
+ Configurable_ClassWritableProps_Get,
+ Configurable_ClassWritableProps_Set, NULL),
SLOT("configuresupport::objreadableproperties",
- ObjRPropsGet, ObjRPropsSet, NULL),
+ Configurable_ObjectReadableProps_Get,
+ Configurable_ObjectReadableProps_Set, NULL),
SLOT("configuresupport::objwritableproperties",
- ObjWPropsGet, ObjWPropsSet, NULL),
+ Configurable_ObjectWritableProps_Get,
+ Configurable_ObjectWritableProps_Set, NULL),
{NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};
@@ -330,12 +353,12 @@ TclOOObjectSetFilters(
*/
Tcl_Obj **filtersList;
- int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
+ size_t size = sizeof(Tcl_Obj *) * numFilters;
if (oPtr->filters.num == 0) {
- filtersList = (Tcl_Obj **)Tcl_Alloc(size);
+ filtersList = (Tcl_Obj **) Tcl_Alloc(size);
} else {
- filtersList = (Tcl_Obj **)Tcl_Realloc(oPtr->filters.list, size);
+ filtersList = (Tcl_Obj **) Tcl_Realloc(oPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
@@ -345,7 +368,7 @@ TclOOObjectSetFilters(
oPtr->filters.num = numFilters;
oPtr->flags &= ~USE_CLASS_CACHE;
}
- BumpInstanceEpoch(oPtr); /* Only this object can be affected. */
+ BumpInstanceEpoch(oPtr); // Only this object can be affected.
}
/*
@@ -389,12 +412,13 @@ TclOOClassSetFilters(
*/
Tcl_Obj **filtersList;
- int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
+ size_t size = sizeof(Tcl_Obj *) * numFilters;
if (classPtr->filters.num == 0) {
- filtersList = (Tcl_Obj **)Tcl_Alloc(size);
+ filtersList = (Tcl_Obj **) Tcl_Alloc(size);
} else {
- filtersList = (Tcl_Obj **)Tcl_Realloc(classPtr->filters.list, size);
+ filtersList = (Tcl_Obj **)
+ Tcl_Realloc(classPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
@@ -448,10 +472,11 @@ TclOOObjectSetMixins(
}
TclOODecrRefCount(mixinPtr->thisPtr);
}
- oPtr->mixins.list = (Class **)Tcl_Realloc(oPtr->mixins.list,
+ oPtr->mixins.list = (Class **) Tcl_Realloc(oPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
- oPtr->mixins.list = (Class **)Tcl_Alloc(sizeof(Class *) * numMixins);
+ oPtr->mixins.list = (Class **)
+ Tcl_Alloc(sizeof(Class *) * numMixins);
oPtr->flags &= ~USE_CLASS_CACHE;
}
oPtr->mixins.num = numMixins;
@@ -506,10 +531,12 @@ TclOOClassSetMixins(
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
- classPtr->mixins.list = (Class **)Tcl_Realloc(classPtr->mixins.list,
- sizeof(Class *) * numMixins);
+ classPtr->mixins.list = (Class **)
+ Tcl_Realloc(classPtr->mixins.list,
+ sizeof(Class *) * numMixins);
} else {
- classPtr->mixins.list = (Class **)Tcl_Alloc(sizeof(Class *) * numMixins);
+ classPtr->mixins.list = (Class **)
+ Tcl_Alloc(sizeof(Class *) * numMixins);
}
classPtr->mixins.num = numMixins;
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
@@ -557,9 +584,10 @@ InstallStandardVariableMapping(
if (varc == 0) {
Tcl_Free(vnlPtr->list);
} else if (i) {
- vnlPtr->list = (Tcl_Obj **)Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
+ vnlPtr->list = (Tcl_Obj **)
+ Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
} else {
- vnlPtr->list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * varc);
+ vnlPtr->list = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj *) * varc);
}
}
vnlPtr->num = 0;
@@ -580,7 +608,8 @@ InstallStandardVariableMapping(
*/
if (n != varc) {
- vnlPtr->list = (Tcl_Obj **)Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * n);
+ vnlPtr->list = (Tcl_Obj **)
+ Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
@@ -609,10 +638,12 @@ InstallPrivateVariableMapping(
if (varc == 0) {
Tcl_Free(pvlPtr->list);
} else if (i) {
- pvlPtr->list = (PrivateVariableMapping *)Tcl_Realloc(pvlPtr->list,
- sizeof(PrivateVariableMapping) * varc);
+ pvlPtr->list = (PrivateVariableMapping *)
+ Tcl_Realloc(pvlPtr->list,
+ sizeof(PrivateVariableMapping) * varc);
} else {
- pvlPtr->list = (PrivateVariableMapping *)Tcl_Alloc(sizeof(PrivateVariableMapping) * varc);
+ pvlPtr->list = (PrivateVariableMapping *)
+ Tcl_Alloc(sizeof(PrivateVariableMapping) * varc);
}
}
@@ -639,7 +670,7 @@ InstallPrivateVariableMapping(
*/
if (n != varc) {
- pvlPtr->list = (PrivateVariableMapping *)Tcl_Realloc(pvlPtr->list,
+ pvlPtr->list = (PrivateVariableMapping *) Tcl_Realloc(pvlPtr->list,
sizeof(PrivateVariableMapping) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
@@ -719,7 +750,7 @@ RenameDeleteMethod(
* Complete the splicing by changing the method's name.
*/
- mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (toPtr) {
Tcl_IncrRefCount(toPtr);
Tcl_DecrRefCount(mPtr->namePtr);
@@ -777,7 +808,8 @@ TclOOUnknownDefinition(
}
hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (hPtr != NULL) {
- const char *nameStr = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
+ const char *nameStr = (const char *)
+ Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
if (strncmp(soughtStr, nameStr, soughtLen) == 0) {
if (matchedStr != NULL) {
@@ -921,7 +953,7 @@ InitDefineContext(
/*
* ----------------------------------------------------------------------
*
- * TclOOGetDefineCmdContext --
+ * TclOOGetDefineCmdContext, TclOOGetClassDefineCmdContext --
*
* Extracts the magic token from the current stack frame, or returns NULL
* (and leaves an error message) otherwise.
@@ -945,7 +977,7 @@ TclOOGetDefineCmdContext(
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
return NULL;
}
- object = (Tcl_Object)iPtr->varFramePtr->clientData;
+ object = (Tcl_Object) iPtr->varFramePtr->clientData;
if (Tcl_ObjectDeleted(object)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command cannot be called when the object has been"
@@ -955,6 +987,23 @@ TclOOGetDefineCmdContext(
}
return object;
}
+
+Class *
+TclOOGetClassDefineCmdContext(
+ Tcl_Interp *interp)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return NULL;
+ }
+ if (!oPtr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return NULL;
+ }
+ return oPtr->classPtr;
+}
/*
* ----------------------------------------------------------------------
@@ -1060,7 +1109,7 @@ GenerateErrorInfo(
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (in definition script for %s \"%.*s%s\" line %d)",
- typeOfSubject, (overflow ? limit : (int)length), objName,
+ typeOfSubject, (overflow ? limit : (int) length), objName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
@@ -1119,7 +1168,7 @@ MagicDefinitionInvoke(
Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
}
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
- /* TODO: overflow? */
+ // TODO: overflow?
Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
TclListObjGetElements(NULL, objPtr, &dummy, &objs);
@@ -1190,7 +1239,7 @@ TclOODefineObjCmd(
Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[2], 0,
- ((Interp *)interp)->cmdFramePtr, 2);
+ ((Interp *) interp)->cmdFramePtr, 2);
if (result == TCL_ERROR) {
GenerateErrorInfo(interp, oPtr, objNameObj, "class");
}
@@ -1259,7 +1308,7 @@ TclOOObjDefObjCmd(
Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[2], 0,
- ((Interp *)interp)->cmdFramePtr, 2);
+ ((Interp *) interp)->cmdFramePtr, 2);
if (result == TCL_ERROR) {
GenerateErrorInfo(interp, oPtr, objNameObj, "object");
}
@@ -1333,7 +1382,7 @@ TclOODefineSelfObjCmd(
Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[1], 0,
- ((Interp *)interp)->cmdFramePtr, 1);
+ ((Interp *) interp)->cmdFramePtr, 1);
if (result == TCL_ERROR) {
GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
}
@@ -1585,28 +1634,18 @@ TclOODefineConstructorObjCmd(
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr;
- Class *clsPtr;
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Method method;
Tcl_Size bodyLength;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
+ if (clsPtr == NULL) {
return TCL_ERROR;
- }
-
- /*
- * Extract and validate the context, which is the class that we wish to
- * modify.
- */
-
- oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- if (oPtr == NULL) {
+ } else if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
return TCL_ERROR;
}
- clsPtr = oPtr->classPtr;
- (void)TclGetStringFromObj(objv[2], &bodyLength);
+ (void) TclGetStringFromObj(objv[2], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
@@ -1660,21 +1699,13 @@ TclOODefineDefnNsObjCmd(
NULL
};
int kind = 0;
- Object *oPtr;
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Namespace *nsPtr;
Tcl_Obj *nsNamePtr, **storagePtr;
- oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
+ if (clsPtr == NULL) {
return TCL_ERROR;
- }
- if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) {
+ } else if (clsPtr->thisPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the definition namespace of the root classes",
-1));
@@ -1710,9 +1741,9 @@ TclOODefineDefnNsObjCmd(
*/
if (kind) {
- storagePtr = &oPtr->classPtr->objDefinitionNs;
+ storagePtr = &clsPtr->objDefinitionNs;
} else {
- storagePtr = &oPtr->classPtr->clsDefinitionNs;
+ storagePtr = &clsPtr->clsDefinitionNs;
}
if (*storagePtr != NULL) {
Tcl_DecrRefCount(*storagePtr);
@@ -1796,23 +1827,19 @@ TclOODefineDestructorObjCmd(
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr;
- Class *clsPtr;
Tcl_Method method;
Tcl_Size bodyLength;
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
- if (objc != 2) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "body");
return TCL_ERROR;
}
- oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
- (void)TclGetStringFromObj(objv[1], &bodyLength);
+ (void) TclGetStringFromObj(objv[1], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
@@ -1897,7 +1924,8 @@ TclOODefineExportObjCmd(
if (isInstanceExport) {
if (!oPtr->methodsPtr) {
- oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
+ oPtr->methodsPtr = (Tcl_HashTable *)
+ Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
@@ -1909,14 +1937,14 @@ TclOODefineExportObjCmd(
}
if (isNew) {
- mPtr = (Method *)Tcl_Alloc(sizeof(Method));
+ mPtr = (Method *) Tcl_Alloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = objv[i];
Tcl_IncrRefCount(objv[i]);
Tcl_SetHashValue(hPtr, mPtr);
} else {
- mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ mPtr = (Method *) Tcl_GetHashValue(hPtr);
}
if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
mPtr->flags |= PUBLIC_METHOD;
@@ -2210,7 +2238,8 @@ TclOODefineUnexportObjCmd(
if (isInstanceUnexport) {
if (!oPtr->methodsPtr) {
- oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
+ oPtr->methodsPtr = (Tcl_HashTable *)
+ Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
@@ -2222,14 +2251,14 @@ TclOODefineUnexportObjCmd(
}
if (isNew) {
- mPtr = (Method *)Tcl_Alloc(sizeof(Method));
+ mPtr = (Method *) Tcl_Alloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = objv[i];
Tcl_IncrRefCount(objv[i]);
Tcl_SetHashValue(hPtr, mPtr);
} else {
- mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ mPtr = (Method *) Tcl_GetHashValue(hPtr);
}
if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
@@ -2321,46 +2350,51 @@ int
TclOODefineSlots(
Foundation *fPtr)
{
- const struct DeclaredSlot *slotInfoPtr;
- Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
- Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
- Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1);
+ const DeclaredSlot *slotInfoPtr;
+ Tcl_Interp *interp = fPtr->interp;
+ Tcl_Obj *getName, *setName, *resolveName;
+ Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class)
+ fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0);
Class *slotCls;
- slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
- fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0))->classPtr;
+ if (object == NULL) {
+ return TCL_ERROR;
+ }
+ slotCls = ((Object *) object)->classPtr;
if (slotCls == NULL) {
return TCL_ERROR;
}
- Tcl_IncrRefCount(getName);
- Tcl_IncrRefCount(setName);
- Tcl_IncrRefCount(resolveName);
+
+ TclNewLiteralStringObj(getName, "Get");
+ TclNewLiteralStringObj(setName, "Set");
+ TclNewLiteralStringObj(resolveName, "Resolve");
for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
- Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
- (Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE, NULL, 0);
+ Tcl_Object slotObject = Tcl_NewObjectInstance(interp,
+ (Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE,
+ NULL, 0);
if (slotObject == NULL) {
continue;
}
- TclNewInstanceMethod(fPtr->interp, slotObject, getName, 0,
+ TclNewInstanceMethod(interp, slotObject, getName, 0,
&slotInfoPtr->getterType, NULL);
- TclNewInstanceMethod(fPtr->interp, slotObject, setName, 0,
+ TclNewInstanceMethod(interp, slotObject, setName, 0,
&slotInfoPtr->setterType, NULL);
if (slotInfoPtr->resolverType.callProc) {
- TclNewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
+ TclNewInstanceMethod(interp, slotObject, resolveName, 0,
&slotInfoPtr->resolverType, NULL);
}
}
- Tcl_DecrRefCount(getName);
- Tcl_DecrRefCount(setName);
- Tcl_DecrRefCount(resolveName);
+ Tcl_BounceRefCount(getName);
+ Tcl_BounceRefCount(setName);
+ Tcl_BounceRefCount(resolveName);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
- * ClassFilterGet, ClassFilterSet --
+ * ClassFilter_Get, ClassFilter_Set --
*
* Implementation of the "filter" slot accessors of the "oo::define"
* command.
@@ -2369,33 +2403,27 @@ TclOODefineSlots(
*/
static int
-ClassFilterGet(
+ClassFilter_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Obj *resultObj, *filterObj;
Tcl_Size i;
- if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- }
TclNewObj(resultObj);
- FOREACH(filterObj, oPtr->classPtr->filters) {
+ FOREACH(filterObj, clsPtr->filters) {
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
}
Tcl_SetObjResult(interp, resultObj);
@@ -2403,44 +2431,39 @@ ClassFilterGet(
}
static int
-ClassFilterSet(
+ClassFilter_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Size filterc;
Tcl_Obj **filterv;
- if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- } else if (TclListObjGetElements(interp, objv[0], &filterc,
+ if (TclListObjGetElements(interp, objv[0], &filterc,
&filterv) != TCL_OK) {
return TCL_ERROR;
}
- TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv);
+ TclOOClassSetFilters(interp, clsPtr, filterc, filterv);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
- * ClassMixinGet, ClassMixinSet --
+ * ClassMixin_Get, ClassMixin_Set --
*
* Implementation of the "mixin" slot accessors of the "oo::define"
* command.
@@ -2449,34 +2472,28 @@ ClassFilterSet(
*/
static int
-ClassMixinGet(
+ClassMixin_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Obj *resultObj;
Class *mixinPtr;
Tcl_Size i;
- if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- }
TclNewObj(resultObj);
- FOREACH(mixinPtr, oPtr->classPtr->mixins) {
+ FOREACH(mixinPtr, clsPtr->mixins) {
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, mixinPtr->thisPtr));
}
@@ -2486,14 +2503,14 @@ ClassMixinGet(
}
static int
-ClassMixinSet(
+ClassMixin_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Size mixinc, i;
Tcl_Obj **mixinv;
Class **mixins; /* The references to the classes to actually
@@ -2503,26 +2520,20 @@ ClassMixinSet(
* values and keys are always pointers. */
int isNew;
- if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- } else if (TclListObjGetElements(interp, objv[0], &mixinc,
- &mixinv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) {
return TCL_ERROR;
}
- mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
+ mixins = (Class **) TclStackAlloc(interp, sizeof(Class *) * mixinc);
Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);
for (i = 0; i < mixinc; i++) {
@@ -2539,7 +2550,7 @@ ClassMixinSet(
Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", (char *)NULL);
goto freeAndError;
}
- if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
+ if (TclOOIsReachable(clsPtr, mixins[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not mix a class into itself", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", (char *)NULL);
@@ -2547,7 +2558,7 @@ ClassMixinSet(
}
}
- TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
+ TclOOClassSetMixins(interp, clsPtr, mixinc, mixins);
Tcl_DeleteHashTable(&uniqueCheck);
TclStackFree(interp, mixins);
return TCL_OK;
@@ -2561,7 +2572,7 @@ ClassMixinSet(
/*
* ----------------------------------------------------------------------
*
- * ClassSuperGet, ClassSuperSet --
+ * ClassSuper_Get, ClassSuper_Set --
*
* Implementation of the "superclass" slot accessors of the "oo::define"
* command.
@@ -2570,34 +2581,28 @@ ClassMixinSet(
*/
static int
-ClassSuperGet(
+ClassSuper_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Obj *resultObj;
Class *superPtr;
Tcl_Size i;
- if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- }
TclNewObj(resultObj);
- FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ FOREACH(superPtr, clsPtr->superclasses) {
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, superPtr->thisPtr));
}
@@ -2606,34 +2611,30 @@ ClassSuperGet(
}
static int
-ClassSuperSet(
+ClassSuper_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Size superc, j;
Tcl_Size i;
Tcl_Obj **superv;
Class **superclasses, *superPtr;
- if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"superclassList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
+ Foundation *fPtr = clsPtr->thisPtr->fPtr;
+ if (clsPtr == fPtr->objectCls) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the superclass of the root object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
@@ -2657,11 +2658,11 @@ ClassSuperSet(
*/
if (superc == 0) {
- superclasses = (Class **)Tcl_Realloc(superclasses, sizeof(Class *));
- if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
- superclasses[0] = oPtr->fPtr->classCls;
+ superclasses = (Class **) Tcl_Realloc(superclasses, sizeof(Class *));
+ if (TclOOIsReachable(fPtr->classCls, clsPtr)) {
+ superclasses[0] = fPtr->classCls;
} else {
- superclasses[0] = oPtr->fPtr->objectCls;
+ superclasses[0] = fPtr->objectCls;
}
superc = 1;
AddRef(superclasses[0]->thisPtr);
@@ -2681,7 +2682,7 @@ ClassSuperSet(
goto failedAfterAlloc;
}
}
- if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
+ if (TclOOIsReachable(clsPtr, superclasses[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", (char *)NULL);
@@ -2709,19 +2710,19 @@ ClassSuperSet(
* subclass list.
*/
- if (oPtr->classPtr->superclasses.num != 0) {
- FOREACH(superPtr, oPtr->classPtr->superclasses) {
- TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+ if (clsPtr->superclasses.num != 0) {
+ FOREACH(superPtr, clsPtr->superclasses) {
+ TclOORemoveFromSubclasses(clsPtr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
- Tcl_Free(oPtr->classPtr->superclasses.list);
+ Tcl_Free(clsPtr->superclasses.list);
}
- oPtr->classPtr->superclasses.list = superclasses;
- oPtr->classPtr->superclasses.num = superc;
- FOREACH(superPtr, oPtr->classPtr->superclasses) {
- TclOOAddToSubclasses(oPtr->classPtr, superPtr);
+ clsPtr->superclasses.list = superclasses;
+ clsPtr->superclasses.num = superc;
+ FOREACH(superPtr, clsPtr->superclasses) {
+ TclOOAddToSubclasses(clsPtr, superPtr);
}
- BumpGlobalEpoch(interp, oPtr->classPtr);
+ BumpGlobalEpoch(interp, clsPtr);
return TCL_OK;
}
@@ -2729,7 +2730,7 @@ ClassSuperSet(
/*
* ----------------------------------------------------------------------
*
- * ClassVarsGet, ClassVarsSet --
+ * ClassVars_Get, ClassVars_Set --
*
* Implementation of the "variable" slot accessors of the "oo::define"
* command.
@@ -2738,42 +2739,36 @@ ClassSuperSet(
*/
static int
-ClassVarsGet(
+ClassVars_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Obj *resultObj;
Tcl_Size i;
- if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- }
TclNewObj(resultObj);
if (IsPrivateDefine(interp)) {
PrivateVariableMapping *privatePtr;
- FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) {
+ FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
}
} else {
Tcl_Obj *variableObj;
- FOREACH(variableObj, oPtr->classPtr->variables) {
+ FOREACH(variableObj, clsPtr->variables) {
Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
}
}
@@ -2782,34 +2777,28 @@ ClassVarsGet(
}
static int
-ClassVarsSet(
+ClassVars_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Size i;
Tcl_Size varc;
Tcl_Obj **varv;
- if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- } else if (TclListObjGetElements(interp, objv[0], &varc,
- &varv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
@@ -2833,10 +2822,10 @@ ClassVarsSet(
}
if (IsPrivateDefine(interp)) {
- InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables,
- varc, varv, oPtr->classPtr->thisPtr->creationEpoch);
+ InstallPrivateVariableMapping(&clsPtr->privateVariables,
+ varc, varv, clsPtr->thisPtr->creationEpoch);
} else {
- InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv);
+ InstallStandardVariableMapping(&clsPtr->variables, varc, varv);
}
return TCL_OK;
}
@@ -2844,7 +2833,7 @@ ClassVarsSet(
/*
* ----------------------------------------------------------------------
*
- * ObjectFilterGet, ObjectFilterSet --
+ * ObjFilter_Get, ObjFilter_Set --
*
* Implementation of the "filter" slot accessors of the "oo::objdefine"
* command.
@@ -2853,7 +2842,7 @@ ClassVarsSet(
*/
static int
-ObjFilterGet(
+ObjFilter_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
@@ -2881,7 +2870,7 @@ ObjFilterGet(
}
static int
-ObjFilterSet(
+ObjFilter_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
@@ -2900,8 +2889,7 @@ ObjFilterSet(
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (TclListObjGetElements(interp, objv[0], &filterc,
- &filterv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[0], &filterc, &filterv) != TCL_OK) {
return TCL_ERROR;
}
@@ -2912,7 +2900,7 @@ ObjFilterSet(
/*
* ----------------------------------------------------------------------
*
- * ObjectMixinGet, ObjectMixinSet --
+ * ObjMixin_Get, ObjMixin_Set --
*
* Implementation of the "mixin" slot accessors of the "oo::objdefine"
* command.
@@ -2921,7 +2909,7 @@ ObjFilterSet(
*/
static int
-ObjMixinGet(
+ObjMixin_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
@@ -2953,7 +2941,7 @@ ObjMixinGet(
}
static int
-ObjMixinSet(
+ObjMixin_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
@@ -2978,12 +2966,11 @@ ObjMixinSet(
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (TclListObjGetElements(interp, objv[0], &mixinc,
- &mixinv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) {
return TCL_ERROR;
}
- mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
+ mixins = (Class **) TclStackAlloc(interp, sizeof(Class *) * mixinc);
Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);
for (i = 0; i < mixinc; i++) {
@@ -3015,7 +3002,7 @@ ObjMixinSet(
/*
* ----------------------------------------------------------------------
*
- * ObjectVarsGet, ObjectVarsSet --
+ * ObjVars_Get, ObjVars_Set --
*
* Implementation of the "variable" slot accessors of the "oo::objdefine"
* command.
@@ -3024,7 +3011,7 @@ ObjMixinSet(
*/
static int
-ObjVarsGet(
+ObjVars_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
@@ -3062,7 +3049,7 @@ ObjVarsGet(
}
static int
-ObjVarsSet(
+ObjVars_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
@@ -3081,8 +3068,7 @@ ObjVarsSet(
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (TclListObjGetElements(interp, objv[0], &varc,
- &varv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
@@ -3170,7 +3156,8 @@ ResolveClass(
/*
* ----------------------------------------------------------------------
*
- * ClassRPropsGet, ClassRPropsSet, ObjRPropsGet, ObjRPropsSet --
+ * Configurable_ClassReadableProps_Get, Configurable_ClassReadableProps_Set,
+ * Configurable_ObjectReadableProps_Get, Configurable_ObjectReadableProps_Set --
*
* Implementations of the "readableproperties" slot accessors for classes
* and instances.
@@ -3178,135 +3165,60 @@ ResolveClass(
* ----------------------------------------------------------------------
*/
-static void
-InstallReadableProps(
- PropertyStorage *props,
- Tcl_Size objc,
- Tcl_Obj *const objv[])
-{
- Tcl_Obj *propObj;
- Tcl_Size i, n;
- int created;
- Tcl_HashTable uniqueTable;
-
- if (props->allReadableCache) {
- Tcl_DecrRefCount(props->allReadableCache);
- props->allReadableCache = NULL;
- }
-
- for (i=0 ; i<objc ; i++) {
- Tcl_IncrRefCount(objv[i]);
- }
- FOREACH(propObj, props->readable) {
- Tcl_DecrRefCount(propObj);
- }
- if (i != objc) {
- if (objc == 0) {
- Tcl_Free(props->readable.list);
- } else if (i) {
- props->readable.list = (Tcl_Obj **)Tcl_Realloc(props->readable.list,
- sizeof(Tcl_Obj *) * objc);
- } else {
- props->readable.list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * objc);
- }
- }
- props->readable.num = 0;
- if (objc > 0) {
- Tcl_InitObjHashTable(&uniqueTable);
- for (i=n=0 ; i<objc ; i++) {
- Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
- if (created) {
- props->readable.list[n++] = objv[i];
- } else {
- Tcl_DecrRefCount(objv[i]);
- }
- }
- props->readable.num = n;
-
- /*
- * Shouldn't be necessary, but maintain num/list invariant.
- */
-
- if (n != objc) {
- props->readable.list = (Tcl_Obj **)Tcl_Realloc(props->readable.list,
- sizeof(Tcl_Obj *) * n);
- }
- Tcl_DeleteHashTable(&uniqueTable);
- }
-}
-
static int
-ClassRPropsGet(
+Configurable_ClassReadableProps_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *resultObj, *propNameObj;
- int i;
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
- if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- }
- TclNewObj(resultObj);
- FOREACH(propNameObj, oPtr->classPtr->properties.readable) {
- Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
- }
- Tcl_SetObjResult(interp, resultObj);
+ Tcl_SetObjResult(interp, TclOOGetPropertyList(&clsPtr->properties.readable));
return TCL_OK;
}
static int
-ClassRPropsSet(
+Configurable_ClassReadableProps_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Size varc;
Tcl_Obj **varv;
- if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
- &varv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
- InstallReadableProps(&oPtr->classPtr->properties, varc, varv);
- BumpGlobalEpoch(interp, oPtr->classPtr);
+ TclOOInstallReadableProperties(&clsPtr->properties, varc, varv);
+ BumpGlobalEpoch(interp, clsPtr);
return TCL_OK;
}
static int
-ObjRPropsGet(
+Configurable_ObjectReadableProps_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
@@ -3314,28 +3226,21 @@ ObjRPropsGet(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *resultObj, *propNameObj;
- int i;
- if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- TclNewObj(resultObj);
- FOREACH(propNameObj, oPtr->properties.readable) {
- Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
- }
- Tcl_SetObjResult(interp, resultObj);
+ Tcl_SetObjResult(interp, TclOOGetPropertyList(&oPtr->properties.readable));
return TCL_OK;
}
static int
-ObjRPropsSet(
+Configurable_ObjectReadableProps_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
@@ -3355,19 +3260,20 @@ ObjRPropsSet(
if (oPtr == NULL) {
return TCL_ERROR;
- } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ } else if (TclListObjGetElements(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
- InstallReadableProps(&oPtr->properties, varc, varv);
+ TclOOInstallReadableProperties(&oPtr->properties, varc, varv);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
- * ClassWPropsGet, ClassWPropsSet, ObjWPropsGet, ObjWPropsSet --
+ * Configurable_ClassWritableProps_Get, Configurable_ClassWritableProps_Set,
+ * Configurable_ObjectWritableProps_Get, Configurable_ObjectWritableProps_Set --
*
* Implementations of the "writableproperties" slot accessors for classes
* and instances.
@@ -3375,135 +3281,60 @@ ObjRPropsSet(
* ----------------------------------------------------------------------
*/
-static void
-InstallWritableProps(
- PropertyStorage *props,
- Tcl_Size objc,
- Tcl_Obj *const objv[])
-{
- Tcl_Obj *propObj;
- Tcl_Size i, n;
- int created;
- Tcl_HashTable uniqueTable;
-
- if (props->allWritableCache) {
- Tcl_DecrRefCount(props->allWritableCache);
- props->allWritableCache = NULL;
- }
-
- for (i=0 ; i<objc ; i++) {
- Tcl_IncrRefCount(objv[i]);
- }
- FOREACH(propObj, props->writable) {
- Tcl_DecrRefCount(propObj);
- }
- if (i != objc) {
- if (objc == 0) {
- Tcl_Free(props->writable.list);
- } else if (i) {
- props->writable.list = (Tcl_Obj **)Tcl_Realloc(props->writable.list,
- sizeof(Tcl_Obj *) * objc);
- } else {
- props->writable.list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * objc);
- }
- }
- props->writable.num = 0;
- if (objc > 0) {
- Tcl_InitObjHashTable(&uniqueTable);
- for (i=n=0 ; i<objc ; i++) {
- Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
- if (created) {
- props->writable.list[n++] = objv[i];
- } else {
- Tcl_DecrRefCount(objv[i]);
- }
- }
- props->writable.num = n;
-
- /*
- * Shouldn't be necessary, but maintain num/list invariant.
- */
-
- if (n != objc) {
- props->writable.list = (Tcl_Obj **)Tcl_Realloc(props->writable.list,
- sizeof(Tcl_Obj *) * n);
- }
- Tcl_DeleteHashTable(&uniqueTable);
- }
-}
-
static int
-ClassWPropsGet(
+Configurable_ClassWritableProps_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *resultObj, *propNameObj;
- int i;
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
- if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- }
- TclNewObj(resultObj);
- FOREACH(propNameObj, oPtr->classPtr->properties.writable) {
- Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
- }
- Tcl_SetObjResult(interp, resultObj);
+ Tcl_SetObjResult(interp, TclOOGetPropertyList(&clsPtr->properties.writable));
return TCL_OK;
}
static int
-ClassWPropsSet(
+Configurable_ClassWritableProps_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
Tcl_Size varc;
Tcl_Obj **varv;
- if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"propertyList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (oPtr == NULL) {
- return TCL_ERROR;
- } else if (!oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
- return TCL_ERROR;
- } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
- &varv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
- InstallWritableProps(&oPtr->classPtr->properties, varc, varv);
- BumpGlobalEpoch(interp, oPtr->classPtr);
+ TclOOInstallWritableProperties(&clsPtr->properties, varc, varv);
+ BumpGlobalEpoch(interp, clsPtr);
return TCL_OK;
}
static int
-ObjWPropsGet(
+Configurable_ObjectWritableProps_Get(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
@@ -3511,28 +3342,21 @@ ObjWPropsGet(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *resultObj, *propNameObj;
- int i;
- if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- TclNewObj(resultObj);
- FOREACH(propNameObj, oPtr->properties.writable) {
- Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
- }
- Tcl_SetObjResult(interp, resultObj);
+ Tcl_SetObjResult(interp, TclOOGetPropertyList(&oPtr->properties.writable));
return TCL_OK;
}
static int
-ObjWPropsSet(
+Configurable_ObjectWritableProps_Set(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
@@ -3552,16 +3376,128 @@ ObjWPropsSet(
if (oPtr == NULL) {
return TCL_ERROR;
- } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ } else if (TclListObjGetElements(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
- InstallWritableProps(&oPtr->properties, varc, varv);
+ TclOOInstallWritableProperties(&oPtr->properties, varc, varv);
return TCL_OK;
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORegisterProperty, TclOORegisterInstanceProperty --
+ *
+ * Helpers to add or remove a name from the property slots of a class or
+ * instance.
+ *
+ * BuildPropertyList --
+ *
+ * Helper for the helpers. Scans a property list and does the filtering
+ * or adding of the property to add or remove
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+BuildPropertyList(
+ PropertyList *propsList, /* Property list to scan. */
+ Tcl_Obj *propName, /* Property to add/remove. */
+ int addingProp, /* True if we're adding, false if removing. */
+ Tcl_Obj *listObj) /* The list of property names we're building */
+{
+ int present = 0, changed = 0, i;
+ Tcl_Obj *other;
+
+ Tcl_SetListObj(listObj, 0, NULL);
+ FOREACH(other, *propsList) {
+ if (!TclStringCmp(propName, other, 1, 0, TCL_INDEX_NONE)) {
+ present = 1;
+ if (!addingProp) {
+ changed = 1;
+ continue;
+ }
+ }
+ Tcl_ListObjAppendElement(NULL, listObj, other);
+ }
+ if (!present && addingProp) {
+ Tcl_ListObjAppendElement(NULL, listObj, propName);
+ changed = 1;
+ }
+ return changed;
+}
+
+void
+TclOORegisterInstanceProperty(
+ Object *oPtr, /* Object that owns the property slots. */
+ Tcl_Obj *propName, /* Property to add/remove. Must include the
+ * hyphen if one is desired; this is the value
+ * that is actually placed in the slot. */
+ int registerReader, /* True if we're adding the property name to
+ * the readable property slot. False if we're
+ * removing the property name from the slot. */
+ int registerWriter) /* True if we're adding the property name to
+ * the writable property slot. False if we're
+ * removing the property name from the slot. */
+{
+ Tcl_Obj *listObj = Tcl_NewObj(); /* Working buffer. */
+ Tcl_Obj **objv;
+ Tcl_Size count;
+
+ if (BuildPropertyList(&oPtr->properties.readable, propName, registerReader,
+ listObj)) {
+ TclListObjGetElements(NULL, listObj, &count, &objv);
+ TclOOInstallReadableProperties(&oPtr->properties, count, objv);
+ }
+
+ if (BuildPropertyList(&oPtr->properties.writable, propName, registerWriter,
+ listObj)) {
+ TclListObjGetElements(NULL, listObj, &count, &objv);
+ TclOOInstallWritableProperties(&oPtr->properties, count, objv);
+ }
+ Tcl_BounceRefCount(listObj);
+}
+
+void
+TclOORegisterProperty(
+ Class *clsPtr, /* Class that owns the property slots. */
+ Tcl_Obj *propName, /* Property to add/remove. Must include the
+ * hyphen if one is desired; this is the value
+ * that is actually placed in the slot. */
+ int registerReader, /* True if we're adding the property name to
+ * the readable property slot. False if we're
+ * removing the property name from the slot. */
+ int registerWriter) /* True if we're adding the property name to
+ * the writable property slot. False if we're
+ * removing the property name from the slot. */
+{
+ Tcl_Obj *listObj = Tcl_NewObj(); /* Working buffer. */
+ Tcl_Obj **objv;
+ Tcl_Size count;
+ int changed = 0;
+
+ if (BuildPropertyList(&clsPtr->properties.readable, propName,
+ registerReader, listObj)) {
+ TclListObjGetElements(NULL, listObj, &count, &objv);
+ TclOOInstallReadableProperties(&clsPtr->properties, count, objv);
+ changed = 1;
+ }
+
+ if (BuildPropertyList(&clsPtr->properties.writable, propName,
+ registerWriter, listObj)) {
+ TclListObjGetElements(NULL, listObj, &count, &objv);
+ TclOOInstallWritableProperties(&clsPtr->properties, count, objv);
+ changed = 1;
+ }
+ Tcl_BounceRefCount(listObj);
+ if (changed) {
+ BumpGlobalEpoch(clsPtr->thisPtr->fPtr->interp, clsPtr);
+ }
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index f8b7ddd..914ed38 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -16,8 +16,6 @@
#include "tclInt.h"
#include "tclOOInt.h"
-static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
-static void SortPropList(Tcl_Obj *list);
static Tcl_ObjCmdProc InfoObjectCallCmd;
static Tcl_ObjCmdProc InfoObjectClassCmd;
static Tcl_ObjCmdProc InfoObjectDefnCmd;
@@ -29,7 +27,6 @@ static Tcl_ObjCmdProc InfoObjectMethodsCmd;
static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
static Tcl_ObjCmdProc InfoObjectMixinsCmd;
static Tcl_ObjCmdProc InfoObjectNsCmd;
-static Tcl_ObjCmdProc InfoObjectPropCmd;
static Tcl_ObjCmdProc InfoObjectVarsCmd;
static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassCallCmd;
@@ -43,7 +40,6 @@ static Tcl_ObjCmdProc InfoClassInstancesCmd;
static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
-static Tcl_ObjCmdProc InfoClassPropCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;
@@ -64,7 +60,7 @@ static const EnsembleImplMap infoObjectCmds[] = {
{"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
- {"properties", InfoObjectPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"properties", TclOOInfoObjectPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
@@ -86,7 +82,7 @@ static const EnsembleImplMap infoClassCmds[] = {
{"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"properties", InfoClassPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"properties", TclOOInfoClassPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
@@ -96,6 +92,23 @@ static const EnsembleImplMap infoClassCmds[] = {
/*
* ----------------------------------------------------------------------
*
+ * LocalVarName --
+ *
+ * Get the name of a local variable (especially a method argument) as a
+ * Tcl value.
+ *
+ * ----------------------------------------------------------------------
+ */
+static inline Tcl_Obj *
+LocalVarName(
+ CompiledLocal *localPtr)
+{
+ return Tcl_NewStringObj(localPtr->name, TCL_AUTO_LENGTH);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOOInitInfo --
*
* Adjusts the Tcl core [info] command to contain subcommands ("object"
@@ -134,7 +147,7 @@ TclOOInitInfo(
/*
* ----------------------------------------------------------------------
*
- * GetClassFromObj --
+ * TclOOGetClassFromObj --
*
* How to correctly get a class from a Tcl_Obj. Just a wrapper round
* Tcl_GetObjectFromObj, but this is an idiom that was used heavily.
@@ -142,8 +155,8 @@ TclOOInitInfo(
* ----------------------------------------------------------------------
*/
-static inline Class *
-GetClassFromObj(
+Class *
+TclOOGetClassFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
@@ -199,7 +212,7 @@ InfoObjectClassCmd(
Class *mixinPtr, *o2clsPtr;
Tcl_Size i;
- o2clsPtr = GetClassFromObj(interp, objv[2]);
+ o2clsPtr = TclOOGetClassFromObj(interp, objv[2]);
if (o2clsPtr == NULL) {
return TCL_ERROR;
}
@@ -257,22 +270,17 @@ InfoObjectDefnCmd(
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
- unknownMethod:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "unknown method \"%s\"", TclGetString(objv[2])));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), (char *)NULL);
- return TCL_ERROR;
+ goto unknownMethod;
}
- procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
+ procPtr = TclOOGetProcFromMethod((Method *) Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "definition not available for this kind of method", -1));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), (char *)NULL);
- return TCL_ERROR;
+ goto wrongType;
}
+ /*
+ * We now have the method to describe the definition of.
+ */
+
TclNewObj(resultObjs[0]);
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
@@ -280,17 +288,34 @@ InfoObjectDefnCmd(
Tcl_Obj *argObj;
TclNewObj(argObj);
- Tcl_ListObjAppendElement(NULL, argObj,
- Tcl_NewStringObj(localPtr->name, -1));
+ Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
- resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));
+ resultObjs[1] = TclOOGetMethodBody((Method *) Tcl_GetHashValue(hPtr));
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
+
+ /*
+ * Errors...
+ */
+
+ unknownMethod:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), (char *)NULL);
+ return TCL_ERROR;
+
+ wrongType:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), (char *)NULL);
+ return TCL_ERROR;
}
/*
@@ -368,25 +393,38 @@ InfoObjectForwardCmd(
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
- unknownMethod:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "unknown method \"%s\"", TclGetString(objv[2])));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), (char *)NULL);
- return TCL_ERROR;
+ goto unknownMethod;
}
- prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr));
+ prefixObj = TclOOGetFwdFromMethod((Method *) Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "prefix argument list not available for this kind of method",
- -1));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), (char *)NULL);
- return TCL_ERROR;
+ goto wrongType;
}
+ /*
+ * Describe the valid forward method.
+ */
+
Tcl_SetObjResult(interp, prefixObj);
return TCL_OK;
+
+ /*
+ * Errors...
+ */
+
+ unknownMethod:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), (char *)NULL);
+ return TCL_ERROR;
+
+ wrongType:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "prefix argument list not available for this kind of method",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), (char *)NULL);
+ return TCL_ERROR;
}
/*
@@ -545,6 +583,10 @@ InfoObjectMethodsCmd(
SCOPE_LOCALPRIVATE
};
+ /*
+ * Parse arguments.
+ */
+
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "objName ?-option value ...?");
return TCL_ERROR;
@@ -605,6 +647,10 @@ InfoObjectMethodsCmd(
}
}
+ /*
+ * List matching methods.
+ */
+
TclNewObj(resultObj);
if (recurse) {
const char **names;
@@ -616,7 +662,7 @@ InfoObjectMethodsCmd(
Tcl_NewStringObj(names[i], -1));
}
if (numNames > 0) {
- Tcl_Free((void *)names);
+ Tcl_Free((void *) names);
}
} else if (oPtr->methodsPtr) {
if (scope == -1) {
@@ -678,14 +724,9 @@ InfoObjectMethodTypeCmd(
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
- unknownMethod:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "unknown method \"%s\"", TclGetString(objv[2])));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), (char *)NULL);
- return TCL_ERROR;
+ goto unknownMethod;
}
- mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
@@ -697,6 +738,13 @@ InfoObjectMethodTypeCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1));
return TCL_OK;
+
+ unknownMethod:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), (char *)NULL);
+ return TCL_ERROR;
}
/*
@@ -835,6 +883,10 @@ InfoObjectVariablesCmd(
}
if (objc == 3) {
if (strcmp("-private", TclGetString(objv[2])) != 0) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "option \"%s\" is not exactly \"-private\"",
+ TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_ARG");
return TCL_ERROR;
}
isPrivate = 1;
@@ -949,7 +1001,7 @@ InfoClassConstrCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -971,8 +1023,7 @@ InfoClassConstrCmd(
Tcl_Obj *argObj;
TclNewObj(argObj);
- Tcl_ListObjAppendElement(NULL, argObj,
- Tcl_NewStringObj(localPtr->name, -1));
+ Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
@@ -1011,7 +1062,7 @@ InfoClassDefnCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1023,7 +1074,7 @@ InfoClassDefnCmd(
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
- procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
+ procPtr = TclOOGetProcFromMethod((Method *) Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
@@ -1039,15 +1090,14 @@ InfoClassDefnCmd(
Tcl_Obj *argObj;
TclNewObj(argObj);
- Tcl_ListObjAppendElement(NULL, argObj,
- Tcl_NewStringObj(localPtr->name, -1));
+ Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
- resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));
+ resultObjs[1] = TclOOGetMethodBody((Method *) Tcl_GetHashValue(hPtr));
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
@@ -1082,7 +1132,7 @@ InfoClassDefnNsCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1126,7 +1176,7 @@ InfoClassDestrCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1171,7 +1221,7 @@ InfoClassFiltersCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1209,7 +1259,7 @@ InfoClassForwardCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1221,7 +1271,7 @@ InfoClassForwardCmd(
TclGetString(objv[2]), (char *)NULL);
return TCL_ERROR;
}
- prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr));
+ prefixObj = TclOOGetFwdFromMethod((Method *) Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
@@ -1262,7 +1312,7 @@ InfoClassInstancesCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1321,7 +1371,7 @@ InfoClassMethodsCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1384,7 +1434,7 @@ InfoClassMethodsCmd(
Tcl_NewStringObj(names[i], -1));
}
if (numNames > 0) {
- Tcl_Free((void *)names);
+ Tcl_Free((void *) names);
}
} else {
FOREACH_HASH_DECLS;
@@ -1437,21 +1487,16 @@ InfoClassMethodTypeCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]);
if (hPtr == NULL) {
- unknownMethod:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "unknown method \"%s\"", TclGetString(objv[2])));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), (char *)NULL);
- return TCL_ERROR;
+ goto unknownMethod;
}
- mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
@@ -1462,6 +1507,13 @@ InfoClassMethodTypeCmd(
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1));
return TCL_OK;
+
+ unknownMethod:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), (char *)NULL);
+ return TCL_ERROR;
}
/*
@@ -1489,7 +1541,7 @@ InfoClassMixinsCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1532,7 +1584,7 @@ InfoClassSubsCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1586,7 +1638,7 @@ InfoClassSupersCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1628,11 +1680,15 @@ InfoClassVariablesCmd(
}
if (objc == 3) {
if (strcmp("-private", TclGetString(objv[2])) != 0) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "option \"%s\" is not exactly \"-private\"",
+ TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_ARG");
return TCL_ERROR;
}
isPrivate = 1;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1693,6 +1749,7 @@ InfoObjectCallCmd(
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot construct any call chain", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_CALL_CHAIN");
return TCL_ERROR;
}
Tcl_SetObjResult(interp,
@@ -1725,7 +1782,7 @@ InfoClassCallCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
- clsPtr = GetClassFromObj(interp, objv[1]);
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
@@ -1738,6 +1795,7 @@ InfoClassCallCmd(
if (callPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot construct any call chain", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_CALL_CHAIN");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
@@ -1746,184 +1804,6 @@ InfoClassCallCmd(
}
/*
- * ----------------------------------------------------------------------
- *
- * InfoClassPropCmd, InfoObjectPropCmd --
- *
- * Implements [info class properties $clsName ?$option...?] and
- * [info object properties $objName ?$option...?]
- *
- * ----------------------------------------------------------------------
- */
-
-enum PropOpt {
- PROP_ALL, PROP_READABLE, PROP_WRITABLE
-};
-static const char *const propOptNames[] = {
- "-all", "-readable", "-writable",
- NULL
-};
-
-static int
-InfoClassPropCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Class *clsPtr;
- int i, idx, all = 0, writable = 0, allocated = 0;
- Tcl_Obj *result, *propObj;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
- return TCL_ERROR;
- }
- clsPtr = GetClassFromObj(interp, objv[1]);
- if (clsPtr == NULL) {
- return TCL_ERROR;
- }
- for (i = 2; i < objc; i++) {
- if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
- &idx) != TCL_OK) {
- return TCL_ERROR;
- }
- switch (idx) {
- case PROP_ALL:
- all = 1;
- break;
- case PROP_READABLE:
- writable = 0;
- break;
- case PROP_WRITABLE:
- writable = 1;
- break;
- }
- }
-
- /*
- * Get the properties.
- */
-
- if (all) {
- result = TclOOGetAllClassProperties(clsPtr, writable, &allocated);
- if (allocated) {
- SortPropList(result);
- }
- } else {
- TclNewObj(result);
- if (writable) {
- FOREACH(propObj, clsPtr->properties.writable) {
- Tcl_ListObjAppendElement(NULL, result, propObj);
- }
- } else {
- FOREACH(propObj, clsPtr->properties.readable) {
- Tcl_ListObjAppendElement(NULL, result, propObj);
- }
- }
- SortPropList(result);
- }
- Tcl_SetObjResult(interp, result);
- return TCL_OK;
-}
-
-static int
-InfoObjectPropCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Object *oPtr;
- int i, idx, all = 0, writable = 0, allocated = 0;
- Tcl_Obj *result, *propObj;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
- return TCL_ERROR;
- }
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- for (i = 2; i < objc; i++) {
- if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
- &idx) != TCL_OK) {
- return TCL_ERROR;
- }
- switch (idx) {
- case PROP_ALL:
- all = 1;
- break;
- case PROP_READABLE:
- writable = 0;
- break;
- case PROP_WRITABLE:
- writable = 1;
- break;
- }
- }
-
- /*
- * Get the properties.
- */
-
- if (all) {
- result = TclOOGetAllObjectProperties(oPtr, writable, &allocated);
- if (allocated) {
- SortPropList(result);
- }
- } else {
- TclNewObj(result);
- if (writable) {
- FOREACH(propObj, oPtr->properties.writable) {
- Tcl_ListObjAppendElement(NULL, result, propObj);
- }
- } else {
- FOREACH(propObj, oPtr->properties.readable) {
- Tcl_ListObjAppendElement(NULL, result, propObj);
- }
- }
- SortPropList(result);
- }
- Tcl_SetObjResult(interp, result);
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * SortPropList --
- * Sort a list of names of properties. Simple support function. Assumes
- * that the list Tcl_Obj is unshared and doesn't have a string
- * representation.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-PropNameCompare(
- const void *a,
- const void *b)
-{
- Tcl_Obj *first = *(Tcl_Obj **) a;
- Tcl_Obj *second = *(Tcl_Obj **) b;
-
- return strcmp(TclGetString(first), TclGetString(second));
-}
-
-static void
-SortPropList(
- Tcl_Obj *list)
-{
- Tcl_Size ec;
- Tcl_Obj **ev;
-
- Tcl_ListObjGetElements(NULL, list, &ec, &ev);
- qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare);
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index b5d1296..3ef395c 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -30,35 +30,45 @@
* Forward declarations.
*/
-struct CallChain;
-struct Class;
-struct Foundation;
-struct Object;
+typedef struct CallChain CallChain;
+typedef struct CallContext CallContext;
+typedef struct Class Class;
+typedef struct DeclaredClassMethod DeclaredClassMethod;
+typedef struct ForwardMethod ForwardMethod;
+typedef struct Foundation Foundation;
+typedef struct Method Method;
+typedef struct MInvoke MInvoke;
+typedef struct Object Object;
+typedef struct PrivateVariableMapping PrivateVariableMapping;
+typedef struct ProcedureMethod ProcedureMethod;
+typedef struct PropertyStorage PropertyStorage;
/*
* The data that needs to be stored per method. This record is used to collect
* information about all sorts of methods, including forwards, constructors
* and destructors.
*/
-
-typedef struct Method {
- const Tcl_MethodType *typePtr;
- /* The type of method. If NULL, this is a
+struct Method {
+ union {
+ const Tcl_MethodType *typePtr;
+ const Tcl_MethodType2 *type2Ptr;
+ }; /* The type of method. If NULL, this is a
* special flag record which is just used for
- * the setting of the flags field. */
+ * the setting of the flags field. Note that
+ * this is a union of two pointer types that
+ * have the same layout at least as far as the
+ * internal version field. */
Tcl_Size refCount;
- void *clientData; /* Type-specific data. */
+ void *clientData; /* Type-specific data. */
Tcl_Obj *namePtr; /* Name of the method. */
- struct Object *declaringObjectPtr;
- /* The object that declares this method, or
+ Object *declaringObjectPtr; /* The object that declares this method, or
* NULL if it was declared by a class. */
- struct Class *declaringClassPtr;
- /* The class that declares this method, or
+ Class *declaringClassPtr; /* The class that declares this method, or
* NULL if it was declared directly on an
* object. */
int flags; /* Assorted flags. Includes whether this
* method is public/exported or not. */
-} Method;
+};
/*
* Pre- and post-call callbacks, to allow procedure-like methods to be fine
@@ -75,10 +85,9 @@ typedef void *(TclOO_PmCDCloneProc)(void *clientData);
/*
* Procedure-like methods have the following extra information.
*/
-
-typedef struct ProcedureMethod {
+struct ProcedureMethod {
int version; /* Version of this structure. Currently must
- * be 0. */
+ * be TCLOO_PROCEDURE_METHOD_VERSION_1. */
Proc *procPtr; /* Core of the implementation of the method;
* includes the argument definition and the
* body bytecodes. */
@@ -107,44 +116,47 @@ typedef struct ProcedureMethod {
* destructor, which we can't know until then
* for messy reasons. Other flags are variable
* but not used. */
-} ProcedureMethod;
+};
-#define TCLOO_PROCEDURE_METHOD_VERSION 0
+enum ProcedureMethodVersion {
+ TCLOO_PROCEDURE_METHOD_VERSION_1 = 0
+};
+#define TCLOO_PROCEDURE_METHOD_VERSION TCLOO_PROCEDURE_METHOD_VERSION_1
/*
* Flags for use in a ProcedureMethod.
*
- * When the USE_DECLARER_NS flag is set, the method will use the namespace of
- * the object or class that declared it (or the clone of it, if it was from
- * such that the implementation of the method came to the particular use)
- * instead of the namespace of the object on which the method was invoked.
- * This flag must be distinct from all others that are associated with
- * methods.
*/
-
-#define USE_DECLARER_NS 0x80
+enum ProceudreMethodFlags {
+ USE_DECLARER_NS = 0x80 /* When set, the method will use the namespace
+ * of the object or class that declared it (or
+ * the clone of it, if it was from such that
+ * the implementation of the method came to the
+ * particular use) instead of the namespace of
+ * the object on which the method was invoked.
+ * This flag must be distinct from all others
+ * that are associated with methods. */
+};
/*
* Forwarded methods have the following extra information.
*/
-
-typedef struct ForwardMethod {
+struct ForwardMethod {
Tcl_Obj *prefixObj; /* The list of values to use to replace the
* object and method name with. Will be a
* non-empty list. */
-} ForwardMethod;
+};
/*
* Structure used in private variable mappings. Describes the mapping of a
* single variable from the user's local name to the system's storage name.
* [TIP #500]
*/
-
-typedef struct {
+struct PrivateVariableMapping {
Tcl_Obj *variableObj; /* Name used within methods. This is the part
* that is properly under user control. */
Tcl_Obj *fullNameObj; /* Name used at the instance namespace level. */
-} PrivateVariableMapping;
+};
/*
* Helper definitions that declare a "list" array. The two varieties are
@@ -167,18 +179,21 @@ typedef struct {
* These types are needed in function arguments.
*/
+typedef LIST_STATIC(Class *) ClassList;
+typedef LIST_DYNAMIC(Class *) VarClassList;
+typedef LIST_STATIC(Tcl_Obj *) FilterList;
+typedef LIST_DYNAMIC(Object *) ObjectList;
typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
+typedef LIST_STATIC(Tcl_Obj *) PropertyList;
/*
- * This type is used in various places.
+ * This type is used in various places. It holds the parts of an object or
+ * class relating to property information.
*/
-
-typedef struct {
- LIST_STATIC(Tcl_Obj *) readable;
- /* The readable properties slot. */
- LIST_STATIC(Tcl_Obj *) writable;
- /* The writable properties slot. */
+struct PropertyStorage {
+ PropertyList readable; /* The readable properties slot. */
+ PropertyList writable; /* The writable properties slot. */
Tcl_Obj *allReadableCache; /* The cache of all readable properties
* exposed by this object or class (in its
* stereotypical instancs). Contains a sorted
@@ -188,40 +203,36 @@ typedef struct {
* stereotypical instances). Contains a sorted
* unique list if not NULL. */
int epoch; /* The epoch that the caches are valid for. */
-} PropertyStorage;
+};
/*
* Now, the definition of what an object actually is.
*/
-typedef struct Object {
- struct Foundation *fPtr; /* The basis for the object system. Putting
- * this here allows the avoidance of quite a
- * lot of hash lookups on the critical path
- * for object invocation and creation. */
+struct Object {
+ Foundation *fPtr; /* The basis for the object system, which is
+ * conceptually part of the interpreter. */
Tcl_Namespace *namespacePtr;/* This object's namespace. */
Tcl_Command command; /* Reference to this object's public
* command. */
Tcl_Command myCommand; /* Reference to this object's internal
* command. */
- struct Class *selfCls; /* This object's class. */
+ Class *selfCls; /* This object's class. */
Tcl_HashTable *methodsPtr; /* Object-local Tcl_Obj (method name) to
* Method* mapping. */
- LIST_STATIC(struct Class *) mixins;
- /* Classes mixed into this object. */
- LIST_STATIC(Tcl_Obj *) filters;
- /* List of filter names. */
- struct Class *classPtr; /* This is non-NULL for all classes, and NULL
+ ClassList mixins; /* Classes mixed into this object. */
+ FilterList filters; /* List of filter names. */
+ Class *classPtr; /* This is non-NULL for all classes, and NULL
* for everything else. It points to the class
* structure. */
Tcl_Size refCount; /* Number of strong references to this object.
* Note that there may be many more weak
* references; this mechanism exists to
* avoid Tcl_Preserve. */
- int flags;
- Tcl_Size creationEpoch; /* Unique value to make comparisons of objects
+ int flags; /* See ObjectFlags. */
+ Tcl_Size creationEpoch; /* Unique value to make comparisons of objects
* easier. */
- Tcl_Size epoch; /* Per-object epoch, incremented when the way
+ Tcl_Size epoch; /* Per-object epoch, incremented when the way
* an object should resolve call chains is
* changed. */
Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
@@ -244,67 +255,62 @@ typedef struct Object {
PropertyStorage properties; /* Information relating to the lists of
* properties that this object *claims* to
* support. */
-} Object;
+};
-#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has
+enum ObjectFlags {
+ OBJECT_DESTRUCTING = 1, /* Indicates that an object is being or has
* been destroyed */
-#define DESTRUCTOR_CALLED 2 /* Indicates that evaluation of destructor
+ DESTRUCTOR_CALLED = 2, /* Indicates that evaluation of destructor
* script for the object has began */
-#define OO_UNUSED_4 4 /* No longer used. */
-#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
+ ROOT_OBJECT = 0x1000, /* Flag to say that this object is the root of
* the class hierarchy and should be treated
* specially during teardown. */
-#define FILTER_HANDLING 0x2000 /* Flag set when the object is processing a
+ FILTER_HANDLING = 0x2000, /* Flag set when the object is processing a
* filter; when set, filters are *not*
* processed on the object, preventing nasty
* recursive filtering problems. */
-#define USE_CLASS_CACHE 0x4000 /* Flag set to say that the object is a pure
+ USE_CLASS_CACHE = 0x4000, /* Flag set to say that the object is a pure
* instance of the class, and has had nothing
* added that changes the dispatch chain (i.e.
* no methods, mixins, or filters. */
-#define ROOT_CLASS 0x8000 /* Flag to say that this object is the root
+ ROOT_CLASS = 0x8000, /* Flag to say that this object is the root
* class of classes, and should be treated
* specially during teardown (and in a few
* other spots). */
-#define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the
+ FORCE_UNKNOWN = 0x10000, /* States that we are *really* looking up the
* unknown method handler at that point. */
-#define DONT_DELETE 0x20000 /* Inhibit deletion of this object. Used
+ DONT_DELETE = 0x20000, /* Inhibit deletion of this object. Used
* during fundamental object type mutation to
* make sure that the object actually survives
* to the end of the operation. */
-#define HAS_PRIVATE_METHODS 0x40000
+ HAS_PRIVATE_METHODS = 0x40000
/* Object/class has (or had) private methods,
* and so shouldn't be cached so
* aggressively. */
+};
/*
* And the definition of a class. Note that every class also has an associated
* object, through which it is manipulated.
*/
-typedef struct Class {
+struct Class {
Object *thisPtr; /* Reference to the object associated with
* this class. */
int flags; /* Assorted flags. */
- LIST_STATIC(struct Class *) superclasses;
- /* List of superclasses, used for generation
+ ClassList superclasses; /* List of superclasses, used for generation
* of method call chains. */
- LIST_DYNAMIC(struct Class *) subclasses;
- /* List of subclasses, used to ensure deletion
+ VarClassList subclasses; /* List of subclasses, used to ensure deletion
* of dependent entities happens properly when
* the class itself is deleted. */
- LIST_DYNAMIC(Object *) instances;
- /* List of instances, used to ensure deletion
+ ObjectList instances; /* List of instances, used to ensure deletion
* of dependent entities happens properly when
* the class itself is deleted. */
- LIST_STATIC(Tcl_Obj *) filters;
- /* List of filter names, used for generation
+ FilterList filters; /* List of filter names, used for generation
* of method call chains. */
- LIST_STATIC(struct Class *) mixins;
- /* List of mixin classes, used for generation
+ ClassList mixins; /* List of mixin classes, used for generation
* of method call chains. */
- LIST_DYNAMIC(struct Class *) mixinSubs;
- /* List of classes that this class is mixed
+ VarClassList mixinSubs; /* List of classes that this class is mixed
* into, used to ensure deletion of dependent
* entities happens properly when the class
* itself is deleted. */
@@ -320,8 +326,8 @@ typedef struct Class {
* of each piece of attached metadata. This
* field starts out as NULL and is only
* allocated if metadata is attached. */
- struct CallChain *constructorChainPtr;
- struct CallChain *destructorChainPtr;
+ CallChain *constructorChainPtr;
+ CallChain *destructorChainPtr;
Tcl_HashTable *classChainCache;
/* Places where call chains are stored. For
* constructors, the class chain is always
@@ -355,15 +361,12 @@ typedef struct Class {
PropertyStorage properties; /* Information relating to the lists of
* properties that this class *claims* to
* support. */
-} Class;
+};
/*
- * The foundation of the object system within an interpreter contains
- * references to the key classes and namespaces, together with a few other
- * useful bits and pieces. Probably ought to eventually go in the Interp
- * structure itself.
+ * Master epoch counter for making unique IDs for objects that can be compared
+ * cheaply.
*/
-
typedef struct ThreadLocalData {
Tcl_Size nsCount; /* Epoch counter is used for keeping
* the values used in Tcl_Obj internal
@@ -373,19 +376,17 @@ typedef struct ThreadLocalData {
* generally cross threads). */
} ThreadLocalData;
-typedef struct Foundation {
- Tcl_Interp *interp;
+/*
+ * The foundation of the object system within an interpreter contains
+ * references to the key classes and namespaces, together with a few other
+ * useful bits and pieces. Probably ought to eventually go in the Interp
+ * structure itself.
+ */
+struct Foundation {
+ Tcl_Interp *interp; /* The interpreter this is attached to. */
Class *objectCls; /* The root of the object system. */
Class *classCls; /* The class of all classes. */
Tcl_Namespace *ooNs; /* ::oo namespace. */
- Tcl_Namespace *defineNs; /* Namespace containing special commands for
- * manipulating objects and classes. The
- * "oo::define" command acts as a special kind
- * of ensemble for this namespace. */
- Tcl_Namespace *objdefNs; /* Namespace containing special commands for
- * manipulating objects and classes. The
- * "oo::objdefine" command acts as a special
- * kind of ensemble for this namespace. */
Tcl_Namespace *helpersNs; /* Namespace containing the commands that are
* only valid when executing inside a
* procedural method. */
@@ -403,17 +404,19 @@ typedef struct Foundation {
Tcl_Obj *clonedName; /* Shared object containing the name of a
* "<cloned>" pseudo-constructor. */
Tcl_Obj *defineName; /* Fully qualified name of oo::define. */
-} Foundation;
+ Tcl_Obj *myName; /* The "my" shared object. */
+};
/*
- * A call context structure is built when a method is called. It contains the
- * chain of method implementations that are to be invoked by a particular
- * call, and the process of calling walks the chain, with the [next] command
- * proceeding to the next entry in the chain.
+ * The number of MInvoke records in the CallChain before we allocate
+ * separately.
*/
-
#define CALL_CHAIN_STATIC_SIZE 4
+/*
+ * Information relating to the invocation of a particular method implementation
+ * in a call chain.
+ */
struct MInvoke {
Method *mPtr; /* Reference to the method implementation
* record. */
@@ -422,7 +425,10 @@ struct MInvoke {
* NULL, it was added by the object. */
};
-typedef struct CallChain {
+/*
+ * The cacheable part of a call context.
+ */
+struct CallChain {
Tcl_Size objectCreationEpoch;/* The object's creation epoch. Note that the
* object reference is not stored in the call
* chain; it is in the call context. */
@@ -433,13 +439,19 @@ typedef struct CallChain {
int flags; /* Assorted flags, see below. */
Tcl_Size refCount; /* Reference count. */
Tcl_Size numChain; /* Size of the call chain. */
- struct MInvoke *chain; /* Array of call chain entries. May point to
+ MInvoke *chain; /* Array of call chain entries. May point to
* staticChain if the number of entries is
* small. */
- struct MInvoke staticChain[CALL_CHAIN_STATIC_SIZE];
-} CallChain;
+ MInvoke staticChain[CALL_CHAIN_STATIC_SIZE];
+};
-typedef struct CallContext {
+/*
+ * A call context structure is built when a method is called. It contains the
+ * chain of method implementations that are to be invoked by a particular
+ * call, and the process of calling walks the chain, with the [next] command
+ * proceeding to the next entry in the chain.
+ */
+struct CallContext {
Object *oPtr; /* The object associated with this call. */
Tcl_Size index; /* Index into the call chain of the currently
* executing method implementation. */
@@ -448,33 +460,32 @@ typedef struct CallContext {
* method call or a continuation via the
* [next] command. */
CallChain *callPtr; /* The actual call chain. */
-} CallContext;
+};
/*
* Bits for the 'flags' field of the call chain.
*/
-
-#define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */
-#define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances
+enum TclOOCallChainFlags {
+ PUBLIC_METHOD = 0x01, /* This is a public (exported) method. */
+ PRIVATE_METHOD = 0x02, /* This is a private (class's direct instances
* only) method. Supports itcl. */
-#define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */
-#define CONSTRUCTOR 0x08 /* This is a constructor. */
-#define DESTRUCTOR 0x10 /* This is a destructor. */
-#define TRUE_PRIVATE_METHOD 0x20
- /* This is a private method only accessible
+ OO_UNKNOWN_METHOD = 0x04, /* This is an unknown method. */
+ CONSTRUCTOR = 0x08, /* This is a constructor. */
+ DESTRUCTOR = 0x10, /* This is a destructor. */
+ TRUE_PRIVATE_METHOD = 0x20 /* This is a private method only accessible
* from other methods defined on this class
* or instance. [TIP #500] */
+};
#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD)
/*
* Structure containing definition information about basic class methods.
*/
-
-typedef struct {
+struct DeclaredClassMethod {
const char *name; /* Name of the method in question. */
int isPublic; /* Whether the method is public by default. */
Tcl_MethodType definition; /* How to call the method. */
-} DeclaredClassMethod;
+};
/*
*----------------------------------------------------------------
@@ -482,7 +493,7 @@ typedef struct {
*----------------------------------------------------------------
*/
-MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
+MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd;
@@ -498,11 +509,14 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePropertyCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition;
MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOInfoObjectPropCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOInfoClassPropCmd;
/*
* Method implementations (in tclOOBasic.c).
@@ -517,6 +531,7 @@ MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Eval;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_LinkVar;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Unknown;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_VarName;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Configurable_Configure;
/*
* Private definitions, some of which perhaps ought to be exposed properly or
@@ -528,14 +543,14 @@ MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp,
Object *useThisObj);
-MODULE_SCOPE int TclMethodIsType(Tcl_Method method,
+MODULE_SCOPE int TclMethodIsType(Tcl_Method method,
const Tcl_MethodType *typePtr,
void **clientDataPtr);
MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp,
Tcl_Object object, Tcl_Obj *nameObj,
int flags, const Tcl_MethodType *typePtr,
void *clientData);
-MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls,
+MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Class cls,
Tcl_Obj *nameObj, int flags,
const Tcl_MethodType *typePtr,
void *clientData);
@@ -557,14 +572,13 @@ MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp,
Object *oPtr);
MODULE_SCOPE void TclOODelMethodRef(Method *method);
-MODULE_SCOPE Tcl_Obj * TclOOGetAllClassProperties(Class *clsPtr,
- int writable, int *allocated);
-MODULE_SCOPE Tcl_Obj * TclOOGetAllObjectProperties(Object *oPtr,
- int writable, int *allocated);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
Tcl_Obj *methodNameObj, int flags,
Object *contextObjPtr, Class *contextClsPtr,
Tcl_Obj *cacheInThisObj);
+MODULE_SCOPE Class * TclOOGetClassDefineCmdContext(Tcl_Interp *interp);
+MODULE_SCOPE Class * TclOOGetClassFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace(
Tcl_Interp *interp, Object *oPtr, int forClass);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
@@ -583,10 +597,13 @@ MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp);
MODULE_SCOPE int TclOOInvokeContext(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Var TclOOLookupObjectVar(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Obj *varName,
+ Tcl_Var *aryPtr);
MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp,
Tcl_ObjectContext context, Tcl_Size objc,
Tcl_Obj *const *objv, Tcl_Size skip);
-MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
+MODULE_SCOPE void TclOONewBasicMethod(Class *clsPtr,
const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void TclOOReleaseClassContents(Tcl_Interp *interp,
@@ -601,7 +618,22 @@ MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp,
CallChain *callPtr);
MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr,
CallContext *contextPtr);
+MODULE_SCOPE Tcl_Obj * TclOOGetAllObjectProperties(Object *oPtr,
+ int writable);
MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
+MODULE_SCOPE Tcl_Obj * TclOOGetPropertyList(PropertyList *propList);
+MODULE_SCOPE void TclOOReleasePropertyStorage(PropertyStorage *propsPtr);
+MODULE_SCOPE void TclOOInstallReadableProperties(PropertyStorage *props,
+ Tcl_Size objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE void TclOOInstallWritableProperties(PropertyStorage *props,
+ Tcl_Size objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclOOInstallStdPropertyImpls(void *useInstance,
+ Tcl_Interp *interp, Tcl_Obj *propName,
+ int readable, int writable);
+MODULE_SCOPE void TclOORegisterProperty(Class *clsPtr,
+ Tcl_Obj *propName, int mayRead, int mayWrite);
+MODULE_SCOPE void TclOORegisterInstanceProperty(Object *oPtr,
+ Tcl_Obj *propName, int mayRead, int mayWrite);
/*
* Include all the private API, generated from tclOO.decls.
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index c5bed43..89e4d4e 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -21,7 +21,7 @@
* used in a procedure-like method.
*/
-typedef struct {
+typedef struct PMFrameData {
CallFrame *framePtr; /* Reference to the call frame itself (it's
* actually allocated on the Tcl stack). */
ProcErrorProc *errProc; /* The error handler for the body. */
@@ -34,7 +34,7 @@ typedef struct {
* on-the-ground resolvers used when working with resolved compiled variables.
*/
-typedef struct {
+typedef struct OOResVarInfo {
Tcl_ResolvedVarInfo info; /* "Type" information so that the compiled
* variable can be linked to the namespace
* variable at the right time. */
@@ -146,25 +146,25 @@ TclNewInstanceMethod(
int isNew;
if (nameObj == NULL) {
- mPtr = (Method *)Tcl_Alloc(sizeof(Method));
+ mPtr = (Method *) Tcl_Alloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
if (!oPtr->methodsPtr) {
- oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
+ oPtr->methodsPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, nameObj, &isNew);
if (isNew) {
- mPtr = (Method *)Tcl_Alloc(sizeof(Method));
+ mPtr = (Method *) Tcl_Alloc(sizeof(Method));
mPtr->namePtr = nameObj;
mPtr->refCount = 1;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
- mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
mPtr->typePtr->deleteProc(mPtr->clientData);
}
@@ -203,10 +203,11 @@ Tcl_NewInstanceMethod(
* method to be created. */
{
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
- Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewInstanceMethod");
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
+ "Tcl_NewInstanceMethod", "TCL_OO_METHOD_VERSION_1");
}
- return TclNewInstanceMethod(NULL, object, nameObj, flags,
- (const Tcl_MethodType *)typePtr, clientData);
+ return TclNewInstanceMethod(NULL, object, nameObj, flags, typePtr,
+ clientData);
}
Tcl_Method
Tcl_NewInstanceMethod2(
@@ -225,10 +226,11 @@ Tcl_NewInstanceMethod2(
* method to be created. */
{
if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
- Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2");
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
+ "Tcl_NewInstanceMethod2", "TCL_OO_METHOD_VERSION_2");
}
return TclNewInstanceMethod(NULL, object, nameObj, flags,
- (const Tcl_MethodType *)typePtr, clientData);
+ (const Tcl_MethodType *) typePtr, clientData);
}
/*
@@ -243,7 +245,6 @@ Tcl_NewInstanceMethod2(
Tcl_Method
TclNewMethod(
- TCL_UNUSED(Tcl_Interp *),
Tcl_Class cls, /* The class to attach the method to. */
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
* for constructors or destructors); if so, up
@@ -262,20 +263,20 @@ TclNewMethod(
int isNew;
if (nameObj == NULL) {
- mPtr = (Method *)Tcl_Alloc(sizeof(Method));
+ mPtr = (Method *) Tcl_Alloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
- hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, nameObj,&isNew);
+ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, nameObj, &isNew);
if (isNew) {
- mPtr = (Method *)Tcl_Alloc(sizeof(Method));
+ mPtr = (Method *) Tcl_Alloc(sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = nameObj;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
- mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ mPtr = (Method *) Tcl_GetHashValue(hPtr);
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
mPtr->typePtr->deleteProc(mPtr->clientData);
}
@@ -315,9 +316,10 @@ Tcl_NewMethod(
* method to be created. */
{
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
- Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewMethod");
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
+ "Tcl_NewMethod", "TCL_OO_METHOD_VERSION_1");
}
- return TclNewMethod(NULL, cls, nameObj, flags, typePtr, clientData);
+ return TclNewMethod(cls, nameObj, flags, typePtr, clientData);
}
Tcl_Method
@@ -336,9 +338,11 @@ Tcl_NewMethod2(
* method to be created. */
{
if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
- Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewMethod2");
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
+ "Tcl_NewMethod2", "TCL_OO_METHOD_VERSION_2");
}
- return TclNewMethod(NULL, cls, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData);
+ return TclNewMethod(cls, nameObj, flags,
+ (const Tcl_MethodType *) typePtr, clientData);
}
/*
@@ -380,7 +384,6 @@ TclOODelMethodRef(
void
TclOONewBasicMethod(
- Tcl_Interp *interp,
Class *clsPtr, /* Class to attach the method to. */
const DeclaredClassMethod *dcm)
/* Name of the method, whether it is public,
@@ -388,10 +391,9 @@ TclOONewBasicMethod(
{
Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);
- Tcl_IncrRefCount(namePtr);
- TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr,
+ TclNewMethod((Tcl_Class) clsPtr, namePtr,
(dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
- Tcl_DecrRefCount(namePtr);
+ Tcl_BounceRefCount(namePtr);
}
/*
@@ -502,45 +504,20 @@ TclOONewProcMethod(
/*
* ----------------------------------------------------------------------
*
- * TclOOMakeProcInstanceMethod --
+ * InitCmdFrame --
*
- * The guts of the code to make a procedure-like method for an object.
- * Split apart so that it is easier for other extensions to reuse (in
- * particular, it frees them from having to pry so deeply into Tcl's
- * guts).
+ * Set up a CmdFrame to record the source location for a procedure
+ * method. Assumes that the body is the last argument to the command
+ * creating the method, a good assumption because putting the body
+ * elsewhere is ugly.
*
* ----------------------------------------------------------------------
*/
-
-Tcl_Method
-TclOOMakeProcInstanceMethod(
- Tcl_Interp *interp, /* The interpreter containing the object. */
- Object *oPtr, /* The object to modify. */
- int flags, /* Whether this is a public method. */
- Tcl_Obj *nameObj, /* The name of the method, which _must not_ be
- * NULL. */
- Tcl_Obj *argsObj, /* The formal argument list for the method,
- * which _must not_ be NULL. */
- Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
- * NULL. */
- const Tcl_MethodType *typePtr,
- /* The type of the method to create. */
- void *clientData, /* The per-method type-specific data. */
- Proc **procPtrPtr) /* A pointer to the variable in which to write
- * the procedure record reference. Presumably
- * inside the structure indicated by the
- * pointer in clientData. */
+static inline void
+InitCmdFrame(
+ Interp *iPtr, /* Where source locations are recorded. */
+ Proc *procPtr) /* Guts of the method being made. */
{
- Interp *iPtr = (Interp *) interp;
- Proc *procPtr;
-
- if (TclCreateProc(interp, NULL, TclGetString(nameObj), argsObj, bodyObj,
- procPtrPtr) != TCL_OK) {
- return NULL;
- }
- procPtr = *procPtrPtr;
- procPtr->cmdPtr = NULL;
-
if (iPtr->cmdFramePtr) {
CmdFrame context = *iPtr->cmdFramePtr;
@@ -565,20 +542,23 @@ TclOOMakeProcInstanceMethod(
if (context.type == TCL_LOCATION_SOURCE) {
/*
* We can account for source location within a proc only if the
- * proc body was not created by substitution.
+ * proc body was not created by substitution. This is where we
+ * assume that the body is the last argument; the index of the body
+ * is NOT a fixed count of arguments in because of the alternate
+ * form of [oo::define]/[oo::objdefine].
* (FIXME: check that this is sane and correct!)
*/
- if (context.line
- && (context.nline >= 4) && (context.line[3] >= 0)) {
+ if (context.line && context.nline > 1
+ && (context.line[context.nline - 1] >= 0)) {
int isNew;
- CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame));
+ CmdFrame *cfPtr = (CmdFrame *) Tcl_Alloc(sizeof(CmdFrame));
Tcl_HashEntry *hPtr;
cfPtr->level = -1;
cfPtr->type = context.type;
- cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size));
- cfPtr->line[0] = context.line[3];
+ cfPtr->line = (Tcl_Size *) Tcl_Alloc(sizeof(Tcl_Size));
+ cfPtr->line[0] = context.line[context.nline - 1];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
cfPtr->nextPtr = NULL;
@@ -602,7 +582,51 @@ TclOOMakeProcInstanceMethod(
Tcl_DecrRefCount(context.data.eval.path);
context.data.eval.path = NULL;
}
+ }}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOMakeProcInstanceMethod --
+ *
+ * The guts of the code to make a procedure-like method for an object.
+ * Split apart so that it is easier for other extensions to reuse (in
+ * particular, it frees them from having to pry so deeply into Tcl's
+ * guts).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+TclOOMakeProcInstanceMethod(
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ Object *oPtr, /* The object to modify. */
+ int flags, /* Whether this is a public method. */
+ Tcl_Obj *nameObj, /* The name of the method, which _must not_ be
+ * NULL. */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which _must not_ be NULL. */
+ Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
+ * NULL. */
+ const Tcl_MethodType *typePtr,
+ /* The type of the method to create. */
+ void *clientData, /* The per-method type-specific data. */
+ Proc **procPtrPtr) /* A pointer to the variable in which to write
+ * the procedure record reference. Presumably
+ * inside the structure indicated by the
+ * pointer in clientData. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Proc *procPtr;
+
+ if (TclCreateProc(interp, NULL, TclGetString(nameObj), argsObj, bodyObj,
+ procPtrPtr) != TCL_OK) {
+ return NULL;
}
+ procPtr = *procPtrPtr;
+ procPtr->cmdPtr = NULL;
+
+ InitCmdFrame(iPtr, procPtr);
return TclNewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
typePtr, clientData);
@@ -638,7 +662,7 @@ TclOOMakeProcMethod(
* NULL. */
const Tcl_MethodType *typePtr,
/* The type of the method to create. */
- void *clientData, /* The per-method type-specific data. */
+ void *clientData, /* The per-method type-specific data. */
Proc **procPtrPtr) /* A pointer to the variable in which to write
* the procedure record reference. Presumably
* inside the structure indicated by the
@@ -654,71 +678,10 @@ TclOOMakeProcMethod(
procPtr = *procPtrPtr;
procPtr->cmdPtr = NULL;
- if (iPtr->cmdFramePtr) {
- CmdFrame context = *iPtr->cmdFramePtr;
-
- if (context.type == TCL_LOCATION_BC) {
- /*
- * Retrieve source information from the bytecode, if possible. If
- * the information is retrieved successfully, context.type will be
- * TCL_LOCATION_SOURCE and the reference held by
- * context.data.eval.path will be counted.
- */
-
- TclGetSrcInfoForPc(&context);
- } else if (context.type == TCL_LOCATION_SOURCE) {
- /*
- * The copy into 'context' up above has created another reference
- * to 'context.data.eval.path'; account for it.
- */
-
- Tcl_IncrRefCount(context.data.eval.path);
- }
-
- if (context.type == TCL_LOCATION_SOURCE) {
- /*
- * We can account for source location within a proc only if the
- * proc body was not created by substitution.
- * (FIXME: check that this is sane and correct!)
- */
+ InitCmdFrame(iPtr, procPtr);
- if (context.line
- && (context.nline >= 4) && (context.line[3] >= 0)) {
- int isNew;
- CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame));
- Tcl_HashEntry *hPtr;
-
- cfPtr->level = -1;
- cfPtr->type = context.type;
- cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size));
- cfPtr->line[0] = context.line[3];
- cfPtr->nline = 1;
- cfPtr->framePtr = NULL;
- cfPtr->nextPtr = NULL;
-
- cfPtr->data.eval.path = context.data.eval.path;
- Tcl_IncrRefCount(cfPtr->data.eval.path);
-
- cfPtr->cmd = NULL;
- cfPtr->len = 0;
-
- hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
- procPtr, &isNew);
- Tcl_SetHashValue(hPtr, cfPtr);
- }
-
- /*
- * 'context' is going out of scope; account for the reference that
- * it's holding to the path name.
- */
-
- Tcl_DecrRefCount(context.data.eval.path);
- context.data.eval.path = NULL;
- }
- }
-
- return TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
- clientData);
+ return TclNewMethod(
+ (Tcl_Class) clsPtr, nameObj, flags, typePtr, clientData);
}
/*
@@ -733,13 +696,13 @@ TclOOMakeProcMethod(
static int
InvokeProcedureMethod(
- void *clientData, /* Pointer to some per-method context. */
+ void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
- ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
+ ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
int result;
PMFrameData *fdPtr; /* Important data that has to have a lifetime
* matched by this function (or rather, by the
@@ -750,7 +713,7 @@ InvokeProcedureMethod(
* the next thing in the chain.
*/
- if (TclOOObjectDestroyed(((CallContext *)context)->oPtr)
+ if (TclOOObjectDestroyed(((CallContext *) context)->oPtr)
|| Tcl_InterpDeleted(interp)) {
return TclNRObjectContextInvokeNext(interp, context, objc, objv,
Tcl_ObjectContextSkippedArgs(context));
@@ -791,7 +754,7 @@ InvokeProcedureMethod(
* Allocate the special frame data.
*/
- fdPtr = (PMFrameData *)TclStackAlloc(interp, sizeof(PMFrameData));
+ fdPtr = (PMFrameData *) TclStackAlloc(interp, sizeof(PMFrameData));
/*
* Create a call frame for this method.
@@ -841,9 +804,9 @@ FinalizePMCall(
Tcl_Interp *interp,
int result)
{
- ProcedureMethod *pmPtr = (ProcedureMethod *)data[0];
- Tcl_ObjectContext context = (Tcl_ObjectContext)data[1];
- PMFrameData *fdPtr = (PMFrameData *)data[2];
+ ProcedureMethod *pmPtr = (ProcedureMethod *) data[0];
+ Tcl_ObjectContext context = (Tcl_ObjectContext) data[1];
+ PMFrameData *fdPtr = (PMFrameData *) data[2];
/*
* Give the post-call callback a chance to do some cleanup. Note that at
@@ -989,7 +952,7 @@ ProcedureMethodVarResolver(
Tcl_Interp *interp,
const char *varName,
Tcl_Namespace *contextNs,
- TCL_UNUSED(int) /*flags*/, /* Ignoring variable access flags (???) */
+ TCL_UNUSED(int) /*flags*/, // Ignoring variable access flags (???)
Tcl_Var *varPtr)
{
int result;
@@ -1037,7 +1000,7 @@ ProcedureMethodCompiledVarConnect(
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
return NULL;
}
- contextPtr = (CallContext *)framePtr->clientData;
+ contextPtr = (CallContext *) framePtr->clientData;
/*
* If we've done the work before (in a comparable context) then reuse that
@@ -1157,7 +1120,7 @@ ProcedureMethodCompiledVarResolver(
return TCL_CONTINUE;
}
- infoPtr = (OOResVarInfo *)Tcl_Alloc(sizeof(OOResVarInfo));
+ infoPtr = (OOResVarInfo *) Tcl_Alloc(sizeof(OOResVarInfo));
infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect;
infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete;
infoPtr->cachedObjectVar = NULL;
@@ -1234,7 +1197,7 @@ RenderDeclarerName(
* ----------------------------------------------------------------------
*/
-/* TODO: Check whether Tcl_AppendLimitedToObj() can work here. */
+// TODO: Check whether Tcl_AppendLimitedToObj() can work here.
#define LIMIT 60
#define ELLIPSIFY(str,len) \
@@ -1244,10 +1207,11 @@ static void
MethodErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
- /* We pull the method name out of context instead of from argument */
+ // We pull the method name out of context instead of from argument
{
Tcl_Size nameLen, objectNameLen;
- CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
+ CallContext *contextPtr = (CallContext *)
+ ((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
const char *objectName, *kindName, *methodName =
Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
@@ -1276,9 +1240,10 @@ static void
ConstructorErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
- /* Ignore. We know it is the constructor. */
+ // Ignore. We know it is the constructor.
{
- CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
+ CallContext *contextPtr = (CallContext *)
+ ((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
@@ -1306,9 +1271,10 @@ static void
DestructorErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
- /* Ignore. We know it is the destructor. */
+ // Ignore. We know it is the destructor.
{
- CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
+ CallContext *contextPtr = (CallContext *)
+ ((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
@@ -1357,7 +1323,7 @@ static void
DeleteProcedureMethod(
void *clientData)
{
- ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
+ ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
if (pmPtr->refCount-- <= 1) {
DeleteProcedureMethodRecord(pmPtr);
@@ -1370,7 +1336,7 @@ CloneProcedureMethod(
void *clientData,
void **newClientData)
{
- ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
+ ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
ProcedureMethod *pm2Ptr;
Tcl_Obj *bodyObj, *argsObj;
CompiledLocal *localPtr;
@@ -1409,7 +1375,7 @@ CloneProcedureMethod(
* record.
*/
- pm2Ptr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod));
+ pm2Ptr = (ProcedureMethod *) Tcl_Alloc(sizeof(ProcedureMethod));
memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
pm2Ptr->refCount = 1;
pm2Ptr->cmd.clientData = &pm2Ptr->efi;
@@ -1465,7 +1431,7 @@ TclOONewForwardInstanceMethod(
return NULL;
}
- fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod));
+ fmPtr = (ForwardMethod *) Tcl_Alloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) TclNewInstanceMethod(interp, (Tcl_Object) oPtr,
@@ -1504,10 +1470,10 @@ TclOONewForwardMethod(
return NULL;
}
- fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod));
+ fmPtr = (ForwardMethod *) Tcl_Alloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
- return (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj,
+ return (Method *) TclNewMethod((Tcl_Class) clsPtr, nameObj,
flags, &fwdMethodType, fmPtr);
}
@@ -1524,14 +1490,14 @@ TclOONewForwardMethod(
static int
InvokeForwardMethod(
- void *clientData, /* Pointer to some per-method context. */
+ void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
CallContext *contextPtr = (CallContext *) context;
- ForwardMethod *fmPtr = (ForwardMethod *)clientData;
+ ForwardMethod *fmPtr = (ForwardMethod *) clientData;
Tcl_Obj **argObjs, **prefixObjs;
Tcl_Size numPrefixes, skip = contextPtr->skip;
int len;
@@ -1552,8 +1518,8 @@ InvokeForwardMethod(
* of the TCL_EVAL_NOERR flag results in an evaluation configuration
* very much like TCL_EVAL_INVOKE.
*/
- ((Interp *)interp)->lookupNsPtr
- = (Namespace *) contextPtr->oPtr->namespacePtr;
+ ((Interp *) interp)->lookupNsPtr = (Namespace *)
+ contextPtr->oPtr->namespacePtr;
return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL);
}
@@ -1563,7 +1529,7 @@ FinalizeForwardCall(
Tcl_Interp *interp,
int result)
{
- Tcl_Obj **argObjs = (Tcl_Obj **)data[0];
+ Tcl_Obj **argObjs = (Tcl_Obj **) data[0];
TclStackFree(interp, argObjs);
return result;
@@ -1583,7 +1549,7 @@ static void
DeleteForwardMethod(
void *clientData)
{
- ForwardMethod *fmPtr = (ForwardMethod *)clientData;
+ ForwardMethod *fmPtr = (ForwardMethod *) clientData;
Tcl_DecrRefCount(fmPtr->prefixObj);
Tcl_Free(fmPtr);
@@ -1595,8 +1561,8 @@ CloneForwardMethod(
void *clientData,
void **newClientData)
{
- ForwardMethod *fmPtr = (ForwardMethod *)clientData;
- ForwardMethod *fm2Ptr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod));
+ ForwardMethod *fmPtr = (ForwardMethod *) clientData;
+ ForwardMethod *fm2Ptr = (ForwardMethod *) Tcl_Alloc(sizeof(ForwardMethod));
fm2Ptr->prefixObj = fmPtr->prefixObj;
Tcl_IncrRefCount(fm2Ptr->prefixObj);
@@ -1620,7 +1586,7 @@ TclOOGetProcFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
- ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData;
+ ProcedureMethod *pmPtr = (ProcedureMethod *) mPtr->clientData;
return pmPtr->procPtr;
}
@@ -1632,7 +1598,7 @@ TclOOGetMethodBody(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
- ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData;
+ ProcedureMethod *pmPtr = (ProcedureMethod *) mPtr->clientData;
(void) TclGetString(pmPtr->procPtr->bodyPtr);
return pmPtr->procPtr->bodyPtr;
@@ -1645,7 +1611,7 @@ TclOOGetFwdFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &fwdMethodType) {
- ForwardMethod *fwPtr = (ForwardMethod *)mPtr->clientData;
+ ForwardMethod *fwPtr = (ForwardMethod *) mPtr->clientData;
return fwPtr->prefixObj;
}
@@ -1687,7 +1653,8 @@ InitEnsembleRewrite(
* array of rewritten arguments. */
{
size_t len = rewriteLength + objc - toRewrite;
- Tcl_Obj **argObjs = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * len);
+ Tcl_Obj **argObjs = (Tcl_Obj **)
+ TclStackAlloc(interp, sizeof(Tcl_Obj *) * len);
memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
memcpy(argObjs + rewriteLength, objv + toRewrite,
@@ -1764,7 +1731,8 @@ Tcl_MethodIsType(
Method *mPtr = (Method *) method;
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
- Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_MethodIsType");
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
+ "Tcl_MethodIsType", "TCL_OO_METHOD_VERSION_1");
}
if (mPtr->typePtr == typePtr) {
if (clientDataPtr != NULL) {
@@ -1784,9 +1752,10 @@ Tcl_MethodIsType2(
Method *mPtr = (Method *) method;
if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
- Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_MethodIsType2");
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
+ "Tcl_MethodIsType2", "TCL_OO_METHOD_VERSION_2");
}
- if (mPtr->typePtr == (const Tcl_MethodType *)typePtr) {
+ if (mPtr->typePtr == (const Tcl_MethodType *) typePtr) {
if (clientDataPtr != NULL) {
*clientDataPtr = mPtr->clientData;
}
@@ -1799,14 +1768,14 @@ int
Tcl_MethodIsPublic(
Tcl_Method method)
{
- return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
+ return (((Method *) method)->flags & PUBLIC_METHOD) ? 1 : 0;
}
int
Tcl_MethodIsPrivate(
Tcl_Method method)
{
- return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0;
+ return (((Method *) method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0;
}
/*
diff --git a/generic/tclOOProp.c b/generic/tclOOProp.c
new file mode 100644
index 0000000..4cff300
--- /dev/null
+++ b/generic/tclOOProp.c
@@ -0,0 +1,1354 @@
+/*
+ * tclOOProp.c --
+ *
+ * This file contains implementations of the configurable property
+ * mecnanisms.
+ *
+ * Copyright © 2023-2024 Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclOOInt.h"
+
+/* Short-term cache for GetPropertyName(). */
+typedef struct GPNCache {
+ Tcl_Obj *listPtr; /* Holds references to names. */
+ char *names[TCLFLEXARRAY]; /* NULL-terminated table of names. */
+} GPNCache;
+
+enum GPNFlags {
+ GPN_WRITABLE = 1, /* Are we looking for a writable property? */
+ GPN_FALLING_BACK = 2 /* Are we doing a recursive call to determine
+ * if the property is of the other type? */
+};
+
+/*
+ * Shared bits for [property] declarations.
+ */
+enum PropOpt {
+ PROP_ALL, PROP_READABLE, PROP_WRITABLE
+};
+static const char *const propOptNames[] = {
+ "-all", "-readable", "-writable",
+ NULL
+};
+
+/*
+ * Forward declarations.
+ */
+
+static int Configurable_Getter(void *clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int Configurable_Setter(void *clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static void DetailsDeleter(void *clientData);
+static int DetailsCloner(Tcl_Interp *, void *oldClientData,
+ void **newClientData);
+static void ImplementObjectProperty(Tcl_Object targetObject,
+ Tcl_Obj *propNamePtr, int installGetter,
+ int installSetter);
+static void ImplementClassProperty(Tcl_Class targetObject,
+ Tcl_Obj *propNamePtr, int installGetter,
+ int installSetter);
+
+/*
+ * Method descriptors
+ */
+
+static const Tcl_MethodType GetterType = {
+ TCL_OO_METHOD_VERSION_1,
+ "PropertyGetter",
+ Configurable_Getter,
+ DetailsDeleter,
+ DetailsCloner
+};
+
+static const Tcl_MethodType SetterType = {
+ TCL_OO_METHOD_VERSION_1,
+ "PropertySetter",
+ Configurable_Setter,
+ DetailsDeleter,
+ DetailsCloner
+};
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Configurable_Configure --
+ *
+ * Implementation of the oo::configurable->configure method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+/*
+ * Ugly thunks to read and write a property by calling the right method in
+ * the right way. Note that we MUST be correct in holding references to Tcl_Obj
+ * values, as this is potentially a call into user code.
+ */
+static inline int
+ReadProperty(
+ Tcl_Interp *interp,
+ Object *oPtr,
+ const char *propName)
+{
+ Tcl_Obj *args[] = {
+ oPtr->fPtr->myName,
+ Tcl_ObjPrintf("<ReadProp%s>", propName)
+ };
+ int code;
+
+ Tcl_IncrRefCount(args[0]);
+ Tcl_IncrRefCount(args[1]);
+ code = TclOOPrivateObjectCmd(oPtr, interp, 2, args);
+ Tcl_DecrRefCount(args[0]);
+ Tcl_DecrRefCount(args[1]);
+ switch (code) {
+ case TCL_BREAK:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "property getter for %s did a break", propName));
+ return TCL_ERROR;
+ case TCL_CONTINUE:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "property getter for %s did a continue", propName));
+ return TCL_ERROR;
+ default:
+ return code;
+ }
+}
+
+static inline int
+WriteProperty(
+ Tcl_Interp *interp,
+ Object *oPtr,
+ const char *propName,
+ Tcl_Obj *valueObj)
+{
+ Tcl_Obj *args[] = {
+ oPtr->fPtr->myName,
+ Tcl_ObjPrintf("<WriteProp%s>", propName),
+ valueObj
+ };
+ int code;
+
+ Tcl_IncrRefCount(args[0]);
+ Tcl_IncrRefCount(args[1]);
+ Tcl_IncrRefCount(args[2]);
+ code = TclOOPrivateObjectCmd(oPtr, interp, 3, args);
+ Tcl_DecrRefCount(args[0]);
+ Tcl_DecrRefCount(args[1]);
+ Tcl_DecrRefCount(args[2]);
+ switch (code) {
+ case TCL_BREAK:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "property setter for %s did a break", propName));
+ return TCL_ERROR;
+ case TCL_CONTINUE:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "property setter for %s did a continue", propName));
+ return TCL_ERROR;
+ default:
+ return code;
+ }
+}
+
+/* Look up a property full name. */
+static Tcl_Obj *
+GetPropertyName(
+ Tcl_Interp *interp, /* Context and error reporting. */
+ Object *oPtr, /* Object to get property name from. */
+ int flags, /* Are we looking for a writable property?
+ * Can we do a fallback message?
+ * See GPNFlags for possible values */
+ Tcl_Obj *namePtr, /* The name supplied by the user. */
+ GPNCache **cachePtr) /* Where to cache the table, if the caller
+ * wants that. The contents are to be freed
+ * with Tcl_Free if the cache is used. */
+{
+ Tcl_Size objc, index, i;
+ Tcl_Obj *listPtr = TclOOGetAllObjectProperties(
+ oPtr, flags & GPN_WRITABLE);
+ Tcl_Obj **objv;
+ GPNCache *tablePtr;
+
+ (void) Tcl_ListObjGetElements(NULL, listPtr, &objc, &objv);
+ if (cachePtr && *cachePtr) {
+ tablePtr = *cachePtr;
+ } else {
+ tablePtr = (GPNCache *) TclStackAlloc(interp,
+ offsetof(GPNCache, names) + sizeof(char *) * (objc + 1));
+
+ for (i = 0; i < objc; i++) {
+ tablePtr->names[i] = TclGetString(objv[i]);
+ }
+ tablePtr->names[objc] = NULL;
+ if (cachePtr) {
+ /*
+ * Have a cache, but nothing in it so far.
+ *
+ * We cache the list here so it doesn't vanish from under our
+ * feet if a property implementation does something crazy like
+ * changing the set of properties. The type of copy this does
+ * means that the copy holds the references to the names in the
+ * table.
+ */
+ tablePtr->listPtr = TclListObjCopy(NULL, listPtr);
+ Tcl_IncrRefCount(tablePtr->listPtr);
+ *cachePtr = tablePtr;
+ } else {
+ tablePtr->listPtr = NULL;
+ }
+ }
+ int result = Tcl_GetIndexFromObjStruct(interp, namePtr, tablePtr->names,
+ sizeof(char *), "property", TCL_INDEX_TEMP_TABLE, &index);
+ if (result == TCL_ERROR && !(flags & GPN_FALLING_BACK)) {
+ /*
+ * If property can be accessed the other way, use a special message.
+ * We use a recursive call to look this up.
+ */
+
+ Tcl_InterpState foo = Tcl_SaveInterpState(interp, result);
+ Tcl_Obj *otherName = GetPropertyName(interp, oPtr,
+ flags ^ (GPN_WRITABLE | GPN_FALLING_BACK), namePtr, NULL);
+ result = Tcl_RestoreInterpState(interp, foo);
+ if (otherName != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "property \"%s\" is %s only",
+ TclGetString(otherName),
+ (flags & GPN_WRITABLE) ? "read" : "write"));
+ }
+ }
+ if (!cachePtr) {
+ TclStackFree(interp, tablePtr);
+ }
+ if (result != TCL_OK) {
+ return NULL;
+ }
+ return objv[index];
+}
+
+/* Release the cache made by GetPropertyName(). */
+static inline void
+ReleasePropertyNameCache(
+ Tcl_Interp *interp,
+ GPNCache **cachePtr)
+{
+ if (*cachePtr) {
+ GPNCache *tablePtr = *cachePtr;
+ if (tablePtr->listPtr) {
+ Tcl_DecrRefCount(tablePtr->listPtr);
+ }
+ TclStackFree(interp, tablePtr);
+ *cachePtr = NULL;
+ }
+}
+
+int
+TclOO_Configurable_Configure(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Interpreter used for the result, error
+ * reporting, etc. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context);
+ Tcl_Obj *namePtr;
+ Tcl_Size i, namec;
+ int code = TCL_OK;
+
+ objc -= skip;
+ if ((objc & 1) && (objc != 1)) {
+ /*
+ * Bad (odd > 1) number of arguments.
+ */
+
+ Tcl_WrongNumArgs(interp, skip, objv, "?-option value ...?");
+ return TCL_ERROR;
+ }
+
+ objv += skip;
+ if (objc == 0) {
+ /*
+ * Read all properties.
+ */
+
+ Tcl_Obj *listPtr = TclOOGetAllObjectProperties(oPtr, 0);
+ Tcl_Obj *resultPtr = Tcl_NewObj(), **namev;
+
+ Tcl_IncrRefCount(listPtr);
+ ListObjGetElements(listPtr, namec, namev);
+
+ for (i = 0; i < namec; ) {
+ code = ReadProperty(interp, oPtr, TclGetString(namev[i]));
+ if (code != TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ break;
+ }
+ Tcl_DictObjPut(NULL, resultPtr, namev[i],
+ Tcl_GetObjResult(interp));
+ if (++i >= namec) {
+ Tcl_SetObjResult(interp, resultPtr);
+ break;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewObj());
+ }
+ Tcl_DecrRefCount(listPtr);
+ return code;
+ } else if (objc == 1) {
+ /*
+ * Read a single named property.
+ */
+
+ namePtr = GetPropertyName(interp, oPtr, 0, objv[0], NULL);
+ if (namePtr == NULL) {
+ return TCL_ERROR;
+ }
+ return ReadProperty(interp, oPtr, TclGetString(namePtr));
+ } else if (objc == 2) {
+ /*
+ * Special case for writing to one property. Saves fiddling with the
+ * cache in this common case.
+ */
+
+ namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[0], NULL);
+ if (namePtr == NULL) {
+ return TCL_ERROR;
+ }
+ code = WriteProperty(interp, oPtr, TclGetString(namePtr), objv[1]);
+ if (code == TCL_OK) {
+ Tcl_ResetResult(interp);
+ }
+ return code;
+ } else {
+ /*
+ * Write properties. Slightly tricky because we want to cache the
+ * table of property names.
+ */
+ GPNCache *cache = NULL;
+
+ code = TCL_OK;
+ for (i = 0; i < objc; i += 2) {
+ namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[i],
+ &cache);
+ if (namePtr == NULL) {
+ code = TCL_ERROR;
+ break;
+ }
+ code = WriteProperty(interp, oPtr, TclGetString(namePtr),
+ objv[i + 1]);
+ if (code != TCL_OK) {
+ break;
+ }
+ }
+ if (code == TCL_OK) {
+ Tcl_ResetResult(interp);
+ }
+ ReleasePropertyNameCache(interp, &cache);
+ return code;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Configurable_Getter, Configurable_Setter --
+ *
+ * Standard property implementation. The clientData is a simple Tcl_Obj*
+ * that contains the name of the property.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+Configurable_Getter(
+ void *clientData, /* Which property to read. Actually a Tcl_Obj*
+ * reference that is the name of the variable
+ * in the cpntext object. */
+ Tcl_Interp *interp, /* Interpreter used for the result, error
+ * reporting, etc. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Tcl_Obj *propNamePtr = (Tcl_Obj *) clientData;
+ Tcl_Var varPtr, aryVar;
+ Tcl_Obj *valuePtr;
+
+ if ((int) Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context),
+ objv, NULL);
+ return TCL_ERROR;
+ }
+
+ varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
+ propNamePtr, &aryVar);
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ valuePtr = TclPtrGetVar(interp, varPtr, aryVar, propNamePtr, NULL,
+ TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG);
+ if (valuePtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, valuePtr);
+ return TCL_OK;
+}
+
+static int
+Configurable_Setter(
+ void *clientData, /* Which property to write. Actually a Tcl_Obj*
+ * reference that is the name of the variable
+ * in the cpntext object. */
+ Tcl_Interp *interp, /* Interpreter used for the result, error
+ * reporting, etc. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Tcl_Obj *propNamePtr = (Tcl_Obj *) clientData;
+ Tcl_Var varPtr, aryVar;
+
+ if ((int) Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context),
+ objv, "value");
+ return TCL_ERROR;
+ }
+
+ varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
+ propNamePtr, &aryVar);
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (TclPtrSetVar(interp, varPtr, aryVar, propNamePtr, NULL,
+ objv[objc - 1], TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+// Simple support functions
+static void
+DetailsDeleter(
+ void *clientData)
+{
+ // Just drop the reference count
+ Tcl_Obj *propNamePtr = (Tcl_Obj *) clientData;
+ Tcl_DecrRefCount(propNamePtr);
+}
+
+static int
+DetailsCloner(
+ TCL_UNUSED(Tcl_Interp *),
+ void *oldClientData,
+ void **newClientData)
+{
+ // Just add another reference to this name; easy!
+ Tcl_Obj *propNamePtr = (Tcl_Obj *) oldClientData;
+ Tcl_IncrRefCount(propNamePtr);
+ *newClientData = propNamePtr;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ImplementObjectProperty, ImplementClassProperty --
+ *
+ * Installs a basic property implementation for a property, either on
+ * an instance or on a class. It's up to the code that calls these
+ * to ensure that the property name is syntactically valid.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+ImplementObjectProperty(
+ Tcl_Object targetObject, /* What to install into. */
+ Tcl_Obj *propNamePtr, /* Property name. */
+ int installGetter, /* Whether to install a standard getter. */
+ int installSetter) /* Whether to install a standard setter. */
+{
+ const char *propName = TclGetString(propNamePtr);
+
+ while (propName[0] == '-') {
+ propName++;
+ }
+ if (installGetter) {
+ Tcl_Obj *methodName = Tcl_ObjPrintf("<ReadProp-%s>", propName);
+ Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
+ TclNewInstanceMethod(
+ NULL, targetObject, methodName, 0, &GetterType, propNamePtr);
+ Tcl_BounceRefCount(methodName);
+ }
+ if (installSetter) {
+ Tcl_Obj *methodName = Tcl_ObjPrintf("<WriteProp-%s>", propName);
+ Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
+ TclNewInstanceMethod(
+ NULL, targetObject, methodName, 0, &SetterType, propNamePtr);
+ Tcl_BounceRefCount(methodName);
+ }
+}
+
+void
+ImplementClassProperty(
+ Tcl_Class targetClass, /* What to install into. */
+ Tcl_Obj *propNamePtr, /* Property name. */
+ int installGetter, /* Whether to install a standard getter. */
+ int installSetter) /* Whether to install a standard setter. */
+{
+ const char *propName = TclGetString(propNamePtr);
+
+ while (propName[0] == '-') {
+ propName++;
+ }
+ if (installGetter) {
+ Tcl_Obj *methodName = Tcl_ObjPrintf("<ReadProp-%s>", propName);
+ Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
+ TclNewMethod(targetClass, methodName, 0, &GetterType, propNamePtr);
+ Tcl_BounceRefCount(methodName);
+ }
+ if (installSetter) {
+ Tcl_Obj *methodName = Tcl_ObjPrintf("<WriteProp-%s>", propName);
+ Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
+ TclNewMethod(targetClass, methodName, 0, &SetterType, propNamePtr);
+ Tcl_BounceRefCount(methodName);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * GetAllClassProperties --
+ *
+ * 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.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+GetAllClassProperties(
+ 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;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SortPropList --
+ * Sort a list of names of properties. Simple support function. Assumes
+ * that the list Tcl_Obj is unshared and doesn't have a string
+ * representation.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+PropNameCompare(
+ const void *a,
+ const void *b)
+{
+ Tcl_Obj *first = *(Tcl_Obj **) a;
+ Tcl_Obj *second = *(Tcl_Obj **) b;
+
+ return TclStringCmp(first, second, 0, 0, TCL_INDEX_NONE);
+}
+
+static inline void
+SortPropList(
+ Tcl_Obj *list)
+{
+ Tcl_Size ec;
+ Tcl_Obj **ev;
+
+ if (Tcl_IsShared(list)) {
+ Tcl_Panic("shared property list cannot be sorted");
+ }
+ Tcl_ListObjGetElements(NULL, list, &ec, &ev);
+ TclInvalidateStringRep(list);
+ qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetAllObjectProperties --
+ *
+ * Get the sorted list of all properties known to a object, including to its
+ * its classes. Manages a cache so this operation is usually cheap.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+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. */
+{
+ 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) {
+ return oPtr->properties.allWritableCache;
+ }
+ } else {
+ if (oPtr->properties.allReadableCache) {
+ return oPtr->properties.allReadableCache;
+ }
+ }
+ }
+
+ /*
+ * Gather the information. Unsorted! (Caller will sort.)
+ */
+
+ Tcl_InitObjHashTable(&hashTable);
+ FindObjectProps(oPtr, writable, &hashTable);
+ TclNewObj(result);
+ FOREACH_HASH(propName, dummy, &hashTable) {
+ Tcl_ListObjAppendElement(NULL, result, propName);
+ }
+ Tcl_DeleteHashTable(&hashTable);
+ SortPropList(result);
+
+ /*
+ * 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;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SetPropertyList --
+ *
+ * Helper for writing a property list (which is actually a set).
+ *
+ * ----------------------------------------------------------------------
+ */
+static inline void
+SetPropertyList(
+ PropertyList *propList, /* The property list to write. Replaces the
+ * property list's contents. */
+ Tcl_Size objc, /* Number of property names. */
+ Tcl_Obj *const objv[]) /* Property names. */
+{
+ Tcl_Size i, n;
+ Tcl_Obj *propObj;
+ int created;
+ Tcl_HashTable uniqueTable;
+
+ for (i=0 ; i<objc ; i++) {
+ Tcl_IncrRefCount(objv[i]);
+ }
+ FOREACH(propObj, *propList) {
+ Tcl_DecrRefCount(propObj);
+ }
+ if (i != objc) {
+ if (objc == 0) {
+ Tcl_Free(propList->list);
+ } else if (i) {
+ propList->list = (Tcl_Obj **)
+ Tcl_Realloc(propList->list, sizeof(Tcl_Obj *) * objc);
+ } else {
+ propList->list = (Tcl_Obj **)
+ Tcl_Alloc(sizeof(Tcl_Obj *) * objc);
+ }
+ }
+ propList->num = 0;
+ if (objc > 0) {
+ Tcl_InitObjHashTable(&uniqueTable);
+ for (i=n=0 ; i<objc ; i++) {
+ Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
+ if (created) {
+ propList->list[n++] = objv[i];
+ } else {
+ Tcl_DecrRefCount(objv[i]);
+ }
+ }
+ propList->num = n;
+
+ /*
+ * Shouldn't be necessary, but maintain num/list invariant.
+ */
+
+ if (n != objc) {
+ propList->list = (Tcl_Obj **)
+ Tcl_Realloc(propList->list, sizeof(Tcl_Obj *) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInstallReadableProperties --
+ *
+ * Helper for writing the readable property list (which is actually a set)
+ * that includes flushing the name cache.
+ *
+ * ----------------------------------------------------------------------
+ */
+void
+TclOOInstallReadableProperties(
+ PropertyStorage *props, /* Which property list to install into. */
+ Tcl_Size objc, /* Number of property names. */
+ Tcl_Obj *const objv[]) /* Property names. */
+{
+ if (props->allReadableCache) {
+ Tcl_DecrRefCount(props->allReadableCache);
+ props->allReadableCache = NULL;
+ }
+
+ SetPropertyList(&props->readable, objc, objv);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInstallWritableProperties --
+ *
+ * Helper for writing the writable property list (which is actually a set)
+ * that includes flushing the name cache.
+ *
+ * ----------------------------------------------------------------------
+ */
+void
+TclOOInstallWritableProperties(
+ PropertyStorage *props, /* Which property list to install into. */
+ Tcl_Size objc, /* Number of property names. */
+ Tcl_Obj *const objv[]) /* Property names. */
+{
+ if (props->allWritableCache) {
+ Tcl_DecrRefCount(props->allWritableCache);
+ props->allWritableCache = NULL;
+ }
+
+ SetPropertyList(&props->writable, objc, objv);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetPropertyList --
+ *
+ * Helper for reading a property list.
+ *
+ * ----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclOOGetPropertyList(
+ PropertyList *propList) /* The property list to read. */
+{
+ Tcl_Obj *resultObj, *propNameObj;
+ Tcl_Size i;
+
+ TclNewObj(resultObj);
+ FOREACH(propNameObj, *propList) {
+ Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
+ }
+ return resultObj;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInstallStdPropertyImpls --
+ *
+ * Validates a (dashless) property name, and installs implementation
+ * methods if asked to do so (readable and writable flags).
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOOInstallStdPropertyImpls(
+ void *useInstance,
+ Tcl_Interp *interp,
+ Tcl_Obj *propName,
+ int readable,
+ int writable)
+{
+ const char *name, *reason;
+ Tcl_Size len;
+ char flag = TCL_DONT_QUOTE_HASH;
+
+ /*
+ * Validate the property name. Note that just calling TclScanElement() is
+ * cheaper than actually formatting a list and comparing the string
+ * version of that with the original, as TclScanElement() is one of the
+ * core parts of doing that; this skips a whole load of irrelevant memory
+ * allocations!
+ */
+
+ name = Tcl_GetStringFromObj(propName, &len);
+ if (Tcl_StringMatch(name, "-*")) {
+ reason = "must not begin with -";
+ goto badProp;
+ }
+ if (TclScanElement(name, len, &flag) != len) {
+ reason = "must be a simple word";
+ goto badProp;
+ }
+ if (Tcl_StringMatch(name, "*::*")) {
+ reason = "must not contain namespace separators";
+ goto badProp;
+ }
+ if (Tcl_StringMatch(name, "*[()]*")) {
+ reason = "must not contain parentheses";
+ goto badProp;
+ }
+
+ /*
+ * Install the implementations... if asked to do so.
+ */
+
+ if (useInstance) {
+ Tcl_Object object = TclOOGetDefineCmdContext(interp);
+ if (!object) {
+ return TCL_ERROR;
+ }
+ ImplementObjectProperty(object, propName, readable, writable);
+ } else {
+ Tcl_Class cls = (Tcl_Class) TclOOGetClassDefineCmdContext(interp);
+ if (!cls) {
+ return TCL_ERROR;
+ }
+ ImplementClassProperty(cls, propName, readable, writable);
+ }
+ return TCL_OK;
+
+ badProp:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad property name \"%s\": %s", name, reason));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "PROPERTY_FORMAT", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefinePropertyCmd --
+ *
+ * Implementation of the "property" definition for classes and instances
+ * governed by the [oo::configurable] metaclass.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefinePropertyCmd(
+ void *useInstance, /* NULL for class, non-NULL for object. */
+ Tcl_Interp *interp, /* For error reporting and lookup. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Arguments. */
+{
+ int i;
+ const char *const options[] = {
+ "-get", "-kind", "-set", NULL
+ };
+ enum Options {
+ OPT_GET, OPT_KIND, OPT_SET
+ };
+ const char *const kinds[] = {
+ "readable", "readwrite", "writable", NULL
+ };
+ enum Kinds {
+ KIND_RO, KIND_RW, KIND_WO
+ };
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!useInstance && !oPtr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
+ return TCL_ERROR;
+ }
+
+ for (i = 1; i < objc; i++) {
+ Tcl_Obj *propObj = objv[i], *nextObj, *argObj, *hyphenated;
+ Tcl_Obj *getterScript = NULL, *setterScript = NULL;
+
+ /*
+ * Parse the extra options for the property.
+ */
+
+ int kind = KIND_RW;
+ while (i + 1 < objc) {
+ int option;
+
+ nextObj = objv[i + 1];
+ if (TclGetString(nextObj)[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, nextObj, options, "option", 0,
+ &option) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (i + 2 >= objc) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing %s to go with %s option",
+ (option == OPT_KIND ? "kind value" : "body"),
+ options[option]));
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ return TCL_ERROR;
+ }
+ argObj = objv[i + 2];
+ i += 2;
+ switch (option) {
+ case OPT_GET:
+ getterScript = argObj;
+ break;
+ case OPT_SET:
+ setterScript = argObj;
+ break;
+ case OPT_KIND:
+ if (Tcl_GetIndexFromObj(interp, argObj, kinds, "kind", 0,
+ &kind) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ }
+ }
+
+ /*
+ * Install the property. Note that TclOOInstallStdPropertyImpls
+ * validates the property name as well.
+ */
+
+ if (TclOOInstallStdPropertyImpls(useInstance, interp, propObj,
+ kind != KIND_WO && getterScript == NULL,
+ kind != KIND_RO && setterScript == NULL) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ hyphenated = Tcl_ObjPrintf("-%s", TclGetString(propObj));
+ if (useInstance) {
+ TclOORegisterInstanceProperty(oPtr, hyphenated,
+ kind != KIND_WO, kind != KIND_RO);
+ } else {
+ TclOORegisterProperty(oPtr->classPtr, hyphenated,
+ kind != KIND_WO, kind != KIND_RO);
+ }
+ Tcl_BounceRefCount(hyphenated);
+
+ /*
+ * Create property implementation methods by using the right
+ * back-end API, but only if the user has given us the bodies of the
+ * methods we'll make.
+ */
+
+ if (getterScript != NULL) {
+ Tcl_Obj *getterName = Tcl_ObjPrintf("<ReadProp-%s>",
+ TclGetString(propObj));
+ Tcl_Obj *argsPtr = Tcl_NewObj();
+ Method *mPtr;
+
+ Tcl_IncrRefCount(getterScript);
+ if (useInstance) {
+ mPtr = TclOONewProcInstanceMethod(interp, oPtr, 0,
+ getterName, argsPtr, getterScript, NULL);
+ } else {
+ mPtr = TclOONewProcMethod(interp, oPtr->classPtr, 0,
+ getterName, argsPtr, getterScript, NULL);
+ }
+ Tcl_BounceRefCount(getterName);
+ Tcl_BounceRefCount(argsPtr);
+ Tcl_DecrRefCount(getterScript);
+ if (mPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ if (setterScript != NULL) {
+ Tcl_Obj *setterName = Tcl_ObjPrintf("<WriteProp-%s>",
+ TclGetString(propObj));
+ Tcl_Obj *argsPtr;
+ Method *mPtr;
+
+ TclNewLiteralStringObj(argsPtr, "value");
+ Tcl_IncrRefCount(setterScript);
+ if (useInstance) {
+ mPtr = TclOONewProcInstanceMethod(interp, oPtr, 0,
+ setterName, argsPtr, setterScript, NULL);
+ } else {
+ mPtr = TclOONewProcMethod(interp, oPtr->classPtr, 0,
+ setterName, argsPtr, setterScript, NULL);
+ }
+ Tcl_BounceRefCount(setterName);
+ Tcl_BounceRefCount(argsPtr);
+ Tcl_DecrRefCount(setterScript);
+ if (mPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInfoClassPropCmd, TclOOInfoObjectPropCmd --
+ *
+ * Implements [info class properties $clsName ?$option...?] and
+ * [info object properties $objName ?$option...?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOInfoClassPropCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *clsPtr;
+ int i, idx, all = 0, writable = 0, allocated = 0;
+ Tcl_Obj *result;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
+ return TCL_ERROR;
+ }
+ clsPtr = TclOOGetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ for (i = 2; i < objc; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (idx) {
+ case PROP_ALL:
+ all = 1;
+ break;
+ case PROP_READABLE:
+ writable = 0;
+ break;
+ case PROP_WRITABLE:
+ writable = 1;
+ break;
+ }
+ }
+
+ /*
+ * Get the properties.
+ */
+
+ if (all) {
+ result = GetAllClassProperties(clsPtr, writable, &allocated);
+ if (allocated) {
+ SortPropList(result);
+ }
+ } else {
+ if (writable) {
+ result = TclOOGetPropertyList(&clsPtr->properties.writable);
+ } else {
+ result = TclOOGetPropertyList(&clsPtr->properties.readable);
+ }
+ SortPropList(result);
+ }
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
+}
+
+int
+TclOOInfoObjectPropCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ int i, idx, all = 0, writable = 0;
+ Tcl_Obj *result;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ for (i = 2; i < objc; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (idx) {
+ case PROP_ALL:
+ all = 1;
+ break;
+ case PROP_READABLE:
+ writable = 0;
+ break;
+ case PROP_WRITABLE:
+ writable = 1;
+ break;
+ }
+ }
+
+ /*
+ * Get the properties.
+ */
+
+ if (all) {
+ result = TclOOGetAllObjectProperties(oPtr, writable);
+ } else {
+ if (writable) {
+ result = TclOOGetPropertyList(&oPtr->properties.writable);
+ } else {
+ result = TclOOGetPropertyList(&oPtr->properties.readable);
+ }
+ SortPropList(result);
+ }
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOReleasePropertyStorage --
+ *
+ * Delete the memory associated with a class or object's properties.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+ReleasePropertyList(
+ PropertyList *propList)
+{
+ Tcl_Obj *propertyObj;
+ Tcl_Size i;
+
+ FOREACH(propertyObj, *propList) {
+ Tcl_DecrRefCount(propertyObj);
+ }
+ Tcl_Free(propList->list);
+ propList->list = NULL;
+ propList->num = 0;
+}
+
+void
+TclOOReleasePropertyStorage(
+ PropertyStorage *propsPtr)
+{
+ if (propsPtr->allReadableCache) {
+ Tcl_DecrRefCount(propsPtr->allReadableCache);
+ }
+ if (propsPtr->allWritableCache) {
+ Tcl_DecrRefCount(propsPtr->allWritableCache);
+ }
+ if (propsPtr->readable.num) {
+ ReleasePropertyList(&propsPtr->readable);
+ }
+ if (propsPtr->writable.num) {
+ ReleasePropertyList(&propsPtr->writable);
+ }
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index a763092..98fa20e 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -258,214 +258,18 @@ static const char *tclOOSetupScript =
"\t\tsuperclass class\n"
"\t\tunexport create createWithNamespace new\n"
"\t}\n"
-"\t::namespace eval configuresupport {\n"
-"\t\tnamespace path ::tcl\n"
-"\t\tproc PropertyImpl {readslot writeslot args} {\n"
-"\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n"
-"\t\t\t\tset prop [lindex $args $i]\n"
-"\t\t\t\tif {[string match \"-*\" $prop]} {\n"
-"\t\t\t\t\treturn -code error -level 2 \\\n"
-"\t\t\t\t\t\t-errorcode {TCL OO PROPERTY_FORMAT} \\\n"
-"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not begin with -\"\n"
-"\t\t\t\t}\n"
-"\t\t\t\tif {$prop ne [list $prop]} {\n"
-"\t\t\t\t\treturn -code error -level 2 \\\n"
-"\t\t\t\t\t\t-errorcode {TCL OO PROPERTY_FORMAT} \\\n"
-"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must be a simple word\"\n"
-"\t\t\t\t}\n"
-"\t\t\t\tif {[string first \"::\" $prop] != -1} {\n"
-"\t\t\t\t\treturn -code error -level 2 \\\n"
-"\t\t\t\t\t\t-errorcode {TCL OO PROPERTY_FORMAT} \\\n"
-"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain namespace separators\"\n"
-"\t\t\t\t}\n"
-"\t\t\t\tif {[string match {*[()]*} $prop]} {\n"
-"\t\t\t\t\treturn -code error -level 2 \\\n"
-"\t\t\t\t\t\t-errorcode {TCL OO PROPERTY_FORMAT} \\\n"
-"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain parentheses\"\n"
-"\t\t\t\t}\n"
-"\t\t\t\tset realprop [string cat \"-\" $prop]\n"
-"\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n"
-"\t\t\t\tset setter [format {::set [my varname %s] $value} $prop]\n"
-"\t\t\t\tset kind readwrite\n"
-"\t\t\t\twhile {[set next [lindex $args [expr {$i + 1}]]\n"
-"\t\t\t\t\t\tstring match \"-*\" $next]} {\n"
-"\t\t\t\t\tset arg [lindex $args [incr i 2]]\n"
-"\t\t\t\t\tswitch [prefix match -error [list -level 2 -errorcode \\\n"
-"\t\t\t\t\t\t\t[list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {\n"
-"\t\t\t\t\t\t-get {\n"
-"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
-"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
-"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
-"\t\t\t\t\t\t\t\t\t\"missing body to go with -get option\"\n"
-"\t\t\t\t\t\t\t}\n"
-"\t\t\t\t\t\t\tset getter $arg\n"
-"\t\t\t\t\t\t}\n"
-"\t\t\t\t\t\t-set {\n"
-"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
-"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
-"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
-"\t\t\t\t\t\t\t\t\t\"missing body to go with -set option\"\n"
-"\t\t\t\t\t\t\t}\n"
-"\t\t\t\t\t\t\tset setter $arg\n"
-"\t\t\t\t\t\t}\n"
-"\t\t\t\t\t\t-kind {\n"
-"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
-"\t\t\t\t\t\t\t\treturn -code error -level 2\\\n"
-"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
-"\t\t\t\t\t\t\t\t\t\"missing kind value to go with -kind option\"\n"
-"\t\t\t\t\t\t\t}\n"
-"\t\t\t\t\t\t\tset kind [prefix match -message \"kind\" -error [list \\\n"
-"\t\t\t\t\t\t\t\t\t-level 2 \\\n"
-"\t\t\t\t\t\t\t\t\t-errorcode [list TCL LOOKUP INDEX kind $arg]] {\n"
-"\t\t\t\t\t\t\t\treadable readwrite writable\n"
-"\t\t\t\t\t\t\t} $arg]\n"
-"\t\t\t\t\t\t}\n"
-"\t\t\t\t\t}\n"
-"\t\t\t\t}\n"
-"\t\t\t\tset reader <ReadProp$realprop>\n"
-"\t\t\t\tset writer <WriteProp$realprop>\n"
-"\t\t\t\tswitch $kind {\n"
-"\t\t\t\t\treadable {\n"
-"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
-"\t\t\t\t\t\tuplevel 2 [list $writeslot -remove $realprop]\n"
-"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
-"\t\t\t\t\t}\n"
-"\t\t\t\t\twritable {\n"
-"\t\t\t\t\t\tuplevel 2 [list $readslot -remove $realprop]\n"
-"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
-"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
-"\t\t\t\t\t}\n"
-"\t\t\t\t\treadwrite {\n"
-"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
-"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
-"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
-"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
-"\t\t\t\t\t}\n"
-"\t\t\t\t}\n"
-"\t\t\t}\n"
-"\t\t}\n"
-"\t\tnamespace eval configurableclass {\n"
-"\t\t\t::proc property args {\n"
-"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
-"\t\t\t\t\t::oo::configuresupport::readableproperties \\\n"
-"\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n"
-"\t\t\t}\n"
+"\tnamespace eval configuresupport {\n"
+"\t\t::namespace eval configurableclass {\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::define\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
-"\t\tnamespace eval configurableobject {\n"
-"\t\t\t::proc property args {\n"
-"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
-"\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n"
-"\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n"
-"\t\t\t}\n"
+"\t\t::namespace eval configurableobject {\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::objdefine\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
-"\t\tproc ReadAll {object my} {\n"
-"\t\t\tset result {}\n"
-"\t\t\tforeach prop [info object properties $object -all -readable] {\n"
-"\t\t\t\ttry {\n"
-"\t\t\t\t\tdict set result $prop [$my <ReadProp$prop>]\n"
-"\t\t\t\t} on error {msg opt} {\n"
-"\t\t\t\t\tdict set opt -level 2\n"
-"\t\t\t\t\treturn -options $opt $msg\n"
-"\t\t\t\t} on return {msg opt} {\n"
-"\t\t\t\t\tdict incr opt -level 2\n"
-"\t\t\t\t\treturn -options $opt $msg\n"
-"\t\t\t\t} on break {} {\n"
-"\t\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n"
-"\t\t\t\t\t\t\"property getter for $prop did a break\"\n"
-"\t\t\t\t} on continue {} {\n"
-"\t\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n"
-"\t\t\t\t\t\t\"property getter for $prop did a continue\"\n"
-"\t\t\t\t}\n"
-"\t\t\t}\n"
-"\t\t\treturn $result\n"
-"\t\t}\n"
-"\t\tproc ReadOne {object my propertyName} {\n"
-"\t\t\tset props [info object properties $object -all -readable]\n"
-"\t\t\ttry {\n"
-"\t\t\t\tset prop [prefix match -message \"property\" $props $propertyName]\n"
-"\t\t\t} on error {msg} {\n"
-"\t\t\t\tcatch {\n"
-"\t\t\t\t\tset wps [info object properties $object -all -writable]\n"
-"\t\t\t\t\tset wprop [prefix match $wps $propertyName]\n"
-"\t\t\t\t\tset msg \"property \\\"$wprop\\\" is write only\"\n"
-"\t\t\t\t}\n"
-"\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
-"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName] $msg\n"
-"\t\t\t}\n"
-"\t\t\ttry {\n"
-"\t\t\t\tset value [$my <ReadProp$prop>]\n"
-"\t\t\t} on error {msg opt} {\n"
-"\t\t\t\tdict set opt -level 2\n"
-"\t\t\t\treturn -options $opt $msg\n"
-"\t\t\t} on return {msg opt} {\n"
-"\t\t\t\tdict incr opt -level 2\n"
-"\t\t\t\treturn -options $opt $msg\n"
-"\t\t\t} on break {} {\n"
-"\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n"
-"\t\t\t\t\t\"property getter for $prop did a break\"\n"
-"\t\t\t} on continue {} {\n"
-"\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n"
-"\t\t\t\t\t\"property getter for $prop did a continue\"\n"
-"\t\t\t}\n"
-"\t\t\treturn $value\n"
-"\t\t}\n"
-"\t\tproc WriteMany {object my setterMap} {\n"
-"\t\t\tset props [info object properties $object -all -writable]\n"
-"\t\t\tforeach {prop value} $setterMap {\n"
-"\t\t\t\ttry {\n"
-"\t\t\t\t\tset prop [prefix match -message \"property\" $props $prop]\n"
-"\t\t\t\t} on error {msg} {\n"
-"\t\t\t\t\tcatch {\n"
-"\t\t\t\t\t\tset rps [info object properties $object -all -readable]\n"
-"\t\t\t\t\t\tset rprop [prefix match $rps $prop]\n"
-"\t\t\t\t\t\tset msg \"property \\\"$rprop\\\" is read only\"\n"
-"\t\t\t\t\t}\n"
-"\t\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
-"\t\t\t\t\t\t\tTCL LOOKUP INDEX property $prop] $msg\n"
-"\t\t\t\t}\n"
-"\t\t\t\ttry {\n"
-"\t\t\t\t\t$my <WriteProp$prop> $value\n"
-"\t\t\t\t} on error {msg opt} {\n"
-"\t\t\t\t\tdict set opt -level 2\n"
-"\t\t\t\t\treturn -options $opt $msg\n"
-"\t\t\t\t} on return {msg opt} {\n"
-"\t\t\t\t\tdict incr opt -level 2\n"
-"\t\t\t\t\treturn -options $opt $msg\n"
-"\t\t\t\t} on break {} {\n"
-"\t\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n"
-"\t\t\t\t\t\t\"property setter for $prop did a break\"\n"
-"\t\t\t\t} on continue {} {\n"
-"\t\t\t\t\treturn -code error -level 2 -errorcode {TCL OO SHENANIGANS} \\\n"
-"\t\t\t\t\t\t\"property setter for $prop did a continue\"\n"
-"\t\t\t\t}\n"
-"\t\t\t}\n"
-"\t\t\treturn\n"
-"\t\t}\n"
-"\t\t::oo::class create configurable {\n"
-"\t\t\tprivate variable my\n"
-"\t\t\tmethod configure -export args {\n"
-"\t\t\t\t::if {![::info exists my]} {\n"
-"\t\t\t\t\t::set my [::namespace which my]\n"
-"\t\t\t\t}\n"
-"\t\t\t\t::if {[::llength $args] == 0} {\n"
-"\t\t\t\t\t::oo::configuresupport::ReadAll [self] $my\n"
-"\t\t\t\t} elseif {[::llength $args] == 1} {\n"
-"\t\t\t\t\t::oo::configuresupport::ReadOne [self] $my \\\n"
-"\t\t\t\t\t\t[::lindex $args 0]\n"
-"\t\t\t\t} elseif {[::llength $args] % 2 == 0} {\n"
-"\t\t\t\t\t::oo::configuresupport::WriteMany [self] $my $args\n"
-"\t\t\t\t} else {\n"
-"\t\t\t\t\t::return -code error -errorcode {TCL WRONGARGS} \\\n"
-"\t\t\t\t\t\t[::format {wrong # args: should be \"%s\"} \\\n"
-"\t\t\t\t\t\t\t\"[self] configure \?-option value ...\?\"]\n"
-"\t\t\t\t}\n"
-"\t\t\t}\n"
+"\t\t::oo::define configurable {\n"
"\t\t\tdefinitionnamespace -instance configurableobject\n"
"\t\t\tdefinitionnamespace -class configurableclass\n"
"\t\t}\n"
diff --git a/tests/compile.test b/tests/compile.test
index cf552e2..72eef5e 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -827,6 +827,7 @@ test compile-18.19 {disassembler - basics} -setup {
# There never was a compile-18.20.
# The keys of the dictionary produced by [getbytecode] are defined.
set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth}
+set allbytecodekeys [list {*}$bytecodekeys initiallinenumber sourcefile]
test compile-18.21 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode
} -match glob -result {wrong # args: should be "*"}
@@ -841,7 +842,7 @@ test compile-18.24 {disassembler - basics} -returnCodes error -body {
} -result "can't interpret \"\{\" as a lambda expression"
test compile-18.25 {disassembler - basics} -body {
dict keys [tcl::unsupported::getbytecode lambda {{} {}}]
-} -result "$bytecodekeys initiallinenumber sourcefile"
+} -result $allbytecodekeys
test compile-18.26 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode proc
} -match glob -result {wrong # args: should be "* proc procName"}
@@ -854,7 +855,7 @@ test compile-18.28 {disassembler - basics} -setup {
dict keys [tcl::unsupported::getbytecode proc chewonthis]
} -cleanup {
rename chewonthis {}
-} -result "$bytecodekeys initiallinenumber sourcefile"
+} -result $allbytecodekeys
test compile-18.28.1 {disassembler - tricky bit} -setup {
eval [list proc chewonthis {} {}]
} -body {
@@ -868,7 +869,7 @@ test compile-18.28.2 {disassembler - tricky bit} -setup {
dict keys [tcl::unsupported::getbytecode proc chewonthis]
} -cleanup {
rename chewonthis {}
-} -result "$bytecodekeys initiallinenumber sourcefile"
+} -result $allbytecodekeys
test compile-18.28.3 {disassembler - tricky bit} -setup {
proc Proc {n a b} {
proc $n $a $b
@@ -890,7 +891,7 @@ test compile-18.28.4 {disassembler - tricky bit} -setup {
} -cleanup {
rename Proc {}
rename chewonthis {}
-} -result "$bytecodekeys initiallinenumber sourcefile"
+} -result $allbytecodekeys
test compile-18.29 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode script
} -match glob -result {wrong # args: should be "* script script"}
@@ -919,7 +920,7 @@ test compile-18.35 {disassembler - basics} -setup {
dict keys [tcl::unsupported::getbytecode method foo bar]
} -cleanup {
foo destroy
-} -result "$bytecodekeys initiallinenumber sourcefile"
+} -result $allbytecodekeys
test compile-18.36 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode objmethod
} -match glob -result {wrong # args: should be "* objmethod objectName methodName"}
@@ -936,7 +937,7 @@ test compile-18.39 {disassembler - basics} -setup {
dict keys [tcl::unsupported::getbytecode objmethod foo bar]
} -cleanup {
foo destroy
-} -result "$bytecodekeys initiallinenumber sourcefile"
+} -result $allbytecodekeys
test compile-18.40 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::disassemble constructor
} -match glob -result {wrong # args: should be "* constructor className"}
@@ -984,7 +985,7 @@ test compile-18.48 {disassembler - basics} -setup {
dict keys [tcl::unsupported::getbytecode constructor foo]
} -cleanup {
foo destroy
-} -result "$bytecodekeys"
+} -result $allbytecodekeys
# There is no compile-18.49
test compile-18.50 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::disassemble destructor
@@ -1033,7 +1034,7 @@ test compile-18.58 {disassembler - basics} -setup {
dict keys [tcl::unsupported::getbytecode destructor foo]
} -cleanup {
foo destroy
-} -result "$bytecodekeys"
+} -result $allbytecodekeys
test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
# This will panic in a --enable-symbols=compile build, unless bug is fixed.
diff --git a/tests/oo.test b/tests/oo.test
index 769a96b..6f8d5b5 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -3620,6 +3620,76 @@ test oo-22.6 {OO and coroutines and info frame: Bug 87271f7cd6} -body {
catch {B destroy}
} -match glob -result {{* method Work class ::A *} {* method Work class ::A *}}
WorkerBase destroy
+test oo-22.7 {oo::define and info frame: correct argument line} -setup {
+ oo::class create C {
+ variable base
+ constructor {info} {set base [dict get $info line]}
+ method Relative {} {
+ set info [next]
+ if {![dict exists $info file]} {
+ error "no file-relative line info: $info"
+ }
+ expr {[dict get $info line] - $base}
+ }
+ filter Relative
+ }
+} -body {
+ C create o [info frame 0]
+ oo::define C {
+ method line1 {} {info frame 0}
+ method line2 {
+ } {info frame 0}
+ method line3 {
+ } {
+ info frame 0
+ }
+ }
+ oo::define C method line4 {} {info frame 0}
+ oo::define C method line5 {
+ } {info frame 0}
+ oo::define C method line6 {
+ } {
+ info frame 0
+ }
+ list [o line1] [o line2] [o line3] [o line4] [o line5] [o line6]
+} -cleanup {
+ C destroy
+} -result {2 4 7 10 12 15}
+test oo-22.8 {oo::objdefine and info frame: correct argument line} -setup {
+ oo::class create C {
+ variable base
+ constructor {info} {set base [dict get $info line]}
+ method Relative {} {
+ set info [next]
+ if {![dict exists $info file]} {
+ error "no file-relative line info: $info"
+ }
+ expr {[dict get $info line] - $base}
+ }
+ filter Relative
+ }
+} -body {
+ C create o [info frame 0]
+ oo::objdefine o {
+ method line1 {} {info frame 0}
+ method line2 {
+ } {info frame 0}
+ method line3 {
+ } {
+ info frame 0
+ }
+ }
+ oo::objdefine o method line4 {} {info frame 0}
+ oo::objdefine o method line5 {
+ } {info frame 0}
+ oo::objdefine o method line6 {
+ } {
+ info frame 0
+ }
+ list [o line1] [o line2] [o line3] [o line4] [o line5] [o line6]
+} -cleanup {
+ C destroy
+} -result {2 4 7 10 12 15}
# Prove that the issue in [Bug 1865054] isn't an issue any more
test oo-23.1 {Self-like derivation; complex case!} -setup {
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 0cbe5b7..fc0927c 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -470,112 +470,20 @@
# * objreadableproperties
# * objwritableproperties
#
- # Those are all slot implementations that provide access to the C layer
+ # These are all slot implementations that provide access to the C layer
# of property support (i.e., very fast cached lookup of property names).
#
+ # * StdClassProperties
+ # * StdObjectPropertes
+ #
+ # These cause very fast basic implementation methods for a property
+ # following the standard model of property implementation naming.
+ # Property schemes that use other models (such as to be more Tk-like)
+ # should not use these (or the oo::cconfigurable metaclass).
+ #
# ----------------------------------------------------------------------
- ::namespace eval configuresupport {
- namespace path ::tcl
-
- # ------------------------------------------------------------------
- #
- # oo::configuresupport --
- #
- # A metaclass that is used to make classes that can be configured.
- #
- # ------------------------------------------------------------------
-
- proc PropertyImpl {readslot writeslot args} {
- for {set i 0} {$i < [llength $args]} {incr i} {
- # Parse the property name
- set prop [lindex $args $i]
- if {[string match "-*" $prop]} {
- return -code error -level 2 \
- -errorcode {TCL OO PROPERTY_FORMAT} \
- "bad property name \"$prop\": must not begin with -"
- }
- if {$prop ne [list $prop]} {
- return -code error -level 2 \
- -errorcode {TCL OO PROPERTY_FORMAT} \
- "bad property name \"$prop\": must be a simple word"
- }
- if {[string first "::" $prop] != -1} {
- return -code error -level 2 \
- -errorcode {TCL OO PROPERTY_FORMAT} \
- "bad property name \"$prop\": must not contain namespace separators"
- }
- if {[string match {*[()]*} $prop]} {
- return -code error -level 2 \
- -errorcode {TCL OO PROPERTY_FORMAT} \
- "bad property name \"$prop\": must not contain parentheses"
- }
- set realprop [string cat "-" $prop]
- set getter [format {::set [my varname %s]} $prop]
- set setter [format {::set [my varname %s] $value} $prop]
- set kind readwrite
-
- # Parse the extra options
- while {[set next [lindex $args [expr {$i + 1}]]
- string match "-*" $next]} {
- set arg [lindex $args [incr i 2]]
- switch [prefix match -error [list -level 2 -errorcode \
- [list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {
- -get {
- if {$i >= [llength $args]} {
- return -code error -level 2 \
- -errorcode {TCL WRONGARGS} \
- "missing body to go with -get option"
- }
- set getter $arg
- }
- -set {
- if {$i >= [llength $args]} {
- return -code error -level 2 \
- -errorcode {TCL WRONGARGS} \
- "missing body to go with -set option"
- }
- set setter $arg
- }
- -kind {
- if {$i >= [llength $args]} {
- return -code error -level 2\
- -errorcode {TCL WRONGARGS} \
- "missing kind value to go with -kind option"
- }
- set kind [prefix match -message "kind" -error [list \
- -level 2 \
- -errorcode [list TCL LOOKUP INDEX kind $arg]] {
- readable readwrite writable
- } $arg]
- }
- }
- }
-
- # Install the option
- set reader <ReadProp$realprop>
- set writer <WriteProp$realprop>
- switch $kind {
- readable {
- uplevel 2 [list $readslot -append $realprop]
- uplevel 2 [list $writeslot -remove $realprop]
- uplevel 2 [list method $reader -unexport {} $getter]
- }
- writable {
- uplevel 2 [list $readslot -remove $realprop]
- uplevel 2 [list $writeslot -append $realprop]
- uplevel 2 [list method $writer -unexport {value} $setter]
- }
- readwrite {
- uplevel 2 [list $readslot -append $realprop]
- uplevel 2 [list $writeslot -append $realprop]
- uplevel 2 [list method $reader -unexport {} $getter]
- uplevel 2 [list method $writer -unexport {value} $setter]
- }
- }
- }
- }
-
+ namespace eval configuresupport {
# ------------------------------------------------------------------
#
# oo::configuresupport::configurableclass,
@@ -583,27 +491,19 @@
#
# Namespaces used as implementation vectors for oo::define and
# oo::objdefine when the class/instance is configurable.
+ # Note that these also contain commands implemented in C,
+ # especially the [property] definition command.
#
# ------------------------------------------------------------------
- namespace eval configurableclass {
- ::proc property args {
- ::oo::configuresupport::PropertyImpl \
- ::oo::configuresupport::readableproperties \
- ::oo::configuresupport::writableproperties {*}$args
- }
+ ::namespace eval configurableclass {
# Plural alias just in case; deliberately NOT documented!
::proc properties args {::tailcall property {*}$args}
::namespace path ::oo::define
::namespace export property
}
- namespace eval configurableobject {
- ::proc property args {
- ::oo::configuresupport::PropertyImpl \
- ::oo::configuresupport::objreadableproperties \
- ::oo::configuresupport::objwritableproperties {*}$args
- }
+ ::namespace eval configurableobject {
# Plural alias just in case; deliberately NOT documented!
::proc properties args {::tailcall property {*}$args}
::namespace path ::oo::objdefine
@@ -612,156 +512,15 @@
# ------------------------------------------------------------------
#
- # oo::configuresupport::ReadAll --
- #
- # The implementation of [$o configure] with no extra arguments.
- #
- # ------------------------------------------------------------------
-
- proc ReadAll {object my} {
- set result {}
- foreach prop [info object properties $object -all -readable] {
- try {
- dict set result $prop [$my <ReadProp$prop>]
- } on error {msg opt} {
- dict set opt -level 2
- return -options $opt $msg
- } on return {msg opt} {
- dict incr opt -level 2
- return -options $opt $msg
- } on break {} {
- return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \
- "property getter for $prop did a break"
- } on continue {} {
- return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \
- "property getter for $prop did a continue"
- }
- }
- return $result
- }
-
- # ------------------------------------------------------------------
- #
- # oo::configuresupport::ReadOne --
- #
- # The implementation of [$o configure -prop] with that single
- # extra argument.
- #
- # ------------------------------------------------------------------
-
- proc ReadOne {object my propertyName} {
- set props [info object properties $object -all -readable]
- try {
- set prop [prefix match -message "property" $props $propertyName]
- } on error {msg} {
- catch {
- set wps [info object properties $object -all -writable]
- set wprop [prefix match $wps $propertyName]
- set msg "property \"$wprop\" is write only"
- }
- return -code error -level 2 -errorcode [list \
- TCL LOOKUP INDEX property $propertyName] $msg
- }
- try {
- set value [$my <ReadProp$prop>]
- } on error {msg opt} {
- dict set opt -level 2
- return -options $opt $msg
- } on return {msg opt} {
- dict incr opt -level 2
- return -options $opt $msg
- } on break {} {
- return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \
- "property getter for $prop did a break"
- } on continue {} {
- return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \
- "property getter for $prop did a continue"
- }
- return $value
- }
-
- # ------------------------------------------------------------------
- #
- # oo::configuresupport::WriteMany --
- #
- # The implementation of [$o configure -prop val ?-prop val...?].
- #
- # ------------------------------------------------------------------
-
- proc WriteMany {object my setterMap} {
- set props [info object properties $object -all -writable]
- foreach {prop value} $setterMap {
- try {
- set prop [prefix match -message "property" $props $prop]
- } on error {msg} {
- catch {
- set rps [info object properties $object -all -readable]
- set rprop [prefix match $rps $prop]
- set msg "property \"$rprop\" is read only"
- }
- return -code error -level 2 -errorcode [list \
- TCL LOOKUP INDEX property $prop] $msg
- }
- try {
- $my <WriteProp$prop> $value
- } on error {msg opt} {
- dict set opt -level 2
- return -options $opt $msg
- } on return {msg opt} {
- dict incr opt -level 2
- return -options $opt $msg
- } on break {} {
- return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \
- "property setter for $prop did a break"
- } on continue {} {
- return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \
- "property setter for $prop did a continue"
- }
- }
- return
- }
-
- # ------------------------------------------------------------------
- #
# oo::configuresupport::configurable --
#
# The class that contains the implementation of the actual
# 'configure' method (mixed into actually configurable classes).
- # Great care needs to be taken in these methods as they are
- # potentially used in classes where the current namespace is set
- # up very strangely.
+ # The 'configure' method is in tclOOBasic.c.
#
# ------------------------------------------------------------------
- ::oo::class create configurable {
- private variable my
- #
- # configure --
- # Method for providing client access to the property mechanism.
- # Has a user-facing API similar to that of [chan configure].
- #
- method configure -export args {
- ::if {![::info exists my]} {
- ::set my [::namespace which my]
- }
- ::if {[::llength $args] == 0} {
- # Read all properties
- ::oo::configuresupport::ReadAll [self] $my
- } elseif {[::llength $args] == 1} {
- # Read a single property
- ::oo::configuresupport::ReadOne [self] $my \
- [::lindex $args 0]
- } elseif {[::llength $args] % 2 == 0} {
- # Set properties, one or several
- ::oo::configuresupport::WriteMany [self] $my $args
- } else {
- # Invalid call
- ::return -code error -errorcode {TCL WRONGARGS} \
- [::format {wrong # args: should be "%s"} \
- "[self] configure ?-option value ...?"]
- }
- }
-
+ ::oo::define configurable {
definitionnamespace -instance configurableobject
definitionnamespace -class configurableclass
}
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 6e20947..0c5462e 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -321,7 +321,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
tclTomMathInterface.o tclZipfs.o
OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \
- tclOOMethod.o tclOOStubInit.o
+ tclOOMethod.o tclOOProp.o tclOOStubInit.o
TOMMATH_OBJS = bn_s_mp_reverse.o bn_s_mp_mul_digs_fast.o \
bn_s_mp_sqr_fast.o bn_mp_add.o bn_mp_and.o \
@@ -494,6 +494,7 @@ OO_SRCS = \
$(GENERIC_DIR)/tclOODefineCmds.c \
$(GENERIC_DIR)/tclOOInfo.c \
$(GENERIC_DIR)/tclOOMethod.c \
+ $(GENERIC_DIR)/tclOOProp.c \
$(GENERIC_DIR)/tclOOStubInit.c
STUB_SRCS = \
@@ -1478,6 +1479,9 @@ tclOOInfo.o: $(GENERIC_DIR)/tclOOInfo.c
tclOOMethod.o: $(GENERIC_DIR)/tclOOMethod.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOMethod.c
+tclOOProp.o: $(GENERIC_DIR)/tclOOProp.c
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOProp.c
+
tclOOStubInit.o: $(GENERIC_DIR)/tclOOStubInit.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOStubInit.c
diff --git a/win/Makefile.in b/win/Makefile.in
index 37d640a..b3e5ace 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -103,6 +103,7 @@ GENERIC_DIR = $(TOP_DIR)/generic
WIN_DIR = $(TOP_DIR)/win
COMPAT_DIR = $(TOP_DIR)/compat
PKGS_DIR = $(TOP_DIR)/pkgs
+TOOL_DIR = $(TOP_DIR)/tools
ZLIB_DIR = $(COMPAT_DIR)/zlib
MINIZIP_DIR = $(ZLIB_DIR)/contrib/minizip
TOMMATH_DIR = $(TOP_DIR)/libtommath
@@ -118,6 +119,7 @@ TCL_LIBRARY_NATIVE = $(shell $(CYGPATH) '$(TCL_LIBRARY)')
GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)')
WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)')
ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)')
+TOOL_DIR_NATIVE = $(shell $(CYGPATH) '$(TOOL_DIR)')
SCRIPT_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(SCRIPT_INSTALL_DIR)')
INCLUDE_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(INCLUDE_INSTALL_DIR)')
MAN_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(MAN_INSTALL_DIR)')
@@ -340,6 +342,7 @@ GENERIC_OBJS = \
tclOODefineCmds.$(OBJEXT) \
tclOOInfo.$(OBJEXT) \
tclOOMethod.$(OBJEXT) \
+ tclOOProp.$(OBJEXT) \
tclOOStubInit.$(OBJEXT) \
tclObj.$(OBJEXT) \
tclOptimize.$(OBJEXT) \
@@ -1146,24 +1149,24 @@ $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
@echo "Developers may want to run \"make genstubs\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
+$(GENERIC_DIR)/tclOOScript.h: $(TOOL_DIR)/tclOOScript.tcl
+ @echo "Warning: tclOOScript.h may be out of date."
+ @echo "Developers may want to run \"make genscript\" to regenerate."
+ @echo "This warning can be safely ignored, do not report as a bug!"
+
genstubs:
- $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/genStubs.tcl" \
+ $(TCL_EXE) "$(TOOL_DIR_NATIVE)/genStubs.tcl" \
"$(GENERIC_DIR_NATIVE)" \
"$(GENERIC_DIR_NATIVE)/tcl.decls" \
"$(GENERIC_DIR_NATIVE)/tclInt.decls" \
"$(GENERIC_DIR_NATIVE)/tclTomMath.decls"
- $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/genStubs.tcl" \
+ $(TCL_EXE) "$(TOOL_DIR_NATIVE)/genStubs.tcl" \
"$(GENERIC_DIR_NATIVE)" \
"$(GENERIC_DIR_NATIVE)/tclOO.decls"
-$(GENERIC_DIR)/tclOOScript.h: $(TOOL_DIR)/tclOOScript.tcl
- @echo "Warning: tclOOScript.h may be out of date."
- @echo "Developers may want to run \"make genscript\" to regenerate."
- @echo "This warning can be safely ignored, do not report as a bug!"
-
genscript:
- $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/makeHeader.tcl" \
- "$(ROOT_DIR_NATIVE)/tools/tclOOScript.tcl" \
+ $(TCL_EXE) "$(TOOL_DIR_NATIVE)/makeHeader.tcl" \
+ "$(TOOL_DIR_NATIVE)/tclOOScript.tcl" \
"$(GENERIC_DIR_NATIVE)/tclOOScript.h"
#
diff --git a/win/makefile.vc b/win/makefile.vc
index 82fcc74..cba51ee 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -301,6 +301,7 @@ COREOBJS = \
$(TMP_DIR)\tclOODefineCmds.obj \
$(TMP_DIR)\tclOOInfo.obj \
$(TMP_DIR)\tclOOMethod.obj \
+ $(TMP_DIR)\tclOOProp.obj \
$(TMP_DIR)\tclOOStubInit.obj \
$(TMP_DIR)\tclObj.obj \
$(TMP_DIR)\tclOptimize.obj \
generated by cgit v0.12 at 2025-12-11 13:34:01 (GMT)