From 03c0cbaafda3c182f3c71aea9ce223b68273695f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 07:19:52 +0000 Subject: Convert MixinClassDelegates to an internal function entirely in C --- generic/tclOO.c | 3 - generic/tclOOBasic.c | 158 ++++++++++++++++++++++++++++++++++++++++++-------- generic/tclOOInt.h | 2 - generic/tclOOScript.h | 17 ------ tools/tclOOScript.tcl | 27 --------- 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, ""); 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 { * "" 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 -- cgit v0.12