summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclOO.c30
-rw-r--r--generic/tclOODefineCmds.c10
-rw-r--r--generic/tclOOInt.h6
3 files changed, 34 insertions, 12 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c
index e6c86c7..7ae6ac0 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOO.c,v 1.33 2010/02/15 22:56:20 nijtmans Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.34 2010/03/04 23:42:53 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -297,6 +297,7 @@ InitFoundation(
ckfree((char *) fPtr->objectCls->superclasses.list);
fPtr->objectCls->superclasses.list = NULL;
fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
+ fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
AddRef(fPtr->objectCls->thisPtr);
@@ -705,8 +706,7 @@ ObjectRenamedTrace(
oPtr->flags |= OBJECT_DELETED;
if (!(oPtr->flags & DESTRUCTOR_CALLED) && (!Tcl_InterpDeleted(interp)
- || (oPtr != oPtr->fPtr->objectCls->thisPtr
- && oPtr != oPtr->fPtr->classCls->thisPtr))) {
+ || (oPtr->flags & (ROOT_OBJECT|ROOT_CLASS)))) {
contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
oPtr->flags |= DESTRUCTOR_CALLED;
if (contextPtr != NULL) {
@@ -731,15 +731,33 @@ ObjectRenamedTrace(
* and nuke the namespace (which triggers the final crushing of the object
* structure itself).
*
- * The namespace is only deleted if it hasn't already been deleted. [Bug
- * 2950259]
+ * The class of classes 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
+ * 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;
+ }
+ }
+
clsPtr = oPtr->classPtr;
if (clsPtr != NULL) {
AddRef(clsPtr);
ReleaseClassContents(interp, oPtr);
}
+
+ /*
+ * The namespace is only deleted if it hasn't already been deleted. [Bug
+ * 2950259]
+ */
+
if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
Tcl_DeleteNamespace(oPtr->namespacePtr);
}
@@ -1644,7 +1662,7 @@ Tcl_CopyObjectInstance(
NULL);
return NULL;
}
- if (oPtr->classPtr == GetFoundation(interp)->classCls) {
+ if (oPtr->flags & ROOT_CLASS) {
Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
return NULL;
}
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 2fb9ce5..ad088af 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOODefineCmds.c,v 1.11 2009/05/04 17:39:51 dkf Exp $
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.12 2010/03/04 23:42:54 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -1043,12 +1043,12 @@ TclOODefineClassObjCmd(
if (oPtr == NULL) {
return TCL_ERROR;
}
- if (oPtr == fPtr->objectCls->thisPtr) {
+ if (oPtr->flags & ROOT_OBJECT) {
Tcl_AppendResult(interp,
- "may not modify the class of the root object", NULL);
+ "may not modify the class of the root object class", NULL);
return TCL_ERROR;
}
- if (oPtr == fPtr->classCls->thisPtr) {
+ if (oPtr->flags & ROOT_CLASS) {
Tcl_AppendResult(interp,
"may not modify the class of the class of classes", NULL);
return TCL_ERROR;
@@ -1679,7 +1679,7 @@ TclOODefineSuperclassObjCmd(
NULL);
return TCL_ERROR;
}
- if (oPtr == fPtr->objectCls->thisPtr) {
+ if (oPtr->flags & ROOT_OBJECT) {
Tcl_AppendResult(interp,
"may not modify the superclass of the root object", NULL);
return TCL_ERROR;
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index dc52638..2103dc0 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOInt.h,v 1.15 2010/01/29 16:17:20 nijtmans Exp $
+ * RCS: @(#) $Id: tclOOInt.h,v 1.16 2010/03/04 23:42:54 dkf Exp $
*/
#ifndef TCL_OO_INTERNAL_H
@@ -212,6 +212,10 @@ typedef struct Object {
* 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
+ * class of classes, and should be treated
+ * specially during teardown (and in a few
+ * other spots). */
/*
* And the definition of a class. Note that every class also has an associated