From e404d079599169631976ea93a1844a2187adce25 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 15 Nov 2019 13:50:39 +0000 Subject: Add TclOOObjectDestroyed to make logic more explicit. Renamed Deleted() to Destructing(). No functiontional changes. --- generic/tclOO.c | 44 +++++++++++++++++++++++++++++--------------- generic/tclOOInt.h | 14 ++++++-------- generic/tclOOMethod.c | 2 +- 3 files changed, 36 insertions(+), 24 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 1c2277e..c9ef94f 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -226,7 +226,7 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; * ROOT_CLASS respectively. */ -#define Deleted(oPtr) ((oPtr)->flags & OBJECT_DELETED) +#define Destructing(oPtr) ((oPtr)->flags & OBJECT_DESTRUCTING) #define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) #define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) @@ -839,7 +839,7 @@ ObjectRenamedTrace( * 2950259]. */ - if (!Deleted(oPtr)) { + if (!Destructing(oPtr)) { Tcl_DeleteNamespace(oPtr->namespacePtr); } oPtr->command = NULL; @@ -879,7 +879,7 @@ TclOODeleteDescendants( * clsPtr */ - if (!Deleted(mixinSubclassPtr->thisPtr) + if (!Destructing(mixinSubclassPtr->thisPtr) && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, mixinSubclassPtr->thisPtr->command); @@ -898,7 +898,7 @@ TclOODeleteDescendants( if (clsPtr->subclasses.num > 0) { while (clsPtr->subclasses.num > 0) { subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1]; - if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr) + if (!Destructing(subclassPtr->thisPtr) && !IsRoot(subclassPtr) && !(subclassPtr->thisPtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); @@ -924,7 +924,7 @@ TclOODeleteDescendants( * This condition also covers the case where instancePtr == oPtr */ - if (!Deleted(instancePtr) && !IsRoot(instancePtr) && + if (!Destructing(instancePtr) && !IsRoot(instancePtr) && !(instancePtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, instancePtr->command); } @@ -965,7 +965,7 @@ TclOOReleaseClassContents( * Sanity check! */ - if (!Deleted(oPtr)) { + if (!Destructing(oPtr)) { if (IsRootClass(oPtr)) { Tcl_Panic("deleting class structure for non-deleted %s", "::oo::class"); @@ -1063,7 +1063,7 @@ TclOOReleaseClassContents( ckfree(clsPtr->variables.list); } - if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { + if (IsRootClass(oPtr) && !Destructing(fPtr->objectCls->thisPtr)) { Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); } } @@ -1095,7 +1095,7 @@ ObjectNamespaceDeleted( Tcl_Interp *interp = oPtr->fPtr->interp; int i; - if (Deleted(oPtr)) { + if (Destructing(oPtr)) { /* * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, * this guard could be removed. @@ -1108,7 +1108,7 @@ ObjectNamespaceDeleted( * process of being deleted, nothing else may modify its bookeeping * records. This is the flag that */ - oPtr->flags |= OBJECT_DELETED; + oPtr->flags |= OBJECT_DESTRUCTING; /* * Let the dominoes fall! @@ -1242,7 +1242,7 @@ ObjectNamespaceDeleted( * sometimes not go away automatically; we force it here. [Bug 2962664] */ - if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) + if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr) && !Tcl_InterpDeleted(interp)) { Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); @@ -1287,6 +1287,20 @@ int TclOODecrRefCount(Object *oPtr) { } /* + * ---------------------------------------------------------------------- + * + * TclOOObjectDestroyed -- + * + * Returns TCL_OK if an object is entirely deleted, i.e. the destruction + * sequence has completed. + * + * ---------------------------------------------------------------------- + */ +int TclOOObjectDestroyed(Object *oPtr) { + oPtr->namespacePtr == NULL; +} + +/* * Setting the "empty" location to NULL makes debugging a little easier. */ @@ -1446,7 +1460,7 @@ TclOOAddToSubclasses( * is assumed that the class is not already * present as a subclass in the superclass. */ { - if (Deleted(superPtr->thisPtr)) { + if (Destructing(superPtr->thisPtr)) { return; } if (superPtr->subclasses.num >= superPtr->subclasses.size) { @@ -1511,7 +1525,7 @@ TclOOAddToMixinSubs( * is assumed that the class is not already * present as a subclass in the superclass. */ { - if (Deleted(superPtr->thisPtr)) { + if (Destructing(superPtr->thisPtr)) { return; } if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) { @@ -1809,7 +1823,7 @@ FinalizeAlloc( * Don't want to lose errors by accident. [Bug 2903011] */ - if (result != TCL_ERROR && Deleted(oPtr)) { + if (result != TCL_ERROR && Destructing(oPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object deleted in constructor", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); @@ -1824,7 +1838,7 @@ FinalizeAlloc( * command before we delete it. [Bug 9dd1bd7a74] */ - if (!Deleted(oPtr)) { + if (!Destructing(oPtr)) { (void) TclOOObjectName(interp, oPtr); Tcl_DeleteCommandFromToken(interp, oPtr->command); } @@ -1961,7 +1975,7 @@ Tcl_CopyObjectInstance( */ o2Ptr->flags = oPtr->flags & ~( - OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); + OBJECT_DESTRUCTING | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); /* * Copy the object's metadata. diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 436acd6..0e4503a 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -189,14 +189,11 @@ typedef struct Object { LIST_STATIC(Tcl_Obj *) variables; } Object; -#define OBJECT_DELETED 1 /* Flag to say that an object has been - * destroyed. */ -#define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been - * called. */ -#define CLASS_GONE 4 /* Obsolete. Indicates that the class of this - * object has been deleted, and so the object - * should not attempt to remove itself from its - * class. */ +#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has + * been destroyed */ +#define 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 * the class hierarchy and should be treated * specially during teardown. */ @@ -497,6 +494,7 @@ MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, const char *nameStr, const char *nsNameStr); MODULE_SCOPE int TclOODecrRefCount(Object *oPtr); +MODULE_SCOPE int TclOOObjectDestroyed(Object *oPtr); MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 0c5f4bb..6f2612c 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -675,7 +675,7 @@ InvokeProcedureMethod( * the next thing in the chain. */ - if (!((CallContext *)context)->oPtr->namespacePtr || + if (!TclOOObjectDestroyed(((CallContext *)context)->oPtr) || Tcl_InterpDeleted(interp) ) { return TclNRObjectContextInvokeNext(interp, context, objc, objv, -- cgit v0.12 From 88e67d27d81cf6f4ddf89d85134b99f2e7950f66 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Nov 2019 15:42:19 +0000 Subject: fix compliation warning, resulting from previous commit --- generic/tclOO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index c9ef94f..c1db80c 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1297,7 +1297,7 @@ int TclOODecrRefCount(Object *oPtr) { * ---------------------------------------------------------------------- */ int TclOOObjectDestroyed(Object *oPtr) { - oPtr->namespacePtr == NULL; + return (oPtr->namespacePtr == NULL); } /* -- cgit v0.12 From 12a22416413a587980cbb7d9c9bc361db5f3e419 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Nov 2019 15:49:33 +0000 Subject: Fix test-case event-11.8, failing as a result of the TclOOObjectDestroyed() function restructuring. --- generic/tclOOMethod.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 6f2612c..493c936 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -675,7 +675,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, -- cgit v0.12