Convert MixinClassDelegates to an internal function entirely in C

5 files changed, 134 insertions, 73 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index ec20537..0ef69a4 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -370,7 +370,6 @@ InitFoundation(
     TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
     TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
     TclNewLiteralStringObj(fPtr->myName, "my");
-    TclNewLiteralStringObj(fPtr->mcdName, "::oo::MixinClassDelegates");
     TclNewLiteralStringObj(fPtr->slotGetName, "Get");
     TclNewLiteralStringObj(fPtr->slotSetName, "Set");
     TclNewLiteralStringObj(fPtr->slotResolveName, "Resolve");
@@ -381,7 +380,6 @@ InitFoundation(
     Tcl_IncrRefCount(fPtr->clonedName);
     Tcl_IncrRefCount(fPtr->defineName);
     Tcl_IncrRefCount(fPtr->myName);
-    Tcl_IncrRefCount(fPtr->mcdName);
     Tcl_IncrRefCount(fPtr->slotGetName);
     Tcl_IncrRefCount(fPtr->slotSetName);
     Tcl_IncrRefCount(fPtr->slotResolveName);
@@ -631,7 +629,6 @@ KillFoundation(
     TclDecrRefCount(fPtr->clonedName);
     TclDecrRefCount(fPtr->defineName);
     TclDecrRefCount(fPtr->myName);
-    TclDecrRefCount(fPtr->mcdName);
     TclDecrRefCount(fPtr->slotGetName);
     TclDecrRefCount(fPtr->slotSetName);
     TclDecrRefCount(fPtr->slotResolveName);
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 44d8cb6..18dd5e9 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -19,7 +19,7 @@
 
 static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
 static Tcl_NRPostProc	AfterNRDestructor;
-static Tcl_NRPostProc	DecrRefsPostClassConstructor;
+static Tcl_NRPostProc	PostClassConstructor;
 static Tcl_NRPostProc	FinalizeConstruction;
 static Tcl_NRPostProc	FinalizeEval;
 static Tcl_NRPostProc	NextRestoreFrame;
@@ -68,6 +68,119 @@ FinalizeConstruction(
 /*
  * ----------------------------------------------------------------------
  *
+ * MixinClassDelegates --
+ *
+ *	Internal utility for setting up the class delegate.
+ *	Runs after the class has called [oo::define] on its argument.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+// Look up the delegate for a class.
+static inline Class *
+GetClassDelegate(
+    Tcl_Interp *interp,
+    Class *clsPtr)
+{
+    Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
+	    clsPtr->thisPtr->namespacePtr->fullName);
+    Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
+    Tcl_DecrRefCount(delegateName);
+    return delegatePtr;
+}
+
+/*
+ * Patches in the appropriate class delegates' superclasses.
+ * Sonewhat nessy because the list of superclasses isn't modified frequently.
+ */
+static inline void
+SetDelegateSuperclasses(
+    Tcl_Interp *interp,
+    Class *clsPtr,
+    Class *delegatePtr)
+{
+    // Build new list of superclasses
+    int i, j = delegatePtr->superclasses.num, k;
+    Class *superPtr, **supers = (Class **) Tcl_Alloc(sizeof(Class *) *
+	    (delegatePtr->superclasses.num + clsPtr->superclasses.num));
+    if (delegatePtr->superclasses.num) {
+	memcpy(supers, delegatePtr->superclasses.list,
+		sizeof(Class *) * delegatePtr->superclasses.num);
+    }
+    FOREACH(superPtr, clsPtr->superclasses) {
+	Class *superDelegatePtr = GetClassDelegate(interp, superPtr);
+	if (!superDelegatePtr) {
+	    continue;
+	}
+	for (k=0 ; k<=j ; k++) {
+	    if (k == j) {
+		supers[j++] = superDelegatePtr;
+		TclOOAddToSubclasses(delegatePtr, superDelegatePtr);
+		AddRef(superDelegatePtr->thisPtr);
+		break;
+	    } else if (supers[k] == superDelegatePtr) {
+		break;
+	    }
+	}
+    }
+
+    // Install new list of superclasses;
+    if (delegatePtr->superclasses.num) {
+	Tcl_Free(delegatePtr->superclasses.list);
+    }
+    delegatePtr->superclasses.list = supers;
+    delegatePtr->superclasses.num = j;
+
+    // Definitely don't need to bump any epoch here
+}
+
+/*
+ * Mixes the delegate into its controlling class.
+ */
+static inline void
+InstallDelegateAsMixin(
+    Tcl_Interp *interp,
+    Class *clsPtr,
+    Class *delegatePtr)
+{
+    if (clsPtr->thisPtr->mixins.num == 0) {
+	TclOOObjectSetMixins(clsPtr->thisPtr, 1, &delegatePtr);
+	return;
+    }
+    Class **mixins = (Class **) TclStackAlloc(interp,
+	    sizeof(Class *) * (clsPtr->thisPtr->mixins.num + 1));
+    for (int i = 0; i < clsPtr->thisPtr->mixins.num; i++) {
+	mixins[i] = clsPtr->thisPtr->mixins.list[i];
+	if (mixins[i] == delegatePtr) {
+	    TclStackFree(interp, (void *) mixins);
+	    return;
+	}
+    }
+    mixins[clsPtr->thisPtr->mixins.num] = delegatePtr;
+    TclOOObjectSetMixins(clsPtr->thisPtr, clsPtr->thisPtr->mixins.num + 1, mixins);
+    TclStackFree(interp, mixins);
+}
+
+// Patches in the appropriate class delegates.
+static void
+MixinClassDelegates(
+    Tcl_Interp *interp,
+    Object *oPtr,
+    Tcl_Obj *delegateName)
+{
+    Class *clsPtr = oPtr->classPtr;
+    if (clsPtr) {
+	Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
+	if (delegatePtr) {
+	    SetDelegateSuperclasses(interp, clsPtr, delegatePtr);
+	    InstallDelegateAsMixin(interp, clsPtr, delegatePtr);
+	}
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOO_Class_Constructor --
  *
  *	Implementation for oo::class constructor.
@@ -84,7 +197,6 @@ TclOO_Class_Constructor(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
-    Tcl_Obj **invoke, *nameObj;
 
     size_t skip = Tcl_ObjectContextSkippedArgs(context);
     if ((size_t) objc > skip + 1) {
@@ -101,25 +213,28 @@ TclOO_Class_Constructor(
      * argument to [oo::define]. [Bug 680503]
      */
 
-    nameObj = Tcl_ObjPrintf("%s:: oo ::delegate",
+    Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
 	    oPtr->namespacePtr->fullName);
+    Tcl_IncrRefCount(delegateName);
     Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
-	    TclGetString(nameObj), NULL, TCL_INDEX_NONE, NULL, 0);
-    Tcl_BounceRefCount(nameObj);
+	    TclGetString(delegateName), NULL, TCL_INDEX_NONE, NULL, 0);
 
     /*
      * If there's nothing else to do, we're done.
      */
 
     if ((size_t) objc == skip) {
-	return TCL_OK;
+	Tcl_InterpState saved = Tcl_SaveInterpState(interp, TCL_OK);
+	MixinClassDelegates(interp, oPtr, delegateName);
+	Tcl_DecrRefCount(delegateName);
+	return Tcl_RestoreInterpState(interp, saved);
     }
 
     /*
      * Delegate to [oo::define] to do the work.
      */
 
-    invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *));
+    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];
@@ -132,8 +247,8 @@ TclOO_Class_Constructor(
     Tcl_IncrRefCount(invoke[0]);
     Tcl_IncrRefCount(invoke[1]);
     Tcl_IncrRefCount(invoke[2]);
-    TclNRAddCallback(interp, DecrRefsPostClassConstructor,
-	    invoke, oPtr, NULL, NULL);
+    TclNRAddCallback(interp, PostClassConstructor,
+	    invoke, oPtr, delegateName, NULL);
 
     /*
      * Tricky point: do not want the extra reported level in the Tcl stack
@@ -143,33 +258,28 @@ TclOO_Class_Constructor(
     return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
 }
 
+/*
+ *	Called *after* [oo::define] inside the constructor of a class.
+ *	Cleans up some temporary storage and sets up the delegate.
+ */
 static int
-DecrRefsPostClassConstructor(
+PostClassConstructor(
     void *data[],
     Tcl_Interp *interp,
     int result)
 {
     Tcl_Obj **invoke = (Tcl_Obj **) data[0];
     Object *oPtr = (Object *) data[1];
-    Tcl_InterpState saved;
-    int code;
+    Tcl_Obj *delegateName = (Tcl_Obj *) data[2];
 
     TclDecrRefCount(invoke[0]);
     TclDecrRefCount(invoke[1]);
     TclDecrRefCount(invoke[2]);
-    invoke[0] = oPtr->fPtr->mcdName;
-    invoke[1] = TclOOObjectName(interp, oPtr);
-    Tcl_IncrRefCount(invoke[0]);
-    Tcl_IncrRefCount(invoke[1]);
-    saved = Tcl_SaveInterpState(interp, result);
-    code = Tcl_EvalObjv(interp, 2, invoke, 0);
-    TclDecrRefCount(invoke[0]);
-    TclDecrRefCount(invoke[1]);
     TclStackFree(interp, invoke);
-    if (code != TCL_OK) {
-	Tcl_DiscardInterpState(saved);
-	return code;
-    }
+
+    Tcl_InterpState saved = Tcl_SaveInterpState(interp, result);
+    MixinClassDelegates(interp, oPtr, delegateName);
+    Tcl_DecrRefCount(delegateName);
     return Tcl_RestoreInterpState(interp, saved);
 }
 
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 1331703..90d5069 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -405,8 +405,6 @@ struct Foundation {
 				 * "<cloned>" pseudo-constructor. */
     Tcl_Obj *defineName;	/* Fully qualified name of oo::define. */
     Tcl_Obj *myName;		/* The "my" shared object. */
-    Tcl_Obj *mcdName;		/* The shared object for calling the helper to
-				 * mix in class delegates. */
     Tcl_Obj *slotGetName;	/* The "Get" name used by slots. */
     Tcl_Obj *slotSetName;	/* The "Set" name used by slots. */
     Tcl_Obj *slotResolveName;	/* The "Resolve" name used by slots. */
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 643e536..bd3721b 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -52,23 +52,6 @@ static const char *tclOOSetupScript =
 "\t\t\trename $cmd {}\n"
 "\t\t}\n"
 "\t}\n"
-"\tproc MixinClassDelegates {class} {\n"
-"\t\tif {![info object isa class $class]} {\n"
-"\t\t\treturn\n"
-"\t\t}\n"
-"\t\tset delegate [DelegateName $class]\n"
-"\t\tif {![info object isa class $delegate]} {\n"
-"\t\t\treturn\n"
-"\t\t}\n"
-"\t\tforeach c [info class superclass $class] {\n"
-"\t\t\tset d [DelegateName $c]\n"
-"\t\t\tif {![info object isa class $d]} {\n"
-"\t\t\t\tcontinue\n"
-"\t\t\t}\n"
-"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
-"\t\t}\n"
-"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
-"\t}\n"
 "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
 "\t\tset originDelegate [DelegateName $originObject]\n"
 "\t\tset targetDelegate [DelegateName $targetObject]\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 2cf40e1..4509202 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -65,33 +65,6 @@
 
     # ----------------------------------------------------------------------
     #
-    # MixinClassDelegates --
-    #
-    #	Support code called *after* [oo::define] inside the constructor of a
-    #	class that patches in the appropriate class delegates.
-    #
-    # ----------------------------------------------------------------------
-
-    proc MixinClassDelegates {class} {
-	if {![info object isa class $class]} {
-	    return
-	}
-	set delegate [DelegateName $class]
-	if {![info object isa class $delegate]} {
-	    return
-	}
-	foreach c [info class superclass $class] {
-	    set d [DelegateName $c]
-	    if {![info object isa class $d]} {
-		continue
-	    }
-	    define $delegate ::oo::define::superclass -appendifnew $d
-	}
-	objdefine $class ::oo::objdefine::mixin -appendifnew $delegate
-    }
-
-    # ----------------------------------------------------------------------
-    #
     # UpdateClassDelegatesAfterClone --
     #
     #	Support code that is like [MixinClassDelegates] except for when a