summaryrefslogtreecommitdiffstats
path: root/generic/tclOO.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclOO.c')
-rw-r--r--generic/tclOO.c386
1 files changed, 252 insertions, 134 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 8ac2039..6300d80 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -28,27 +28,20 @@ static const struct {
{"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
{"destructor", TclOODefineDestructorObjCmd, 0},
{"export", TclOODefineExportObjCmd, 0},
- {"filter", TclOODefineFilterObjCmd, 0},
{"forward", TclOODefineForwardObjCmd, 0},
{"method", TclOODefineMethodObjCmd, 0},
- {"mixin", TclOODefineMixinObjCmd, 0},
{"renamemethod", TclOODefineRenameMethodObjCmd, 0},
{"self", TclOODefineSelfObjCmd, 0},
- {"superclass", TclOODefineSuperclassObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 0},
- {"variable", TclOODefineVariablesObjCmd, 0},
{NULL, NULL, 0}
}, objdefCmds[] = {
{"class", TclOODefineClassObjCmd, 1},
{"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
{"export", TclOODefineExportObjCmd, 1},
- {"filter", TclOODefineFilterObjCmd, 1},
{"forward", TclOODefineForwardObjCmd, 1},
{"method", TclOODefineMethodObjCmd, 1},
- {"mixin", TclOODefineMixinObjCmd, 1},
{"renamemethod", TclOODefineRenameMethodObjCmd, 1},
{"unexport", TclOODefineUnexportObjCmd, 1},
- {"variable", TclOODefineVariablesObjCmd, 1},
{NULL, NULL, 0}
};
@@ -79,7 +72,7 @@ static int FinalizeNext(ClientData data[],
Tcl_Interp *interp, int result);
static int FinalizeObjectCall(ClientData data[],
Tcl_Interp *interp, int result);
-static void InitFoundation(Tcl_Interp *interp);
+static int InitFoundation(Tcl_Interp *interp);
static void KillFoundation(ClientData clientData,
Tcl_Interp *interp);
static void MyDeleted(ClientData clientData);
@@ -136,6 +129,35 @@ static char initScript[] =
/* "tcl_findLibrary tcloo $oo::version $oo::version" */
/* " tcloo.tcl OO_LIBRARY oo::library;"; */
+static const char *slotScript =
+"::oo::define ::oo::Slot {\n"
+" method Get {} {error unimplemented}\n"
+" method Set list {error unimplemented}\n"
+" method -set args {\n"
+" uplevel 1 [list [namespace which my] Set $args]\n"
+" }\n"
+" method -append args {\n"
+" uplevel 1 [list [namespace which my] Set [list"
+" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
+" }\n"
+" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
+" forward --default-operation my -append\n"
+" method unknown {args} {\n"
+" set def --default-operation\n"
+" if {[llength $args] == 0} {\n"
+" return [uplevel 1 [list [namespace which my] $def]]\n"
+" } elseif {![string match -* [lindex $args 0]]} {\n"
+" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
+" }\n"
+" next {*}$args\n"
+" }\n"
+" export -set -append -clear\n"
+" unexport unknown destroy\n"
+"}\n"
+"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
+"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
+"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
+
MODULE_SCOPE const TclOOStubs tclOOStubs;
/*
@@ -144,6 +166,17 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
#define GetFoundation(interp) \
((Foundation *)((Interp *)(interp))->objectFoundation)
+
+/*
+ * Macros to make inspecting into the guts of an object cleaner. Note that the
+ * roots oo::object and oo::class have _both_ their object and class flags
+ * tagged with ROOT_OBJECT and ROOT_CLASS respectively.
+ */
+
+#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL)
+#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
+#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
+#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
/*
* ----------------------------------------------------------------------
@@ -170,7 +203,9 @@ TclOOInit(
* Build the core of the OO system.
*/
- InitFoundation(interp);
+ if (InitFoundation(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
/*
* Run our initialization script and, if that works, declare the package
@@ -214,7 +249,7 @@ TclOOGetFoundation(
* ----------------------------------------------------------------------
*/
-static void
+static int
InitFoundation(
Tcl_Interp *interp)
{
@@ -292,11 +327,13 @@ InitFoundation(
AllocObject(interp, "::oo::class", NULL));
fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+ fPtr->objectCls->flags |= ROOT_OBJECT;
fPtr->objectCls->superclasses.num = 0;
ckfree(fPtr->objectCls->superclasses.list);
fPtr->objectCls->superclasses.list = NULL;
fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
+ fPtr->classCls->flags |= ROOT_CLASS;
TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
AddRef(fPtr->objectCls->thisPtr);
@@ -357,6 +394,15 @@ InitFoundation(
NULL);
Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
TclOOInitInfo(interp);
+
+ /*
+ * Now make the class of slots.
+ */
+
+ if (TclOODefineSlots(fPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return Tcl_Eval(interp, slotScript);
}
/*
@@ -669,8 +715,7 @@ ObjectRenamedTrace(
int flags) /* Why was the object deleted? */
{
Object *oPtr = clientData;
- Class *clsPtr;
- CallContext *contextPtr;
+ Foundation *fPtr = oPtr->fPtr;
/*
* If this is a rename and not a delete of the object, we just flush the
@@ -702,17 +747,20 @@ ObjectRenamedTrace(
*/
AddRef(oPtr);
+ AddRef(fPtr->classCls);
+ AddRef(fPtr->objectCls);
+ AddRef(fPtr->classCls->thisPtr);
+ AddRef(fPtr->objectCls->thisPtr);
oPtr->command = NULL;
- oPtr->flags |= OBJECT_DELETED;
- if (!(oPtr->flags & DESTRUCTOR_CALLED) && (!Tcl_InterpDeleted(interp)
- || (oPtr->flags & (ROOT_OBJECT|ROOT_CLASS)))) {
- contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {
+ CallContext *contextPtr =
+ TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ int result;
+ Tcl_InterpState state;
+
oPtr->flags |= DESTRUCTOR_CALLED;
if (contextPtr != NULL) {
- int result;
- Tcl_InterpState state;
-
contextPtr->callPtr->flags |= DESTRUCTOR;
contextPtr->skip = 0;
state = Tcl_SaveInterpState(interp, TCL_OK);
@@ -731,25 +779,20 @@ ObjectRenamedTrace(
* and nuke the namespace (which triggers the final crushing of the object
* structure itself).
*
- * The class of classes needs some special care; if it is deleted (and
+ * The class of objects needs some special care; if it is deleted (and
* we're not killing the whole interpreter) we force the delete of the
- * class of objects now as well. Due to the incestuous nature of those two
+ * class of classes now as well. Due to the incestuous nature of those two
* classes, if one goes the other must too and yet the tangle can
* sometimes not go away automatically; we force it here. [Bug 2962664]
*/
- if (!Tcl_InterpDeleted(interp)) {
- if ((oPtr->flags & ROOT_OBJECT) && oPtr->fPtr->classCls != NULL) {
- Tcl_DeleteCommandFromToken(interp,
- oPtr->fPtr->classCls->thisPtr->command);
- } else if (oPtr->flags & ROOT_CLASS) {
- oPtr->fPtr->classCls = NULL;
- }
+ if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
+ && !Deleted(fPtr->classCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
}
- clsPtr = oPtr->classPtr;
- if (clsPtr != NULL) {
- AddRef(clsPtr);
+ if (oPtr->classPtr != NULL) {
+ AddRef(oPtr->classPtr);
ReleaseClassContents(interp, oPtr);
}
@@ -761,9 +804,13 @@ ObjectRenamedTrace(
if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
Tcl_DeleteNamespace(oPtr->namespacePtr);
}
- if (clsPtr) {
- DelRef(clsPtr);
+ if (oPtr->classPtr) {
+ DelRef(oPtr->classPtr);
}
+ DelRef(fPtr->classCls->thisPtr);
+ DelRef(fPtr->objectCls->thisPtr);
+ DelRef(fPtr->classCls);
+ DelRef(fPtr->objectCls);
DelRef(oPtr);
}
@@ -783,77 +830,128 @@ ReleaseClassContents(
Tcl_Interp *interp, /* The interpreter containing the class. */
Object *oPtr) /* The object representing the class. */
{
- int i, n;
- Class *clsPtr = oPtr->classPtr, **list;
- Object **insts;
+ FOREACH_HASH_DECLS;
+ int i;
+ Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
+ Object *instancePtr;
+ Foundation *fPtr = oPtr->fPtr;
/*
- * Must empty list before processing the members of the list so that
- * things happen in the correct order even if something tries to play
- * fast-and-loose.
+ * Sanity check!
*/
- list = clsPtr->mixinSubs.list;
- n = clsPtr->mixinSubs.num;
- clsPtr->mixinSubs.list = NULL;
- clsPtr->mixinSubs.num = 0;
- clsPtr->mixinSubs.size = 0;
- for (i=0 ; i<n ; i++) {
- AddRef(list[i]);
- AddRef(list[i]->thisPtr);
+ if (!Deleted(oPtr)) {
+ if (IsRootClass(oPtr)) {
+ Tcl_Panic("deleting class structure for non-deleted %s",
+ "::oo::class");
+ } else if (IsRootObject(oPtr)) {
+ Tcl_Panic("deleting class structure for non-deleted %s",
+ "::oo::object");
+ } else {
+ Tcl_Panic("deleting class structure for non-deleted %s",
+ "general object");
+ }
}
- for (i=0 ; i<n ; i++) {
- if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) {
- list[i]->thisPtr->flags |= OBJECT_DELETED;
- Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+
+ /*
+ * Lock a number of dependent objects until we've stopped putting our
+ * fingers in them.
+ */
+
+ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
+ if (mixinSubclassPtr != NULL) {
+ AddRef(mixinSubclassPtr);
+ AddRef(mixinSubclassPtr->thisPtr);
}
- DelRef(list[i]->thisPtr);
- DelRef(list[i]);
}
- if (list != NULL) {
- ckfree(list);
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
+ AddRef(subclassPtr);
+ AddRef(subclassPtr->thisPtr);
+ }
}
-
- list = clsPtr->subclasses.list;
- n = clsPtr->subclasses.num;
- clsPtr->subclasses.list = NULL;
- clsPtr->subclasses.num = 0;
- clsPtr->subclasses.size = 0;
- for (i=0 ; i<n ; i++) {
- AddRef(list[i]);
- AddRef(list[i]->thisPtr);
+ if (!IsRootClass(oPtr)) {
+ FOREACH(instancePtr, clsPtr->instances) {
+ if (instancePtr != NULL && !IsRoot(instancePtr)) {
+ AddRef(instancePtr);
+ }
+ }
}
- for (i=0 ; i<n ; i++) {
- if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) {
- list[i]->thisPtr->flags |= OBJECT_DELETED;
- Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+
+ /*
+ * Squelch classes that this class has been mixed into.
+ */
+
+ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
+ if (mixinSubclassPtr == NULL) {
+ continue;
}
- DelRef(list[i]->thisPtr);
- DelRef(list[i]);
+ if (!Deleted(mixinSubclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp,
+ mixinSubclassPtr->thisPtr->command);
+ }
+ DelRef(mixinSubclassPtr->thisPtr);
+ DelRef(mixinSubclassPtr);
}
- if (list != NULL) {
- ckfree(list);
+ if (clsPtr->mixinSubs.list != NULL) {
+ ckfree(clsPtr->mixinSubs.list);
+ clsPtr->mixinSubs.list = NULL;
+ clsPtr->mixinSubs.num = 0;
}
- insts = clsPtr->instances.list;
- n = clsPtr->instances.num;
- clsPtr->instances.list = NULL;
- clsPtr->instances.num = 0;
- clsPtr->instances.size = 0;
- for (i=0 ; i<n ; i++) {
- AddRef(insts[i]);
+ /*
+ * Squelch subclasses of this class.
+ */
+
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ if (subclassPtr == NULL || IsRoot(subclassPtr)) {
+ continue;
+ }
+ if (!Deleted(subclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
+ }
+ DelRef(subclassPtr->thisPtr);
+ DelRef(subclassPtr);
+ }
+ if (clsPtr->subclasses.list != NULL) {
+ ckfree(clsPtr->subclasses.list);
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.num = 0;
}
- for (i=0 ; i<n ; i++) {
- if (!(insts[i]->flags & OBJECT_DELETED)) {
- insts[i]->flags |= OBJECT_DELETED;
- Tcl_DeleteCommandFromToken(interp, insts[i]->command);
+
+ /*
+ * Squelch instances of this class (includes objects we're mixed into).
+ */
+
+ if (!IsRootClass(oPtr)) {
+ FOREACH(instancePtr, clsPtr->instances) {
+ if (instancePtr == NULL || IsRoot(instancePtr)) {
+ continue;
+ }
+ if (!Deleted(instancePtr)) {
+ Tcl_DeleteCommandFromToken(interp, instancePtr->command);
+ }
+ DelRef(instancePtr);
}
- DelRef(insts[i]);
}
- if (insts != NULL) {
- ckfree(insts);
+ if (clsPtr->instances.list != NULL) {
+ ckfree(clsPtr->instances.list);
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.num = 0;
+ }
+
+ /*
+ * Special: We delete these after everything else.
+ */
+
+ if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
}
+ /*
+ * Squelch method implementation chain caches.
+ */
+
if (clsPtr->constructorChainPtr) {
TclOODeleteChain(clsPtr->constructorChainPtr);
clsPtr->constructorChainPtr = NULL;
@@ -863,7 +961,6 @@ ReleaseClassContents(
clsPtr->destructorChainPtr = NULL;
}
if (clsPtr->classChainCache) {
- FOREACH_HASH_DECLS;
CallChain *callPtr;
FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
@@ -874,6 +971,10 @@ ReleaseClassContents(
clsPtr->classChainCache = NULL;
}
+ /*
+ * Squelch our filter list.
+ */
+
if (clsPtr->filters.num) {
Tcl_Obj *filterObj;
@@ -884,9 +985,11 @@ ReleaseClassContents(
clsPtr->filters.num = 0;
}
+ /*
+ * Squelch our metadata.
+ */
if (clsPtr->metadataPtr != NULL) {
- FOREACH_HASH_DECLS;
Tcl_ObjectMetadataType *metadataTypePtr;
ClientData value;
@@ -922,7 +1025,7 @@ ObjectNamespaceDeleted(
Class *clsPtr = oPtr->classPtr, *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
- int i, preserved = !(oPtr->flags & OBJECT_DELETED);
+ int i;
/*
* Instruct everyone to no longer use any allocated fields of the object.
@@ -931,27 +1034,19 @@ ObjectNamespaceDeleted(
* point into freed memory, allowing crashes.
*/
- oPtr->flags |= OBJECT_DELETED;
if (oPtr->command) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
}
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
}
- if (preserved) {
- AddRef(oPtr);
- if (clsPtr != NULL) {
- AddRef(clsPtr);
- ReleaseClassContents(NULL, oPtr);
- }
- }
/*
* Splice the object out of its context. After this, we must *not* call
* methods on the object.
*/
- if (!(oPtr->flags & ROOT_OBJECT)) {
+ if (!IsRootObject(oPtr)) {
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
}
@@ -1007,11 +1102,10 @@ ObjectNamespaceDeleted(
if (clsPtr != NULL) {
Class *superPtr;
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
if (clsPtr->metadataPtr != NULL) {
- Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value;
-
FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
metadataTypePtr->deleteProc(value);
}
@@ -1028,7 +1122,7 @@ ObjectNamespaceDeleted(
clsPtr->filters.num = 0;
}
FOREACH(mixinPtr, clsPtr->mixins) {
- if (!(mixinPtr->thisPtr->flags & OBJECT_DELETED)) {
+ if (!Deleted(mixinPtr->thisPtr)) {
TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
}
}
@@ -1037,7 +1131,7 @@ ObjectNamespaceDeleted(
clsPtr->mixins.num = 0;
}
FOREACH(superPtr, clsPtr->superclasses) {
- if (!(superPtr->thisPtr->flags & OBJECT_DELETED)) {
+ if (!Deleted(superPtr->thisPtr)) {
TclOORemoveFromSubclasses(clsPtr, superPtr);
}
}
@@ -1080,12 +1174,6 @@ ObjectNamespaceDeleted(
*/
DelRef(oPtr);
- if (preserved) {
- if (clsPtr) {
- DelRef(clsPtr);
- }
- DelRef(oPtr);
- }
}
/*
@@ -1116,12 +1204,16 @@ TclOORemoveFromInstances(
return;
removeInstance:
- clsPtr->instances.num--;
- if (i < clsPtr->instances.num) {
- clsPtr->instances.list[i] =
- clsPtr->instances.list[clsPtr->instances.num];
+ if (Deleted(clsPtr->thisPtr)) {
+ clsPtr->instances.list[i] = NULL;
+ } else {
+ clsPtr->instances.num--;
+ if (i < clsPtr->instances.num) {
+ clsPtr->instances.list[i] =
+ clsPtr->instances.list[clsPtr->instances.num];
+ }
+ clsPtr->instances.list[clsPtr->instances.num] = NULL;
}
- clsPtr->instances.list[clsPtr->instances.num] = NULL;
}
/*
@@ -1142,6 +1234,9 @@ TclOOAddToInstances(
* assumed that the class is not already
* present as an instance in the class. */
{
+ if (Deleted(clsPtr->thisPtr)) {
+ return;
+ }
if (clsPtr->instances.num >= clsPtr->instances.size) {
clsPtr->instances.size += ALLOC_CHUNK;
if (clsPtr->instances.size == ALLOC_CHUNK) {
@@ -1182,12 +1277,16 @@ TclOORemoveFromSubclasses(
return;
removeSubclass:
- superPtr->subclasses.num--;
- if (i < superPtr->subclasses.num) {
- superPtr->subclasses.list[i] =
- superPtr->subclasses.list[superPtr->subclasses.num];
+ if (Deleted(superPtr->thisPtr)) {
+ superPtr->subclasses.list[i] = NULL;
+ } else {
+ superPtr->subclasses.num--;
+ if (i < superPtr->subclasses.num) {
+ superPtr->subclasses.list[i] =
+ superPtr->subclasses.list[superPtr->subclasses.num];
+ }
+ superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
}
- superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
}
/*
@@ -1208,6 +1307,9 @@ TclOOAddToSubclasses(
* is assumed that the class is not already
* present as a subclass in the superclass. */
{
+ if (Deleted(superPtr->thisPtr)) {
+ return;
+ }
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
@@ -1248,12 +1350,16 @@ TclOORemoveFromMixinSubs(
return;
removeSubclass:
- superPtr->mixinSubs.num--;
- if (i < superPtr->mixinSubs.num) {
- superPtr->mixinSubs.list[i] =
- superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+ if (Deleted(superPtr->thisPtr)) {
+ superPtr->mixinSubs.list[i] = NULL;
+ } else {
+ superPtr->mixinSubs.num--;
+ if (i < superPtr->mixinSubs.num) {
+ superPtr->mixinSubs.list[i] =
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+ }
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
}
- superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
}
/*
@@ -1274,6 +1380,9 @@ TclOOAddToMixinSubs(
* is assumed that the class is not already
* present as a subclass in the superclass. */
{
+ if (Deleted(superPtr->thisPtr)) {
+ return;
+ }
if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
superPtr->mixinSubs.size += ALLOC_CHUNK;
if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
@@ -1460,7 +1569,7 @@ Tcl_NewObjectInstance(
* errors by accident...) [Bug 2903011]
*/
- if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+ if (result != TCL_ERROR && Deleted(oPtr)) {
Tcl_SetResult(interp, "object deleted in constructor",
TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
@@ -1475,7 +1584,7 @@ Tcl_NewObjectInstance(
* bad. [Bug 2903011]
*/
- if (!(flags & OBJECT_DELETED)) {
+ if (!Deleted(oPtr)) {
Tcl_DeleteCommandFromToken(interp, oPtr->command);
}
return NULL;
@@ -1572,6 +1681,7 @@ TclNRNewObjectInstance(
* Fire off the constructors non-recursively.
*/
+ AddRef(oPtr);
TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
objectPtr);
TclPushTailcallPoint(interp);
@@ -1588,7 +1698,7 @@ FinalizeAlloc(
Object *oPtr = data[1];
Tcl_InterpState state = data[2];
Tcl_Object *objectPtr = data[3];
- int flags = oPtr->flags;
+ //int flags = oPtr->flags;
/*
* It's an error if the object was whacked in the constructor. Force this
@@ -1596,7 +1706,7 @@ FinalizeAlloc(
* [Bug 2903011]
*/
- if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+ if (result != TCL_ERROR && Deleted(oPtr)) {
Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
@@ -1610,13 +1720,15 @@ FinalizeAlloc(
* 2903011]
*/
- if (!(flags & OBJECT_DELETED)) {
+ if (!Deleted(oPtr)) {
Tcl_DeleteCommandFromToken(interp, oPtr->command);
}
+ DelRef(oPtr);
return TCL_ERROR;
}
Tcl_RestoreInterpState(interp, state);
*objectPtr = (Tcl_Object) oPtr;
+ DelRef(oPtr);
return TCL_OK;
}
@@ -1656,7 +1768,7 @@ Tcl_CopyObjectInstance(
Tcl_SetErrorCode(interp, "TCL", "OO", "NO_COPY_TARGET", NULL);
return NULL;
}
- if (oPtr->flags & ROOT_CLASS) {
+ if (IsRootClass(oPtr)) {
Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
return NULL;
@@ -1728,7 +1840,7 @@ Tcl_CopyObjectInstance(
*/
o2Ptr->flags = oPtr->flags & ~(
- OBJECT_DELETED | ROOT_OBJECT | FILTER_HANDLING);
+ OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
/*
* Copy the object's metadata.
@@ -2254,9 +2366,15 @@ TclOOObjectCmdCore(
Tcl_Obj *methodNamePtr;
int result;
+ /*
+ * If we've no method name, throw this directly into the unknown
+ * processing.
+ */
+
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
- return TCL_ERROR;
+ flags |= FORCE_UNKNOWN;
+ methodNamePtr = NULL;
+ goto noMapping;
}
/*
@@ -2710,7 +2828,7 @@ int
Tcl_ObjectDeleted(
Tcl_Object object)
{
- return (((Object *)object)->flags & OBJECT_DELETED) ? 1 : 0;
+ return Deleted(object) ? 1 : 0;
}
Tcl_Object