From 4a3783d6dfd19edde7bac018d19ccdb351a8bca9 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 19 Aug 2025 08:57:06 +0000 Subject: Working on rewriting the slot implementation in C; not quite correct yet --- generic/tclOODefineCmds.c | 373 ++++++++++++++++++++++++++++++++++++++++++++-- generic/tclOOScript.h | 35 +---- tools/tclOOScript.tcl | 67 +-------- 3 files changed, 366 insertions(+), 109 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 5ca69e2..0395599 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -39,15 +39,25 @@ typedef struct DeclaredSlot { const Tcl_MethodType resolverType; } DeclaredSlot; -#define SLOT(name,getter,setter,resolver) \ +#define SLOT(name,getter,setter,resolver) \ {"::oo::" name, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ + {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter", \ getter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ + {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter", \ setter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \ + {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver", \ resolver, NULL, NULL}} +typedef struct DeclaredSlotMethod { + const char *name; + int flags; + const Tcl_MethodType implType; +} DeclaredSlotMethod; + +#define SLOT_METHOD(name,impl,flags) \ + {name, flags, {TCL_OO_METHOD_VERSION_1, \ + "core method: " name " slot", impl, NULL, NULL}} + /* * A [string match] pattern used to determine if a method should be exported. */ @@ -78,6 +88,39 @@ static inline void RecomputeClassCacheFlag(Object *oPtr); static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, int useClass, Tcl_Obj *const fromPtr, Tcl_Obj *const toPtr); +static int Slot_Append(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +#if 0 // TODO +static int Slot_AppendNew(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +#endif +static int Slot_Clear(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Prepend(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +#if 0 // TODO +static int Slot_Remove(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +#endif +static int Slot_Resolve(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Set(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Unimplemented(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +#if 0 // TODO +static int Slot_Unknown(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +#endif static int ClassFilter_Get(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -175,6 +218,22 @@ static const DeclaredSlot slots[] = { {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; +static const DeclaredSlotMethod slotMethods[] = { + SLOT_METHOD("Get", Slot_Unimplemented, 0), + SLOT_METHOD("Resolve", Slot_Resolve, 0), + SLOT_METHOD("Set", Slot_Unimplemented, 0), + SLOT_METHOD("-append", Slot_Append, PUBLIC_METHOD), + SLOT_METHOD("-clear", Slot_Clear, PUBLIC_METHOD), + SLOT_METHOD("-prepend", Slot_Prepend, PUBLIC_METHOD), + SLOT_METHOD("-set", Slot_Set, PUBLIC_METHOD), +#if 0 // TODO + SLOT_METHOD("-appendifnew", Slot_AppendNew, PUBLIC_METHOD), + SLOT_METHOD("-remove", Slot_Remove, PUBLIC_METHOD), + SLOT_METHOD("unknown", Slot_Unknown, 0), +#endif + {NULL, 0, {0, 0, 0, 0, 0}} +}; + /* * How to build the in-namespace name of a private variable. This is a pattern * used with Tcl_ObjPrintf(). @@ -2397,39 +2456,43 @@ int TclOODefineSlots( Foundation *fPtr) { - const DeclaredSlot *slotInfoPtr; Tcl_Interp *interp = fPtr->interp; - Tcl_Obj *getName, *setName, *resolveName; Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0); - Class *slotCls; if (object == NULL) { return TCL_ERROR; } - slotCls = ((Object *) object)->classPtr; + Tcl_Class slotCls = (Tcl_Class) ((Object *) object)->classPtr; if (slotCls == NULL) { return TCL_ERROR; } + for (const DeclaredSlotMethod *smPtr = slotMethods; smPtr->name; smPtr++) { + Tcl_Obj *name = Tcl_NewStringObj(smPtr->name, -1); + Tcl_NewMethod(interp, slotCls, name, smPtr->flags, + &smPtr->implType, NULL); + Tcl_BounceRefCount(name); + } + + Tcl_Obj *getName, *setName, *resolveName; TclNewLiteralStringObj(getName, "Get"); TclNewLiteralStringObj(setName, "Set"); TclNewLiteralStringObj(resolveName, "Resolve"); - for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { + for (const DeclaredSlot *slotPtr = slots ; slotPtr->name ; slotPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE, - NULL, 0); + slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0); if (slotObject == NULL) { continue; } TclNewInstanceMethod(interp, slotObject, getName, 0, - &slotInfoPtr->getterType, NULL); + &slotPtr->getterType, NULL); TclNewInstanceMethod(interp, slotObject, setName, 0, - &slotInfoPtr->setterType, NULL); - if (slotInfoPtr->resolverType.callProc) { + &slotPtr->setterType, NULL); + if (slotPtr->resolverType.callProc) { TclNewInstanceMethod(interp, slotObject, resolveName, 0, - &slotInfoPtr->resolverType, NULL); + &slotPtr->resolverType, NULL); } } Tcl_BounceRefCount(getName); @@ -2438,6 +2501,286 @@ TclOODefineSlots( return TCL_OK; } +static int +Slot_Append( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + if (Tcl_ObjectContextSkippedArgs(context) == objc) { + return TCL_OK; + } + objc -= Tcl_ObjectContextSkippedArgs(context); + objv += Tcl_ObjectContextSkippedArgs(context); + + Tcl_Obj *args[3]; + args[0] = Tcl_NewStringObj("my", -1); + Tcl_IncrRefCount(args[0]); + + // Resolve all values + Tcl_Obj **resolved = (Tcl_Obj **) + TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc); + args[1] = Tcl_NewStringObj("Resolve", -1); + Tcl_IncrRefCount(args[1]); + for (int i = 0; i < objc; i++) { + args[2] = objv[i]; + if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) { + Tcl_DecrRefCount(args[0]); + Tcl_DecrRefCount(args[1]); + for (int j = 0; j < i; j++) { + Tcl_DecrRefCount(resolved[j]); + } + TclStackFree(interp, (void *) resolved); + return TCL_ERROR; + } + resolved[i] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resolved[i]); + Tcl_ResetResult(interp); + } + Tcl_DecrRefCount(args[1]); + + // Get slot contents; store in args[2] + args[1] = Tcl_NewStringObj("Get", -1); + Tcl_IncrRefCount(args[1]); + if (TclOOPrivateObjectCmd(oPtr, interp, 2, args) != TCL_OK) { + Tcl_DecrRefCount(args[0]); + Tcl_DecrRefCount(args[1]); + for (int j = 0; j < objc; j++) { + Tcl_DecrRefCount(resolved[j]); + } + TclStackFree(interp, (void *) resolved); + return TCL_ERROR; + } + args[2] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(args[2]); + Tcl_DecrRefCount(args[1]); + Tcl_ResetResult(interp); + + // Append + if (Tcl_IsShared(args[2])) { + Tcl_Obj *dup = Tcl_DuplicateObj(args[2]); + Tcl_IncrRefCount(dup); + Tcl_DecrRefCount(args[2]); + args[2] = dup; + } + if (TclListObjAppendElements(interp, args[2], objc, resolved) != TCL_OK) { + Tcl_DecrRefCount(args[0]); + Tcl_DecrRefCount(args[2]); + for (int j = 0; j < objc; j++) { + Tcl_DecrRefCount(resolved[j]); + } + TclStackFree(interp, (void *) resolved); + return TCL_ERROR; + } + for (int j = 0; j < objc; j++) { + Tcl_DecrRefCount(resolved[j]); + } + TclStackFree(interp, (void *) resolved); + // resolved is now non-referenceable + + // Set slot contents + args[1] = Tcl_NewStringObj("Set", -1); + Tcl_IncrRefCount(args[1]); + int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args); + Tcl_DecrRefCount(args[0]); + Tcl_IncrRefCount(args[1]); + Tcl_IncrRefCount(args[2]); + return code; +} + +static int +Slot_Clear( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } + Tcl_Obj *args[] = { + Tcl_NewStringObj("my", -1), + Tcl_NewStringObj("Set", -1), + Tcl_NewObj() + }; + Tcl_IncrRefCount(args[0]); + Tcl_IncrRefCount(args[1]); + Tcl_IncrRefCount(args[2]); + int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args); + Tcl_DecrRefCount(args[0]); + Tcl_IncrRefCount(args[1]); + Tcl_IncrRefCount(args[2]); + return code; +} + +static int +Slot_Prepend( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + if (Tcl_ObjectContextSkippedArgs(context) == objc) { + return TCL_OK; + } + objc -= Tcl_ObjectContextSkippedArgs(context); + objv += Tcl_ObjectContextSkippedArgs(context); + + Tcl_Obj *args[3]; + args[0] = Tcl_NewStringObj("my", -1); + Tcl_IncrRefCount(args[0]); + + // Resolve all values + Tcl_Obj **resolved = (Tcl_Obj **) + TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc); + args[1] = Tcl_NewStringObj("Resolve", -1); + Tcl_IncrRefCount(args[1]); + for (int i = 0; i < objc; i++) { + args[2] = objv[i]; + if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) { + Tcl_DecrRefCount(args[0]); + Tcl_DecrRefCount(args[1]); + for (int j = 0; j < i; j++) { + Tcl_DecrRefCount(resolved[j]); + } + TclStackFree(interp, (void *) resolved); + return TCL_ERROR; + } + resolved[i] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resolved[i]); + Tcl_ResetResult(interp); + } + Tcl_DecrRefCount(args[1]); + Tcl_Obj *list = Tcl_NewListObj(objc, resolved); + Tcl_IncrRefCount(list); + for (int j = 0; j < objc; j++) { + Tcl_DecrRefCount(resolved[j]); + } + TclStackFree(interp, (void *) resolved); + // resolved is now non-referenceable + + // Get slot contents and append to list + args[1] = Tcl_NewStringObj("Get", -1); + Tcl_IncrRefCount(args[1]); + if (TclOOPrivateObjectCmd(oPtr, interp, 2, args) != TCL_OK) { + Tcl_DecrRefCount(args[0]); + Tcl_DecrRefCount(args[1]); + Tcl_DecrRefCount(list); + return TCL_ERROR; + } + Tcl_ListObjAppendList(NULL, list, Tcl_GetObjResult(interp)); + Tcl_ResetResult(interp); + + // Set slot contents + args[1] = Tcl_NewStringObj("Set", -1); + args[2] = list; // Already has a ref + Tcl_IncrRefCount(args[1]); + int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args); + Tcl_DecrRefCount(args[0]); + Tcl_IncrRefCount(args[1]); + Tcl_IncrRefCount(args[2]); + return code; +} + +static int +Slot_Resolve( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "list"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, objv[objc - 1]); + return TCL_OK; +} + +static int +Slot_Set( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + if (Tcl_ObjectContextSkippedArgs(context) == objc) { + return TCL_OK; + } + objc -= Tcl_ObjectContextSkippedArgs(context); + objv += Tcl_ObjectContextSkippedArgs(context); + + Tcl_Obj *args[3]; + args[0] = Tcl_NewStringObj("my", -1); + Tcl_IncrRefCount(args[0]); + + // Resolve all values + Tcl_Obj **resolved = (Tcl_Obj **) + TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc); + args[1] = Tcl_NewStringObj("Resolve", -1); + Tcl_IncrRefCount(args[1]); + for (int i = 0; i < objc; i++) { + args[2] = objv[i]; + if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) { + Tcl_DecrRefCount(args[0]); + Tcl_DecrRefCount(args[1]); + for (int j = 0; j < i; j++) { + Tcl_DecrRefCount(resolved[j]); + } + TclStackFree(interp, (void *) resolved); + return TCL_ERROR; + } + resolved[i] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resolved[i]); + Tcl_ResetResult(interp); + } + Tcl_DecrRefCount(args[1]); + + // Make a list + args[2] = Tcl_NewListObj(objc, resolved); + Tcl_IncrRefCount(args[2]); + for (int j = 0; j < objc; j++) { + Tcl_DecrRefCount(resolved[j]); + } + TclStackFree(interp, (void *) resolved); + // resolved is now non-referenceable + + // Set slot contents + args[1] = Tcl_NewStringObj("Set", -1); + Tcl_IncrRefCount(args[1]); + int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args); + Tcl_DecrRefCount(args[0]); + Tcl_IncrRefCount(args[1]); + Tcl_IncrRefCount(args[2]); + return code; +} + +static int +Slot_Unimplemented( + TCL_UNUSED(void *), + Tcl_Interp *interp, + TCL_UNUSED(Tcl_ObjectContext), + TCL_UNUSED(int), + TCL_UNUSED(Tcl_Obj *const *)) +{ + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); + OO_ERROR(interp, ABSTRACT_SLOT); + return TCL_ERROR; +} + /* * ---------------------------------------------------------------------- * diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 7b8a69d..796a5cf 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -117,26 +117,6 @@ static const char *tclOOSetupScript = "\t\t::tailcall forward $name myclass $name\n" "\t}\n" "\tdefine Slot {\n" -"\t\tmethod Get -unexport {} {\n" -"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n" -"\t\t}\n" -"\t\tmethod Set -unexport list {\n" -"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n" -"\t\t}\n" -"\t\tmethod Resolve -unexport list {\n" -"\t\t\treturn $list\n" -"\t\t}\n" -"\t\tmethod -set -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\ttailcall my Set $args\n" -"\t\t}\n" -"\t\tmethod -append -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [list {*}$current {*}$args]\n" -"\t\t}\n" "\t\tmethod -appendifnew -export args {\n" "\t\t\tset my [namespace which my]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" @@ -148,13 +128,6 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t\ttailcall my Set $current\n" "\t\t}\n" -"\t\tmethod -clear -export {} {tailcall my Set {}}\n" -"\t\tmethod -prepend -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [list {*}$args {*}$current]\n" -"\t\t}\n" "\t\tmethod -remove -export args {\n" "\t\t\tset my [namespace which my]\n" "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" @@ -210,8 +183,8 @@ static const char *tclOOSetupScript = "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" "\t}\n" "\tclass create singleton {\n" -"\t\tsuperclass class\n" -"\t\tvariable object\n" +"\t\tsuperclass -set class\n" +"\t\tvariable -set object\n" "\t\tunexport create createWithNamespace\n" "\t\tmethod new args {\n" "\t\t\tif {![info exists object] || ![info object isa object $object]} {\n" @@ -231,7 +204,7 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t}\n" "\tclass create abstract {\n" -"\t\tsuperclass class\n" +"\t\tsuperclass -set class\n" "\t\tunexport create createWithNamespace new\n" "\t}\n" "\tnamespace eval configuresupport::configurableclass {\n" @@ -249,7 +222,7 @@ static const char *tclOOSetupScript = "\t\tdefinitionnamespace -class configuresupport::configurableclass\n" "\t}\n" "\tclass create configurable {\n" -"\t\tsuperclass class\n" +"\t\tsuperclass -set class\n" "\t\tconstructor {{definitionScript \"\"}} {\n" "\t\t\tnext {mixin ::oo::configuresupport::configurable}\n" "\t\t\tnext $definitionScript\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 442756d..f2fcfd5 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -198,47 +198,6 @@ define Slot { # ------------------------------------------------------------------ # - # Slot Get -- - # - # Basic slot getter. Retrieves the contents of the slot. - # Particular slots must provide concrete non-erroring - # implementation. - # - # ------------------------------------------------------------------ - - method Get -unexport {} { - return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented" - } - - # ------------------------------------------------------------------ - # - # Slot Set -- - # - # Basic slot setter. Sets the contents of the slot. Particular - # slots must provide concrete non-erroring implementation. - # - # ------------------------------------------------------------------ - - method Set -unexport list { - return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented" - } - - # ------------------------------------------------------------------ - # - # Slot Resolve -- - # - # Helper that lets a slot convert a list of arguments of a - # particular type to their canonical forms. Defaults to doing - # nothing (suitable for simple strings). - # - # ------------------------------------------------------------------ - - method Resolve -unexport list { - return $list - } - - # ------------------------------------------------------------------ - # # Slot -set, -append, -clear, --default-operation -- # # Standard public slot operations. If a slot can't figure out @@ -246,17 +205,6 @@ # # ------------------------------------------------------------------ - method -set -export args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - tailcall my Set $args - } - method -append -export args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - set current [uplevel 1 [list $my Get]] - tailcall my Set [list {*}$current {*}$args] - } method -appendifnew -export args { set my [namespace which my] set current [uplevel 1 [list $my Get]] @@ -268,13 +216,6 @@ } tailcall my Set $current } - method -clear -export {} {tailcall my Set {}} - method -prepend -export args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - set current [uplevel 1 [list $my Get]] - tailcall my Set [list {*}$args {*}$current] - } method -remove -export args { set my [namespace which my] set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] @@ -372,8 +313,8 @@ # ---------------------------------------------------------------------- class create singleton { - superclass class - variable object + superclass -set class + variable -set object unexport create createWithNamespace method new args { if {![info exists object] || ![info object isa object $object]} { @@ -403,7 +344,7 @@ # ---------------------------------------------------------------------- class create abstract { - superclass class + superclass -set class unexport create createWithNamespace new } @@ -486,7 +427,7 @@ # ---------------------------------------------------------------------- class create configurable { - superclass class + superclass -set class constructor {{definitionScript ""}} { next {mixin ::oo::configuresupport::configurable} -- cgit v0.12 From 2d4422bbbaaea2c7d45ecb8af256c8b6c548f568 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 19 Aug 2025 13:51:54 +0000 Subject: Saner C implementation of slot methods; add unknown handler to C side --- generic/tclOO.c | 12 ++ generic/tclOODefineCmds.c | 345 +++++++++++++++++++++------------------------- generic/tclOOInt.h | 4 + generic/tclOOScript.h | 9 -- tools/tclOOScript.tcl | 11 +- 5 files changed, 176 insertions(+), 205 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index e1dd40f..1e8012f 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -371,6 +371,10 @@ InitFoundation( 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"); + TclNewLiteralStringObj(fPtr->slotDefOpName, "--default-operation"); Tcl_IncrRefCount(fPtr->unknownMethodNameObj); Tcl_IncrRefCount(fPtr->constructorName); Tcl_IncrRefCount(fPtr->destructorName); @@ -378,6 +382,10 @@ InitFoundation( Tcl_IncrRefCount(fPtr->defineName); Tcl_IncrRefCount(fPtr->myName); Tcl_IncrRefCount(fPtr->mcdName); + Tcl_IncrRefCount(fPtr->slotGetName); + Tcl_IncrRefCount(fPtr->slotSetName); + Tcl_IncrRefCount(fPtr->slotResolveName); + Tcl_IncrRefCount(fPtr->slotDefOpName); TclCreateObjCommandInNs(interp, "UnknownDefinition", fPtr->ooNs, TclOOUnknownDefinition, NULL, NULL); @@ -621,6 +629,10 @@ KillFoundation( TclDecrRefCount(fPtr->defineName); TclDecrRefCount(fPtr->myName); TclDecrRefCount(fPtr->mcdName); + TclDecrRefCount(fPtr->slotGetName); + TclDecrRefCount(fPtr->slotSetName); + TclDecrRefCount(fPtr->slotResolveName); + TclDecrRefCount(fPtr->slotDefOpName); TclOODecrRefCount(fPtr->objectCls->thisPtr); TclOODecrRefCount(fPtr->classCls->thisPtr); diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 0395599..fc7e479 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -88,7 +88,7 @@ static inline void RecomputeClassCacheFlag(Object *oPtr); static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, int useClass, Tcl_Obj *const fromPtr, Tcl_Obj *const toPtr); -static int Slot_Append(void *clientData, +static int Slot_Append(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); #if 0 // TODO @@ -96,10 +96,10 @@ static int Slot_AppendNew(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); #endif -static int Slot_Clear(void *clientData, +static int Slot_Clear(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static int Slot_Prepend(void *clientData, +static int Slot_Prepend(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); #if 0 // TODO @@ -107,20 +107,18 @@ static int Slot_Remove(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); #endif -static int Slot_Resolve(void *clientData, +static int Slot_Resolve(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static int Slot_Set(void *clientData, +static int Slot_Set(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static int Slot_Unimplemented(void *clientData, +static int Slot_Unimplemented(void *, + Tcl_Interp *interp, Tcl_ObjectContext, + int, Tcl_Obj *const *); +static int Slot_Unknown(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -#if 0 // TODO -static int Slot_Unknown(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -#endif static int ClassFilter_Get(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -226,10 +224,10 @@ static const DeclaredSlotMethod slotMethods[] = { SLOT_METHOD("-clear", Slot_Clear, PUBLIC_METHOD), SLOT_METHOD("-prepend", Slot_Prepend, PUBLIC_METHOD), SLOT_METHOD("-set", Slot_Set, PUBLIC_METHOD), + SLOT_METHOD("unknown", Slot_Unknown, 0), #if 0 // TODO SLOT_METHOD("-appendifnew", Slot_AppendNew, PUBLIC_METHOD), SLOT_METHOD("-remove", Slot_Remove, PUBLIC_METHOD), - SLOT_METHOD("unknown", Slot_Unknown, 0), #endif {NULL, 0, {0, 0, 0, 0, 0}} }; @@ -2475,10 +2473,6 @@ TclOODefineSlots( Tcl_BounceRefCount(name); } - Tcl_Obj *getName, *setName, *resolveName; - TclNewLiteralStringObj(getName, "Get"); - TclNewLiteralStringObj(setName, "Set"); - TclNewLiteralStringObj(resolveName, "Resolve"); for (const DeclaredSlot *slotPtr = slots ; slotPtr->name ; slotPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(interp, slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0); @@ -2486,21 +2480,87 @@ TclOODefineSlots( if (slotObject == NULL) { continue; } - TclNewInstanceMethod(interp, slotObject, getName, 0, + TclNewInstanceMethod(interp, slotObject, fPtr->slotGetName, 0, &slotPtr->getterType, NULL); - TclNewInstanceMethod(interp, slotObject, setName, 0, + TclNewInstanceMethod(interp, slotObject, fPtr->slotSetName, 0, &slotPtr->setterType, NULL); if (slotPtr->resolverType.callProc) { - TclNewInstanceMethod(interp, slotObject, resolveName, 0, + TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0, &slotPtr->resolverType, NULL); } } - Tcl_BounceRefCount(getName); - Tcl_BounceRefCount(setName); - Tcl_BounceRefCount(resolveName); return TCL_OK; } +static inline int +CallSlotGet( + Tcl_Interp *interp, + Object *oPtr) +{ + Tcl_Obj *getArgs[] = { + oPtr->fPtr->myName, + oPtr->fPtr->slotGetName + }; + return TclOOPrivateObjectCmd(oPtr, interp, 2, getArgs); +} + +static inline int +CallSlotSet( + Tcl_Interp *interp, + Object *oPtr, + Tcl_Obj *list) +{ + Tcl_Obj *setArgs[] = { + oPtr->fPtr->myName, + oPtr->fPtr->slotSetName, + list + }; + return TclOOPrivateObjectCmd(oPtr, interp, 3, setArgs); +} + +static inline int +CallSlotResolve( + Tcl_Interp *interp, + Object *oPtr, + Tcl_Obj *item) +{ + Tcl_Obj *resolveArgs[] = { + oPtr->fPtr->myName, + oPtr->fPtr->slotResolveName, + item + }; + return TclOOPrivateObjectCmd(oPtr, interp, 3, resolveArgs); +} + +static inline Tcl_Obj * +ResolveAll( + Tcl_Interp *interp, + Object *oPtr, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp, + sizeof(Tcl_Obj *) * objc); + for (int i = 0; i < objc; i++) { + if (CallSlotResolve(interp, oPtr, objv[i]) != TCL_OK) { + for (int j = 0; j < i; j++) { + Tcl_DecrRefCount(resolvedItems[j]); + } + TclStackFree(interp, (void *) resolvedItems); + return NULL; + } + resolvedItems[i] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resolvedItems[i]); + Tcl_ResetResult(interp); + } + Tcl_Obj *resolvedList = Tcl_NewListObj(objc, resolvedItems); + for (int i = 0; i < objc; i++) { + TclDecrRefCount(resolvedItems[i]); + } + TclStackFree(interp, (void *) resolvedItems); + return resolvedList; +} + static int Slot_Append( TCL_UNUSED(void *), @@ -2510,84 +2570,43 @@ Slot_Append( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - if (Tcl_ObjectContextSkippedArgs(context) == objc) { + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip == objc) { return TCL_OK; } - objc -= Tcl_ObjectContextSkippedArgs(context); - objv += Tcl_ObjectContextSkippedArgs(context); - - Tcl_Obj *args[3]; - args[0] = Tcl_NewStringObj("my", -1); - Tcl_IncrRefCount(args[0]); // Resolve all values - Tcl_Obj **resolved = (Tcl_Obj **) - TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc); - args[1] = Tcl_NewStringObj("Resolve", -1); - Tcl_IncrRefCount(args[1]); - for (int i = 0; i < objc; i++) { - args[2] = objv[i]; - if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) { - Tcl_DecrRefCount(args[0]); - Tcl_DecrRefCount(args[1]); - for (int j = 0; j < i; j++) { - Tcl_DecrRefCount(resolved[j]); - } - TclStackFree(interp, (void *) resolved); - return TCL_ERROR; - } - resolved[i] = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resolved[i]); - Tcl_ResetResult(interp); + Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (resolved == NULL) { + return TCL_ERROR; } - Tcl_DecrRefCount(args[1]); - // Get slot contents; store in args[2] - args[1] = Tcl_NewStringObj("Get", -1); - Tcl_IncrRefCount(args[1]); - if (TclOOPrivateObjectCmd(oPtr, interp, 2, args) != TCL_OK) { - Tcl_DecrRefCount(args[0]); - Tcl_DecrRefCount(args[1]); - for (int j = 0; j < objc; j++) { - Tcl_DecrRefCount(resolved[j]); - } - TclStackFree(interp, (void *) resolved); + // Get slot contents; store in list + if (CallSlotGet(interp, oPtr) != TCL_OK) { + Tcl_DecrRefCount(resolved); return TCL_ERROR; } - args[2] = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(args[2]); - Tcl_DecrRefCount(args[1]); + Tcl_Obj *list = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(list); Tcl_ResetResult(interp); // Append - if (Tcl_IsShared(args[2])) { - Tcl_Obj *dup = Tcl_DuplicateObj(args[2]); + if (Tcl_IsShared(list)) { + Tcl_Obj *dup = Tcl_DuplicateObj(list); Tcl_IncrRefCount(dup); - Tcl_DecrRefCount(args[2]); - args[2] = dup; + Tcl_DecrRefCount(list); + list = dup; } - if (TclListObjAppendElements(interp, args[2], objc, resolved) != TCL_OK) { - Tcl_DecrRefCount(args[0]); - Tcl_DecrRefCount(args[2]); - for (int j = 0; j < objc; j++) { - Tcl_DecrRefCount(resolved[j]); - } - TclStackFree(interp, (void *) resolved); + if (Tcl_ListObjAppendList(interp, list, resolved) != TCL_OK) { + Tcl_DecrRefCount(list); + Tcl_DecrRefCount(resolved); return TCL_ERROR; } - for (int j = 0; j < objc; j++) { - Tcl_DecrRefCount(resolved[j]); - } - TclStackFree(interp, (void *) resolved); - // resolved is now non-referenceable + Tcl_DecrRefCount(resolved); // Set slot contents - args[1] = Tcl_NewStringObj("Set", -1); - Tcl_IncrRefCount(args[1]); - int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args); - Tcl_DecrRefCount(args[0]); - Tcl_IncrRefCount(args[1]); - Tcl_IncrRefCount(args[2]); + int code = CallSlotSet(interp, oPtr, list); + Tcl_DecrRefCount(list); return code; } @@ -2600,23 +2619,15 @@ Slot_Clear( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip != objc) { + Tcl_WrongNumArgs(interp, skip, objv, NULL); return TCL_ERROR; } - Tcl_Obj *args[] = { - Tcl_NewStringObj("my", -1), - Tcl_NewStringObj("Set", -1), - Tcl_NewObj() - }; - Tcl_IncrRefCount(args[0]); - Tcl_IncrRefCount(args[1]); - Tcl_IncrRefCount(args[2]); - int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args); - Tcl_DecrRefCount(args[0]); - Tcl_IncrRefCount(args[1]); - Tcl_IncrRefCount(args[2]); + Tcl_Obj *list = Tcl_NewObj(); + Tcl_IncrRefCount(list); + int code = CallSlotSet(interp, oPtr, list); + Tcl_DecrRefCount(list); return code; } @@ -2629,51 +2640,20 @@ Slot_Prepend( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - if (Tcl_ObjectContextSkippedArgs(context) == objc) { + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip == objc) { return TCL_OK; } - objc -= Tcl_ObjectContextSkippedArgs(context); - objv += Tcl_ObjectContextSkippedArgs(context); - - Tcl_Obj *args[3]; - args[0] = Tcl_NewStringObj("my", -1); - Tcl_IncrRefCount(args[0]); // Resolve all values - Tcl_Obj **resolved = (Tcl_Obj **) - TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc); - args[1] = Tcl_NewStringObj("Resolve", -1); - Tcl_IncrRefCount(args[1]); - for (int i = 0; i < objc; i++) { - args[2] = objv[i]; - if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) { - Tcl_DecrRefCount(args[0]); - Tcl_DecrRefCount(args[1]); - for (int j = 0; j < i; j++) { - Tcl_DecrRefCount(resolved[j]); - } - TclStackFree(interp, (void *) resolved); - return TCL_ERROR; - } - resolved[i] = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resolved[i]); - Tcl_ResetResult(interp); + Tcl_Obj *list = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (list == NULL) { + return TCL_ERROR; } - Tcl_DecrRefCount(args[1]); - Tcl_Obj *list = Tcl_NewListObj(objc, resolved); Tcl_IncrRefCount(list); - for (int j = 0; j < objc; j++) { - Tcl_DecrRefCount(resolved[j]); - } - TclStackFree(interp, (void *) resolved); - // resolved is now non-referenceable // Get slot contents and append to list - args[1] = Tcl_NewStringObj("Get", -1); - Tcl_IncrRefCount(args[1]); - if (TclOOPrivateObjectCmd(oPtr, interp, 2, args) != TCL_OK) { - Tcl_DecrRefCount(args[0]); - Tcl_DecrRefCount(args[1]); + if (CallSlotGet(interp, oPtr) != TCL_OK) { Tcl_DecrRefCount(list); return TCL_ERROR; } @@ -2681,13 +2661,8 @@ Slot_Prepend( Tcl_ResetResult(interp); // Set slot contents - args[1] = Tcl_NewStringObj("Set", -1); - args[2] = list; // Already has a ref - Tcl_IncrRefCount(args[1]); - int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args); - Tcl_DecrRefCount(args[0]); - Tcl_IncrRefCount(args[1]); - Tcl_IncrRefCount(args[2]); + int code = CallSlotSet(interp, oPtr, list); + Tcl_DecrRefCount(list); return code; } @@ -2699,9 +2674,9 @@ Slot_Resolve( int objc, Tcl_Obj *const *objv) { - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "list"); + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip + 1 != objc) { + Tcl_WrongNumArgs(interp, skip, objv, "list"); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[objc - 1]); @@ -2717,54 +2692,23 @@ Slot_Set( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - if (Tcl_ObjectContextSkippedArgs(context) == objc) { - return TCL_OK; - } - objc -= Tcl_ObjectContextSkippedArgs(context); - objv += Tcl_ObjectContextSkippedArgs(context); - - Tcl_Obj *args[3]; - args[0] = Tcl_NewStringObj("my", -1); - Tcl_IncrRefCount(args[0]); + int skip = Tcl_ObjectContextSkippedArgs(context); + Tcl_Obj *list; // Resolve all values - Tcl_Obj **resolved = (Tcl_Obj **) - TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc); - args[1] = Tcl_NewStringObj("Resolve", -1); - Tcl_IncrRefCount(args[1]); - for (int i = 0; i < objc; i++) { - args[2] = objv[i]; - if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) { - Tcl_DecrRefCount(args[0]); - Tcl_DecrRefCount(args[1]); - for (int j = 0; j < i; j++) { - Tcl_DecrRefCount(resolved[j]); - } - TclStackFree(interp, (void *) resolved); + if (skip == objc) { + list = Tcl_NewObj(); + } else { + list = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (list == NULL) { return TCL_ERROR; } - resolved[i] = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resolved[i]); - Tcl_ResetResult(interp); - } - Tcl_DecrRefCount(args[1]); - - // Make a list - args[2] = Tcl_NewListObj(objc, resolved); - Tcl_IncrRefCount(args[2]); - for (int j = 0; j < objc; j++) { - Tcl_DecrRefCount(resolved[j]); } - TclStackFree(interp, (void *) resolved); - // resolved is now non-referenceable + Tcl_IncrRefCount(list); // Set slot contents - args[1] = Tcl_NewStringObj("Set", -1); - Tcl_IncrRefCount(args[1]); - int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args); - Tcl_DecrRefCount(args[0]); - Tcl_IncrRefCount(args[1]); - Tcl_IncrRefCount(args[2]); + int code = CallSlotSet(interp, oPtr, list); + Tcl_DecrRefCount(list); return code; } @@ -2780,6 +2724,35 @@ Slot_Unimplemented( OO_ERROR(interp, ABSTRACT_SLOT); return TCL_ERROR; } + +static int +Slot_Unknown( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip >= objc) { + Tcl_Obj *args[] = { + oPtr->fPtr->myName, + oPtr->fPtr->slotDefOpName + }; + return TclOOPrivateObjectCmd(oPtr, interp, 2, args); + } else if (TclGetString(objv[skip])[0] != '-') { + Tcl_Obj **args = (Tcl_Obj **) TclStackAlloc(interp, + sizeof(Tcl_Obj *) * (objc - skip + 2)); + args[0] = oPtr->fPtr->myName; + args[1] = oPtr->fPtr->slotDefOpName; + memcpy(args+2, objv+skip, sizeof(Tcl_Obj*) * (objc - skip)); + int code = TclOOPrivateObjectCmd(oPtr, interp, objc - skip + 2, args); + TclStackFree(interp, args); + return code; + } + return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip); +} /* * ---------------------------------------------------------------------- diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index e4351f6..94eda61 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -407,6 +407,10 @@ struct Foundation { 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. */ + Tcl_Obj *slotDefOpName; /* The "--default-operation" name used by slots. */ }; /* diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 796a5cf..9b1de48 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -137,15 +137,6 @@ static const char *tclOOSetupScript = "\t\t\t}]\n" "\t\t}\n" "\t\tforward --default-operation my -append\n" -"\t\tmethod unknown -unexport {args} {\n" -"\t\t\tset def --default-operation\n" -"\t\t\tif {[llength $args] == 0} {\n" -"\t\t\t\ttailcall my $def\n" -"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n" -"\t\t\t\ttailcall my $def {*}$args\n" -"\t\t\t}\n" -"\t\t\tnext {*}$args\n" -"\t\t}\n" "\t\tunexport destroy\n" "\t}\n" "\tobjdefine define::superclass forward --default-operation my -set\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index f2fcfd5..535c56c 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -198,7 +198,7 @@ define Slot { # ------------------------------------------------------------------ # - # Slot -set, -append, -clear, --default-operation -- + # Slot -appendifnew, -remove, --default-operation -- # # Standard public slot operations. If a slot can't figure out # what method to call directly, it uses --default-operation. @@ -227,15 +227,6 @@ # Default handling forward --default-operation my -append - method unknown -unexport {args} { - set def --default-operation - if {[llength $args] == 0} { - tailcall my $def - } elseif {![string match -* [lindex $args 0]]} { - tailcall my $def {*}$args - } - next {*}$args - } # Hide destroy unexport destroy -- cgit v0.12 From dde7348f8642b86ddeaf6e386962d0691fb84ca9 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 19 Aug 2025 14:15:18 +0000 Subject: Add remoaining slot ops --- generic/tclOODefineCmds.c | 143 ++++++++++++++++++++++++++++++++++++++++++---- generic/tclOOScript.h | 19 ------ tools/tclOOScript.tcl | 26 +-------- 3 files changed, 136 insertions(+), 52 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index fc7e479..0c4d328 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -91,22 +91,18 @@ static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, static int Slot_Append(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -#if 0 // TODO -static int Slot_AppendNew(void *clientData, +static int Slot_AppendNew(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -#endif static int Slot_Clear(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int Slot_Prepend(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -#if 0 // TODO -static int Slot_Remove(void *clientData, +static int Slot_Remove(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -#endif static int Slot_Resolve(void *, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -221,14 +217,12 @@ static const DeclaredSlotMethod slotMethods[] = { SLOT_METHOD("Resolve", Slot_Resolve, 0), SLOT_METHOD("Set", Slot_Unimplemented, 0), SLOT_METHOD("-append", Slot_Append, PUBLIC_METHOD), + SLOT_METHOD("-appendifnew", Slot_AppendNew, PUBLIC_METHOD), SLOT_METHOD("-clear", Slot_Clear, PUBLIC_METHOD), SLOT_METHOD("-prepend", Slot_Prepend, PUBLIC_METHOD), + SLOT_METHOD("-remove", Slot_Remove, PUBLIC_METHOD), SLOT_METHOD("-set", Slot_Set, PUBLIC_METHOD), SLOT_METHOD("unknown", Slot_Unknown, 0), -#if 0 // TODO - SLOT_METHOD("-appendifnew", Slot_AppendNew, PUBLIC_METHOD), - SLOT_METHOD("-remove", Slot_Remove, PUBLIC_METHOD), -#endif {NULL, 0, {0, 0, 0, 0, 0}} }; @@ -2611,6 +2605,73 @@ Slot_Append( } static int +Slot_AppendNew( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip == objc) { + return TCL_OK; + } + + // Resolve all values + Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (resolved == NULL) { + return TCL_ERROR; + } + + // Get slot contents; store in list + if (CallSlotGet(interp, oPtr) != TCL_OK) { + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_Obj *list = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(list); + Tcl_ResetResult(interp); + + // Prepare a set of items in the list to set + Tcl_Size listc; + Tcl_Obj **listv; + if (TclListObjGetElements(interp, list, &listc, &listv) != TCL_OK) { + Tcl_DecrRefCount(list); + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_HashTable unique; + Tcl_InitObjHashTable(&unique); + for (Tcl_Size i=0 ; i Date: Tue, 19 Aug 2025 14:46:11 +0000 Subject: Add some documentation comments --- generic/tclOODefineCmds.c | 175 +++++++++++++++++++++++++++++++++++++--------- 1 file changed, 142 insertions(+), 33 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 0c4d328..199fce7 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2486,64 +2486,87 @@ TclOODefineSlots( return TCL_OK; } -static inline int +/* + * ---------------------------------------------------------------------- + * + * CallSlotGet, CallSlotSet, CallSlotResolve, ResolveAll -- + * + * How to call the standard low-level methods of a slot. + * ResolveAll is the lifting of CallSlotResolve to work over a whole + * list of items. + * + * ---------------------------------------------------------------------- + */ + +// Call [$slot Get] to retrieve the list of contents of the slot +static inline Tcl_Obj * CallSlotGet( Tcl_Interp *interp, - Object *oPtr) + Object *slot) { Tcl_Obj *getArgs[] = { - oPtr->fPtr->myName, - oPtr->fPtr->slotGetName + slot->fPtr->myName, + slot->fPtr->slotGetName }; - return TclOOPrivateObjectCmd(oPtr, interp, 2, getArgs); + int code = TclOOPrivateObjectCmd(slot, interp, 2, getArgs); + if (code != TCL_OK) { + return NULL; + } + return Tcl_GetObjResult(interp); } +// Call [$slot Set $list] to set the list of contents of the slot static inline int CallSlotSet( Tcl_Interp *interp, - Object *oPtr, + Object *slot, Tcl_Obj *list) { Tcl_Obj *setArgs[] = { - oPtr->fPtr->myName, - oPtr->fPtr->slotSetName, + slot->fPtr->myName, + slot->fPtr->slotSetName, list }; - return TclOOPrivateObjectCmd(oPtr, interp, 3, setArgs); + return TclOOPrivateObjectCmd(slot, interp, 3, setArgs); } -static inline int +// Call [$slot Resolve $item] to convert a slot item into canonical form +static inline Tcl_Obj * CallSlotResolve( Tcl_Interp *interp, - Object *oPtr, + Object *slot, Tcl_Obj *item) { Tcl_Obj *resolveArgs[] = { - oPtr->fPtr->myName, - oPtr->fPtr->slotResolveName, + slot->fPtr->myName, + slot->fPtr->slotResolveName, item }; - return TclOOPrivateObjectCmd(oPtr, interp, 3, resolveArgs); + int code = TclOOPrivateObjectCmd(slot, interp, 3, resolveArgs); + if (code != TCL_OK) { + return NULL; + } + return Tcl_GetObjResult(interp); } static inline Tcl_Obj * ResolveAll( Tcl_Interp *interp, - Object *oPtr, + Object *slot, int objc, Tcl_Obj *const *objv) { Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc); for (int i = 0; i < objc; i++) { - if (CallSlotResolve(interp, oPtr, objv[i]) != TCL_OK) { + resolvedItems[i] = CallSlotResolve(interp, slot, objv[i]); + if (resolvedItems[i] == NULL) { for (int j = 0; j < i; j++) { Tcl_DecrRefCount(resolvedItems[j]); } TclStackFree(interp, (void *) resolvedItems); return NULL; } - resolvedItems[i] = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resolvedItems[i]); Tcl_ResetResult(interp); } @@ -2555,6 +2578,15 @@ ResolveAll( return resolvedList; } +/* + * ---------------------------------------------------------------------- + * + * Slot_Append -- + * + * Implementation of the "-append" slot operation. + * + * ---------------------------------------------------------------------- + */ static int Slot_Append( TCL_UNUSED(void *), @@ -2576,11 +2608,11 @@ Slot_Append( } // Get slot contents; store in list - if (CallSlotGet(interp, oPtr) != TCL_OK) { + Tcl_Obj *list = CallSlotGet(interp, oPtr); + if (list == NULL) { Tcl_DecrRefCount(resolved); return TCL_ERROR; } - Tcl_Obj *list = Tcl_GetObjResult(interp); Tcl_IncrRefCount(list); Tcl_ResetResult(interp); @@ -2603,7 +2635,16 @@ Slot_Append( Tcl_DecrRefCount(list); return code; } - + +/* + * ---------------------------------------------------------------------- + * + * Slot_AppendNew -- + * + * Implementation of the "-appendifnew" slot operation. + * + * ---------------------------------------------------------------------- + */ static int Slot_AppendNew( TCL_UNUSED(void *), @@ -2625,11 +2666,11 @@ Slot_AppendNew( } // Get slot contents; store in list - if (CallSlotGet(interp, oPtr) != TCL_OK) { + Tcl_Obj *list = CallSlotGet(interp, oPtr); + if (list == NULL) { Tcl_DecrRefCount(resolved); return TCL_ERROR; } - Tcl_Obj *list = Tcl_GetObjResult(interp); Tcl_IncrRefCount(list); Tcl_ResetResult(interp); @@ -2670,7 +2711,16 @@ Slot_AppendNew( Tcl_DecrRefCount(list); return code; } - + +/* + * ---------------------------------------------------------------------- + * + * Slot_Clear -- + * + * Implementation of the "-clear" slot operation. + * + * ---------------------------------------------------------------------- + */ static int Slot_Clear( TCL_UNUSED(void *), @@ -2691,7 +2741,16 @@ Slot_Clear( Tcl_DecrRefCount(list); return code; } - + +/* + * ---------------------------------------------------------------------- + * + * Slot_Prepend -- + * + * Implementation of the "-prepend" slot operation. + * + * ---------------------------------------------------------------------- + */ static int Slot_Prepend( TCL_UNUSED(void *), @@ -2714,11 +2773,12 @@ Slot_Prepend( Tcl_IncrRefCount(list); // Get slot contents and append to list - if (CallSlotGet(interp, oPtr) != TCL_OK) { + Tcl_Obj *oldList = CallSlotGet(interp, oPtr); + if (oldList == NULL) { Tcl_DecrRefCount(list); return TCL_ERROR; } - Tcl_ListObjAppendList(NULL, list, Tcl_GetObjResult(interp)); + Tcl_ListObjAppendList(NULL, list, oldList); Tcl_ResetResult(interp); // Set slot contents @@ -2726,7 +2786,16 @@ Slot_Prepend( Tcl_DecrRefCount(list); return code; } - + +/* + * ---------------------------------------------------------------------- + * + * Slot_Remove -- + * + * Implementation of the "-remove" slot operation. + * + * ---------------------------------------------------------------------- + */ static int Slot_Remove( TCL_UNUSED(void *), @@ -2748,11 +2817,11 @@ Slot_Remove( } // Get slot contents; store in list - if (CallSlotGet(interp, oPtr) != TCL_OK) { + Tcl_Obj *oldList = CallSlotGet(interp, oPtr); + if (oldList == NULL) { Tcl_DecrRefCount(resolved); return TCL_ERROR; } - Tcl_Obj *oldList = Tcl_GetObjResult(interp); Tcl_IncrRefCount(oldList); Tcl_ResetResult(interp); @@ -2788,7 +2857,17 @@ Slot_Remove( Tcl_DecrRefCount(newList); return code; } - + +/* + * ---------------------------------------------------------------------- + * + * Slot_Resolve -- + * + * Default implementation of the "Resolve" slot accessor. Just returns + * its argument unchanged; particular slots may override. + * + * ---------------------------------------------------------------------- + */ static int Slot_Resolve( TCL_UNUSED(void *), @@ -2805,7 +2884,16 @@ Slot_Resolve( Tcl_SetObjResult(interp, objv[objc - 1]); return TCL_OK; } - + +/* + * ---------------------------------------------------------------------- + * + * Slot_Set -- + * + * Implementation of the "-set" slot operation. + * + * ---------------------------------------------------------------------- + */ static int Slot_Set( TCL_UNUSED(void *), @@ -2834,7 +2922,17 @@ Slot_Set( Tcl_DecrRefCount(list); return code; } - + +/* + * ---------------------------------------------------------------------- + * + * Slot_Unimplemented -- + * + * Default implementation of the "Get" and "Set" slot accessors. Just + * returns an error; actual slots must override. + * + * ---------------------------------------------------------------------- + */ static int Slot_Unimplemented( TCL_UNUSED(void *), @@ -2847,7 +2945,18 @@ Slot_Unimplemented( OO_ERROR(interp, ABSTRACT_SLOT); return TCL_ERROR; } - + +/* + * ---------------------------------------------------------------------- + * + * Slot_Unknown -- + * + * Unknown method name handler for slots. Delegates to the default slot + * operation (--default-operation forwarded method) unless the first + * argument starts with a dash. + * + * ---------------------------------------------------------------------- + */ static int Slot_Unknown( TCL_UNUSED(void *), -- cgit v0.12 From c418b4db02db0cf5df8fafb6d52dddfb4f299ef2 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 19 Aug 2025 15:45:53 +0000 Subject: Slightly faster way to write the init script --- generic/tclOOScript.h | 59 +++++++++++++++++------------------- tools/tclOOScript.tcl | 84 +++++++++++++++++++++++---------------------------- 2 files changed, 65 insertions(+), 78 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 80c4c68..6b0c5bd 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -116,10 +116,8 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t\t::tailcall forward $name myclass $name\n" "\t}\n" -"\tdefine Slot {\n" -"\t\tforward --default-operation my -append\n" -"\t\tunexport destroy\n" -"\t}\n" +"\tdefine Slot forward --default-operation my -append\n" +"\tdefine Slot unexport destroy\n" "\tobjdefine define::superclass forward --default-operation my -set\n" "\tobjdefine define::mixin forward --default-operation my -set\n" "\tobjdefine objdefine::mixin forward --default-operation my -set\n" @@ -154,31 +152,29 @@ static const char *tclOOSetupScript = "\t\tnext $originObject\n" "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" "\t}\n" -"\tclass create singleton {\n" -"\t\tsuperclass -set class\n" -"\t\tvariable -set object\n" -"\t\tunexport create createWithNamespace\n" -"\t\tmethod new args {\n" -"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n" -"\t\t\t\tset object [next {*}$args]\n" -"\t\t\t\t::oo::objdefine $object {\n" -"\t\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" -"\t\t\t\t\t}\n" -"\t\t\t\t\tmethod -unexport {originObject} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" -"\t\t\t\t\t}\n" +"\tclass create singleton\n" +"\tdefine singleton superclass -set class\n" +"\tdefine singleton variable -set object\n" +"\tdefine singleton unexport create createWithNamespace\n" +"\tdefine singleton method new args {\n" +"\t\tif {![info exists object] || ![info object isa object $object]} {\n" +"\t\t\tset object [next {*}$args]\n" +"\t\t\t::oo::objdefine $object {\n" +"\t\t\t\tmethod destroy {} {\n" +"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\t\t\t\"may not destroy a singleton object\"\n" +"\t\t\t\t}\n" +"\t\t\t\tmethod -unexport {originObject} {\n" +"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\t\t\t\"may not clone a singleton object\"\n" "\t\t\t\t}\n" "\t\t\t}\n" -"\t\t\treturn $object\n" "\t\t}\n" +"\t\treturn $object\n" "\t}\n" -"\tclass create abstract {\n" -"\t\tsuperclass -set class\n" -"\t\tunexport create createWithNamespace new\n" -"\t}\n" +"\tclass create abstract\n" +"\tdefine abstract superclass -set class\n" +"\tdefine abstract unexport create createWithNamespace new\n" "\tnamespace eval configuresupport::configurableclass {\n" "\t\t::proc properties args {::tailcall property {*}$args}\n" "\t\t::namespace path ::oo::define\n" @@ -193,14 +189,13 @@ static const char *tclOOSetupScript = "\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" "\t\tdefinitionnamespace -class configuresupport::configurableclass\n" "\t}\n" -"\tclass create configurable {\n" -"\t\tsuperclass -set class\n" -"\t\tconstructor {{definitionScript \"\"}} {\n" -"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n" -"\t\t\tnext $definitionScript\n" -"\t\t}\n" -"\t\tdefinitionnamespace -class configuresupport::configurableclass\n" +"\tclass create configurable\n" +"\tdefine configurable superclass -set class\n" +"\tdefine configurable constructor {{definitionScript \"\"}} {\n" +"\t\tnext {mixin ::oo::configuresupport::configurable}\n" +"\t\tnext $definitionScript\n" "\t}\n" +"\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n" "}\n" /* !END!: Do not edit above this line. */ ; diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index e829fcf..2b9e2a4 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -195,22 +195,18 @@ # # ---------------------------------------------------------------------- - define Slot { - # ------------------------------------------------------------------ - # - # Slot --default-operation -- - # - # If a slot can't figure out what method to call directly, it - # uses --default-operation. - # - # ------------------------------------------------------------------ - - # Default handling - forward --default-operation my -append - - # Hide destroy - unexport destroy - } + # ------------------------------------------------------------------ + # + # Slot --default-operation -- + # + # If a slot can't figure out what method to call directly, it + # uses --default-operation. + # + # ------------------------------------------------------------------ + define Slot forward --default-operation my -append + + # Hide destroy + define Slot unexport destroy # Set the default operation differently for these slots objdefine define::superclass forward --default-operation my -set @@ -283,26 +279,25 @@ # # ---------------------------------------------------------------------- - class create singleton { - superclass -set class - variable -set object - unexport create createWithNamespace - method new args { - if {![info exists object] || ![info object isa object $object]} { - set object [next {*}$args] - ::oo::objdefine $object { - method destroy {} { - ::return -code error -errorcode {TCL OO SINGLETON} \ - "may not destroy a singleton object" - } - method -unexport {originObject} { - ::return -code error -errorcode {TCL OO SINGLETON} \ - "may not clone a singleton object" - } + class create singleton + define singleton superclass -set class + define singleton variable -set object + define singleton unexport create createWithNamespace + define singleton method new args { + if {![info exists object] || ![info object isa object $object]} { + set object [next {*}$args] + ::oo::objdefine $object { + method destroy {} { + ::return -code error -errorcode {TCL OO SINGLETON} \ + "may not destroy a singleton object" + } + method -unexport {originObject} { + ::return -code error -errorcode {TCL OO SINGLETON} \ + "may not clone a singleton object" } } - return $object } + return $object } # ---------------------------------------------------------------------- @@ -314,10 +309,9 @@ # # ---------------------------------------------------------------------- - class create abstract { - superclass -set class - unexport create createWithNamespace new - } + class create abstract + define abstract superclass -set class + define abstract unexport create createWithNamespace new # ---------------------------------------------------------------------- # @@ -397,16 +391,14 @@ # # ---------------------------------------------------------------------- - class create configurable { - superclass -set class - - constructor {{definitionScript ""}} { - next {mixin ::oo::configuresupport::configurable} - next $definitionScript - } - - definitionnamespace -class configuresupport::configurableclass + class create configurable + define configurable superclass -set class + define configurable constructor {{definitionScript ""}} { + next {mixin ::oo::configuresupport::configurable} + next $definitionScript } + + define configurable definitionnamespace -class configuresupport::configurableclass } # Local Variables: -- cgit v0.12 From 10f3bcbb8d0434693a3cf99c50ccbcd5be80e484 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 20 Aug 2025 10:11:04 +0000 Subject: Move another command into C: classvariable --- generic/tclOO.c | 2 ++ generic/tclOOBasic.c | 91 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOInt.h | 1 + generic/tclOOScript.h | 17 ---------- tools/tclOOScript.tcl | 29 ---------------- 5 files changed, 94 insertions(+), 46 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 1e8012f..4a2e35c 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -444,6 +444,8 @@ InitFoundation( TclOOCallbackObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->helpersNs, "mymethod", TclOOCallbackObjCmd, NULL, NULL, 0); + CreateCmdInNS(interp, fPtr->helpersNs, "classvariable", + TclOOClassVariableObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->helpersNs, "next", NULL, TclOONextObjCmd, TclCompileObjectNextCmd, CMD_COMPILES_EXPANDED); CreateCmdInNS(interp, fPtr->helpersNs, "nextto", diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index aefa91d..866f080 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1412,6 +1412,97 @@ TclOOCallbackObjCmd( } /* + * ---------------------------------------------------------------------- + * + * TclOOClassVariableObjCmd -- + * + * Implementation of the [classvariable] command, which links to + * variables in the class of the current object. + * + * ---------------------------------------------------------------------- + */ +int +TclOOClassVariableObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ..."); + return TCL_ERROR; + } + + /* + * Start with sanity checks on the calling context to make sure that we + * are invoked from a suitable method context. If so, we can safely + * retrieve the handle to the object call context. + */ + + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); + OO_ERROR(interp, CONTEXT_REQUIRED); + return TCL_ERROR; + } + + // Get a reference to the class's namespace + CallContext *contextPtr = (CallContext *) framePtr->clientData; + Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; + if (clsPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method not defined by a class", TCL_AUTO_LENGTH)); + OO_ERROR(interp, UNMATCHED_CONTEXT); + return TCL_ERROR; + } + Tcl_Namespace *clsNsPtr = clsPtr->thisPtr->namespacePtr; + + // Check the list of variable names + for (int i = 1; i < objc; i++) { + const char *varName = TclGetString(objv[i]); + if (Tcl_StringMatch(varName, "*(*)")) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad variable name \"%s\": can't create a %s", + varName, "scalar variable that looks like an array element")); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); + return TCL_ERROR; + } + if (Tcl_StringMatch(varName, "*::*")) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad variable name \"%s\": can't create a %s", + varName, "local variable with a namespace separator in it")); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); + return TCL_ERROR; + } + } + + // Lastly, link the caller's local variables to the class's variables + Tcl_Namespace *ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + for (int i = 1; i < objc; i++) { + // Locate the other variable. + iPtr->varFramePtr->nsPtr = (Namespace *) clsNsPtr; + Var *arrayPtr, *otherPtr = TclObjLookupVarEx(interp, objv[i], NULL, + (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), + "access", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); + iPtr->varFramePtr->nsPtr = (Namespace *) ourNsPtr; + if (otherPtr == NULL) { + return TCL_ERROR; + } + + // Create the new variable and link it to otherPtr. + if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, -1) != TCL_OK) { + return TCL_ERROR; + } + } + + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 94eda61..0367e60 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -519,6 +519,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePropertyCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition; MODULE_SCOPE Tcl_ObjCmdProc TclOOCallbackObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOClassVariableObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd; diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 6b0c5bd..dcc44c0 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,23 +27,6 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\tproc Helpers::classvariable {name args} {\n" -"\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" -"\t\tforeach v [list $name {*}$args] {\n" -"\t\t\tif {[string match *(*) $v]} {\n" -"\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" -"\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" -"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t}\n" -"\t\t\tif {[string match *::* $v]} {\n" -"\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" -"\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" -"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t}\n" -"\t\t\tlappend vs $v $v\n" -"\t\t}\n" -"\t\ttailcall namespace upvar $ns {*}$vs\n" -"\t}\n" "\tproc Helpers::link {args} {\n" "\t\tset ns [uplevel 1 {::namespace current}]\n" "\t\tforeach link $args {\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 2b9e2a4..3f34c56 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -19,35 +19,6 @@ # ------------------------------------------------------------------ # - # classvariable -- - # - # Link to a variable in the class of the current object. - # - # ------------------------------------------------------------------ - - proc Helpers::classvariable {name args} { - # Get a reference to the class's namespace - set ns [info object namespace [uplevel 1 {self class}]] - # Double up the list of variable names - foreach v [list $name {*}$args] { - if {[string match *(*) $v]} { - set reason "can't create a scalar variable that looks like an array element" - return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \ - [format {bad variable name "%s": %s} $v $reason] - } - if {[string match *::* $v]} { - set reason "can't create a local variable with a namespace separator in it" - return -code error -errorcode {TCL UPVAR INVERTED} \ - [format {bad variable name "%s": %s} $v $reason] - } - lappend vs $v $v - } - # Lastly, link the caller's local variables to the class's variables - tailcall namespace upvar $ns {*}$vs - } - - # ------------------------------------------------------------------ - # # link -- # # Make a command that invokes a method on the current object. -- cgit v0.12 From f80e08da71e969b6b79dd861d91f684a8159e9f2 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 20 Aug 2025 12:22:28 +0000 Subject: Move a bit of internal machinery --- generic/tclOO.c | 1 + generic/tclOOBasic.c | 37 ++++++++++++++++++++++++++++++++++++- generic/tclOOInt.h | 1 + generic/tclOOScript.h | 3 --- tools/tclOOScript.tcl | 14 -------------- 5 files changed, 38 insertions(+), 18 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 4a2e35c..ec20537 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -456,6 +456,7 @@ InitFoundation( CreateCmdInNS(interp, fPtr->ooNs, "define", TclOODefineObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->ooNs, "objdefine", TclOOObjDefObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->ooNs, "copy", TclOOCopyObjectCmd, NULL, NULL, 0); + CreateCmdInNS(interp, fPtr->ooNs, "DelegateName", TclOODelegateNameObjCmd, NULL, NULL, 0); TclOOInitInfo(interp); diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 866f080..44d8cb6 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1494,7 +1494,8 @@ TclOOClassVariableObjCmd( } // Create the new variable and link it to otherPtr. - if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, -1) != TCL_OK) { + if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, + TCL_INDEX_NONE) != TCL_OK) { return TCL_ERROR; } } @@ -1503,6 +1504,40 @@ TclOOClassVariableObjCmd( } /* + * ---------------------------------------------------------------------- + * + * TclOODelegateNameObjCmd -- + * + * Implementation of the [oo::DelegateName] command, which is a utility + * that gets the name of the class delegate for a class. It's trivial, + * but makes working with them much easier as delegate names are + * intentionally hard to create by accident. + * + * Not part of TclOO public API. No public documentation. + * + * ---------------------------------------------------------------------- + */ +int +TclOODelegateNameObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "class"); + return TCL_ERROR; + } + Class *clsPtr = TclOOGetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s:: oo ::delegate", + clsPtr->thisPtr->namespacePtr->fullName)); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 0367e60..1331703 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -521,6 +521,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition; MODULE_SCOPE Tcl_ObjCmdProc TclOOCallbackObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOClassVariableObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODelegateNameObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd; diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index dcc44c0..643e536 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -52,9 +52,6 @@ static const char *tclOOSetupScript = "\t\t\trename $cmd {}\n" "\t\t}\n" "\t}\n" -"\tproc DelegateName {class} {\n" -"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n" -"\t}\n" "\tproc MixinClassDelegates {class} {\n" "\t\tif {![info object isa class $class]} {\n" "\t\t\treturn\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 3f34c56..2cf40e1 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -65,20 +65,6 @@ # ---------------------------------------------------------------------- # - # DelegateName -- - # - # Utility that gets the name of the class delegate for a class. It's - # trivial, but makes working with them much easier as delegate names are - # intentionally hard to create by accident. - # - # ---------------------------------------------------------------------- - - proc DelegateName {class} { - string cat [info object namespace $class] {:: oo ::delegate} - } - - # ---------------------------------------------------------------------- - # # MixinClassDelegates -- # # Support code called *after* [oo::define] inside the constructor of a -- cgit v0.12 From 4864c57e4d1995198bfd8860b50529c303efe533 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Aug 2025 15:53:11 +0000 Subject: Eliminate clang compiler warning: use of logical '&&' with constant operand --- generic/tclOO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 8ac5494..76e2016 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1240,7 +1240,7 @@ ObjectNamespaceDeleted( * freed memory. */ - if (((Command *) oPtr->command)->flags && CMD_DYING) { + if (((Command *) oPtr->command)->flags & CMD_DYING) { /* * Something has already started the command deletion process. We can * go ahead and clean up the namespace, -- cgit v0.12 From 7093dc16ae75a5a9c2a60c29752aa153ca40f6f9 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 21 Aug 2025 16:21:10 +0000 Subject: Make logical -> bitwise correction corresponding to recent change in Tcl 9. --- generic/tclOO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 9dce0ef..b488cee 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1168,7 +1168,7 @@ ObjectNamespaceDeleted( * freed memory. */ - if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) { + if (((Command *) oPtr->command)->flags & CMD_IS_DELETED) { /* * Something has already started the command deletion process. We can * go ahead and clean up the namespace, -- cgit v0.12 From 03dd129a16f43ca26c64bce498157abd7e249856 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 07:16:45 +0000 Subject: Fix memory debugging info --- generic/tclStringObj.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 13fbdbc..c33860d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -235,6 +235,10 @@ Tcl_NewStringObj( { return Tcl_DbNewStringObj(bytes, length, "unknown", 0); } + +// Redefine the macro +#define Tcl_NewStringObj(bytes, len) \ + Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewStringObj( -- cgit v0.12 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 From 1e47aa3a2e2d85795e56613c97a47a6777e153d1 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 07:50:00 +0000 Subject: Move another definition (classmethod) into C. --- generic/tclOO.c | 1 + generic/tclOODefineCmds.c | 66 +++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOInt.h | 1 + generic/tclOOScript.h | 13 ---------- tools/tclOOScript.tcl | 28 -------------------- 5 files changed, 68 insertions(+), 41 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 0ef69a4..3eeeb80 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -25,6 +25,7 @@ static const struct { Tcl_ObjCmdProc *objProc; int flag; } defineCmds[] = { + {"classmethod", TclOODefineClassMethodObjCmd, 0}, {"constructor", TclOODefineConstructorObjCmd, 0}, {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 199fce7..40c4fe0 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2228,6 +2228,72 @@ TclOODefineMethodObjCmd( /* * ---------------------------------------------------------------------- * + * TclOODefineClassMethodObjCmd -- + * + * Implementation of the "classmethod" subcommand of the "oo::define" + * command. Defines a class method. See define(n) for details. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineClassMethodObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + if (objc != 2 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?args body?"); + return TCL_ERROR; + } + Class *clsPtr = TclOOGetClassDefineCmdContext(interp); + if (!clsPtr) { + return TCL_ERROR; + } + + int isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) + ? PUBLIC_METHOD : 0; + + // Create the method on the delegate class if the caller gave arguments and body + if (objc == 4) { + Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate", + clsPtr->thisPtr->namespacePtr->fullName); + Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName); + Tcl_DecrRefCount(delegateName); + if (!delegatePtr) { + return TCL_ERROR; + } + if (IsPrivateDefine(interp)) { + isPublic = 0; + } + if (TclOONewProcMethod(interp, delegatePtr, isPublic, objv[1], + objv[2], objv[3], NULL) == NULL) { + return TCL_ERROR; + } + } + + // Make the connection to the delegate by forwarding + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } + Tcl_Obj *forwardArgs[] = { + Tcl_NewStringObj("myclass", -1), + objv[1] + }; + Tcl_Obj *prefixObj = Tcl_NewListObj(2, forwardArgs); + Method *mPtr = TclOONewForwardMethod(interp, clsPtr, isPublic, + objv[1], prefixObj); + if (mPtr == NULL) { + Tcl_DecrRefCount(prefixObj); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineRenameMethodObjCmd -- * * Implementation of the "renamemethod" subcommand of the "oo::define" diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 90d5069..7ea5999 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -500,6 +500,7 @@ struct DeclaredClassMethod { MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDefnNsObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd; diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index bd3721b..4a69bc8 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -66,19 +66,6 @@ static const char *tclOOSetupScript = "\t\t\t\t}]\n" "\t\t}\n" "\t}\n" -"\tproc define::classmethod {name args} {\n" -"\t\t::set argc [::llength [::info level 0]]\n" -"\t\t::if {$argc == 3} {\n" -"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n" -"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n" -"\t\t\t\t[::lindex [::info level 0] 0]]\n" -"\t\t}\n" -"\t\t::set cls [::uplevel 1 self]\n" -"\t\t::if {$argc == 4} {\n" -"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n" -"\t\t}\n" -"\t\t::tailcall forward $name myclass $name\n" -"\t}\n" "\tdefine Slot forward --default-operation my -append\n" "\tdefine Slot unexport destroy\n" "\tobjdefine define::superclass forward --default-operation my -set\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 4509202..e480aac 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -90,34 +90,6 @@ # ---------------------------------------------------------------------- # - # oo::define::classmethod -- - # - # Defines a class method. See define(n) for details. - # - # Note that the ::oo::define namespace is semi-public and a bit weird - # anyway, so we don't regard the namespace path as being under control: - # fully qualified names are used for everything. - # - # ---------------------------------------------------------------------- - - proc define::classmethod {name args} { - # Create the method on the class if the caller gave arguments and body - ::set argc [::llength [::info level 0]] - ::if {$argc == 3} { - ::return -code error -errorcode {TCL WRONGARGS} [::format \ - {wrong # args: should be "%s name ?args body?"} \ - [::lindex [::info level 0] 0]] - } - ::set cls [::uplevel 1 self] - ::if {$argc == 4} { - ::oo::define [::oo::DelegateName $cls] method $name {*}$args - } - # Make the connection by forwarding - ::tailcall forward $name myclass $name - } - - # ---------------------------------------------------------------------- - # # Slot -- # # The class of slot operations, which are basically lists at the low -- cgit v0.12 From 6a89806ee62b84b96bafb2d86c0726a9408fbe0f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 11:45:24 +0000 Subject: Move [link] into C. --- generic/tclInt.h | 4 +++ generic/tclInterp.c | 20 +++++------ generic/tclOO.c | 14 ++++++++ generic/tclOOBasic.c | 92 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOInt.h | 2 ++ generic/tclOOScript.h | 25 -------------- tools/tclOOScript.tcl | 51 ---------------------------- 7 files changed, 120 insertions(+), 88 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 096d5e7..9252eb8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3282,6 +3282,10 @@ MODULE_SCOPE void TclAdvanceContinuations(int *line, Tcl_Size **next, Tcl_Size loc); MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, const char *end); +MODULE_SCOPE int TclAliasCreate(Tcl_Interp *interp, + Tcl_Interp *childInterp, Tcl_Interp *parentInterp, + Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc, + Tcl_Obj *const objv[]); MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size len); MODULE_SCOPE void TclAppendUtfToUtf(Tcl_Obj *objPtr, diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 061ddcf..77d06f6 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -221,10 +221,6 @@ enum LimitHandlerFlags { * Prototypes for local static functions: */ -static int AliasCreate(Tcl_Interp *interp, - Tcl_Interp *childInterp, Tcl_Interp *parentInterp, - Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc, - Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, Tcl_Interp *childInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, @@ -701,7 +697,7 @@ NRInterpCmd( return TCL_ERROR; } - return AliasCreate(interp, childInterp, parentInterp, objv[3], + return TclAliasCreate(interp, childInterp, parentInterp, objv[3], objv[5], objc - 6, objv + 6); } @@ -1232,7 +1228,7 @@ Tcl_CreateAlias( targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, + result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, argc, objv); for (i = 0; i < argc; i++) { @@ -1279,7 +1275,7 @@ Tcl_CreateAliasObj( targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, + result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, objc, objv); Tcl_DecrRefCount(childObjPtr); @@ -1452,7 +1448,7 @@ TclPreventAliasLoop( /* *---------------------------------------------------------------------- * - * AliasCreate -- + * TclAliasCreate -- * * Helper function to do the work to actually create an alias. * @@ -1466,8 +1462,8 @@ TclPreventAliasLoop( *---------------------------------------------------------------------- */ -static int -AliasCreate( +int +TclAliasCreate( Tcl_Interp *interp, /* Interp for error reporting. */ Tcl_Interp *childInterp, /* Interp where alias cmd will live or from * which alias will be deleted. */ @@ -2468,7 +2464,7 @@ ChildCreate( TclNewLiteralStringObj(clockObj, "clock"); Tcl_IncrRefCount(clockObj); - status = AliasCreate(interp, childInterp, parentInterp, clockObj, + status = TclAliasCreate(interp, childInterp, parentInterp, clockObj, clockObj, 0, NULL); Tcl_DecrRefCount(clockObj); if (status != TCL_OK) { @@ -2558,7 +2554,7 @@ NRChildCmd( return AliasDelete(interp, childInterp, objv[2]); } } else { - return AliasCreate(interp, childInterp, interp, objv[2], + return TclAliasCreate(interp, childInterp, interp, objv[2], objv[3], objc - 4, objv + 4); } } diff --git a/generic/tclOO.c b/generic/tclOO.c index e0cde38..d7dea8d 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -445,6 +445,8 @@ InitFoundation( TclOOCallbackObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->helpersNs, "classvariable", TclOOClassVariableObjCmd, NULL, NULL, 0); + CreateCmdInNS(interp, fPtr->helpersNs, "link", + TclOOLinkObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->helpersNs, "next", NULL, TclOONextObjCmd, TclCompileObjectNextCmd, CMD_COMPILES_EXPANDED); CreateCmdInNS(interp, fPtr->helpersNs, "nextto", @@ -817,6 +819,7 @@ AllocObject( oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, MyClassDeleted); + oPtr->linkedCmdsList = NULL; return oPtr; } @@ -861,6 +864,17 @@ MyDeleted( { Object *oPtr = (Object *) clientData; + if (oPtr->linkedCmdsList) { + Tcl_Size linkc, i; + Tcl_Obj **linkv; + TclListObjGetElements(NULL, oPtr->linkedCmdsList, &linkc, &linkv); + for (i=0 ; ifPtr->interp, TclGetString(link)); + } + Tcl_DecrRefCount(oPtr->linkedCmdsList); + oPtr->linkedCmdsList = NULL; + } oPtr->myCommand = NULL; } diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 18dd5e9..6884db6 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1014,6 +1014,98 @@ TclOO_Object_VarName( /* * ---------------------------------------------------------------------- * + * TclOOLinkObjCmd -- + * + * Implementation of the [link] command, that makes a command that + * invokes a method on the current object. The name of the command and + * the name of the method match by default. Note that this command is + * only ever to be used inside the body of a procedure-like method, + * and is typically intended for constructors. + * + * ---------------------------------------------------------------------- + */ +int +TclOOLinkObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + // Set up common bits. + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); + OO_ERROR(interp, CONTEXT_REQUIRED); + return TCL_ERROR; + } + CallContext *context = (CallContext *) framePtr->clientData; + Object *oPtr = context->oPtr; + if (!oPtr->myCommand) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot link to non-existent callback handle")); + OO_ERROR(interp, MY_GONE); + return TCL_ERROR; + } + Tcl_Obj *myCmd = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, oPtr->myCommand, myCmd); + if (!oPtr->linkedCmdsList) { + oPtr->linkedCmdsList = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(oPtr->linkedCmdsList); + } + + // For each argument + for (int i=1; ioPtr->namespacePtr->fullName, srcStr); + } + + // Make the alias command + if (TclAliasCreate(interp, interp, interp, src, myCmd, 1, &dst) != TCL_OK) { + Tcl_BounceRefCount(myCmd); + Tcl_BounceRefCount(src); + return TCL_ERROR; + } + + // Remember the alias for cleanup if necessary + Tcl_ListObjAppendElement(NULL, oPtr->linkedCmdsList, src); + } + Tcl_BounceRefCount(myCmd); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * TclOONextObjCmd, TclOONextToObjCmd -- * * Implementation of the [next] and [nextto] commands. Note that these diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 7ea5999..777c7fa 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -255,6 +255,7 @@ struct Object { PropertyStorage properties; /* Information relating to the lists of * properties that this object *claims* to * support. */ + Tcl_Obj *linkedCmdsList; /* List of names of linked commands. */ }; enum ObjectFlags { @@ -521,6 +522,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOOCallbackObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOClassVariableObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODelegateNameObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOLinkObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd; diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 4a69bc8..79379d3 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,31 +27,6 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\tproc Helpers::link {args} {\n" -"\t\tset ns [uplevel 1 {::namespace current}]\n" -"\t\tforeach link $args {\n" -"\t\t\tif {[llength $link] == 2} {\n" -"\t\t\t\tlassign $link src dst\n" -"\t\t\t} elseif {[llength $link] == 1} {\n" -"\t\t\t\tlassign $link src\n" -"\t\t\t\tset dst $src\n" -"\t\t\t} else {\n" -"\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n" -"\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" -"\t\t\t}\n" -"\t\t\tif {![string match ::* $src]} {\n" -"\t\t\t\tset src [string cat $ns :: $src]\n" -"\t\t\t}\n" -"\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" -"\t\t\ttrace add command ${ns}::my delete [list \\\n" -"\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" -"\t\t}\n" -"\t}\n" -"\tproc UnlinkLinkedCommand {cmd args} {\n" -"\t\tif {[namespace which $cmd] ne {}} {\n" -"\t\t\trename $cmd {}\n" -"\t\t}\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 e480aac..8bb214a 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -12,57 +12,6 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. ::namespace eval ::oo { - - # - # Commands that are made available to objects by default. - # - - # ------------------------------------------------------------------ - # - # link -- - # - # Make a command that invokes a method on the current object. - # The name of the command and the name of the method match by - # default. - # - # ------------------------------------------------------------------ - - proc Helpers::link {args} { - set ns [uplevel 1 {::namespace current}] - foreach link $args { - if {[llength $link] == 2} { - lassign $link src dst - } elseif {[llength $link] == 1} { - lassign $link src - set dst $src - } else { - return -code error -errorcode {TCL OO CMDLINK_FORMAT} \ - "bad link description; must only have one or two elements" - } - if {![string match ::* $src]} { - set src [string cat $ns :: $src] - } - interp alias {} $src {} ${ns}::my $dst - trace add command ${ns}::my delete [list \ - ::oo::UnlinkLinkedCommand $src] - } - } - - # ---------------------------------------------------------------------- - # - # UnlinkLinkedCommand -- - # - # Callback used to remove linked command when the underlying mechanism - # that supports it is deleted. - # - # ---------------------------------------------------------------------- - - proc UnlinkLinkedCommand {cmd args} { - if {[namespace which $cmd] ne {}} { - rename $cmd {} - } - } - # ---------------------------------------------------------------------- # # UpdateClassDelegatesAfterClone -- -- cgit v0.12 From eb5871174066e297e0975aa323f7fb1b37c2fcbe Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 13:43:50 +0000 Subject: Combine UpdateClassDelegatesAfterClone into its caller. --- generic/tclOOScript.h | 32 +++++++++++++++----------------- tools/tclOOScript.tcl | 43 +++++++++++++++---------------------------- 2 files changed, 30 insertions(+), 45 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 79379d3..0bec4fa 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,20 +27,6 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" -"\t\tset originDelegate [DelegateName $originObject]\n" -"\t\tset targetDelegate [DelegateName $targetObject]\n" -"\t\tif {\n" -"\t\t\t[info object isa class $originDelegate]\n" -"\t\t\t&& ![info object isa class $targetDelegate]\n" -"\t\t} then {\n" -"\t\t\tcopy $originDelegate $targetDelegate\n" -"\t\t\tobjdefine $targetObject ::oo::objdefine::mixin -set \\\n" -"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n" -"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n" -"\t\t\t\t}]\n" -"\t\t}\n" -"\t}\n" "\tdefine Slot forward --default-operation my -append\n" "\tdefine Slot unexport destroy\n" "\tobjdefine define::superclass forward --default-operation my -set\n" @@ -74,8 +60,20 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t}\n" "\tdefine class method -unexport {originObject} {\n" +"\t\tset targetObject [self]\n" "\t\tnext $originObject\n" -"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" +"\t\tset originDelegate [::oo::DelegateName $originObject]\n" +"\t\tset targetDelegate [::oo::DelegateName $targetObject]\n" +"\t\tif {\n" +"\t\t\t[info object isa class $originDelegate]\n" +"\t\t\t&& ![info object isa class $targetDelegate]\n" +"\t\t} then {\n" +"\t\t\t::oo::copy $originDelegate $targetDelegate\n" +"\t\t\t::oo::objdefine $targetObject mixin -set \\\n" +"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n" +"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n" +"\t\t\t\t}]\n" +"\t\t}\n" "\t}\n" "\tclass create singleton\n" "\tdefine singleton superclass -set class\n" @@ -86,11 +84,11 @@ static const char *tclOOSetupScript = "\t\t\tset object [next {*}$args]\n" "\t\t\t::oo::objdefine $object {\n" "\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" "\t\t\t\t\t\t\"may not destroy a singleton object\"\n" "\t\t\t\t}\n" "\t\t\t\tmethod -unexport {originObject} {\n" -"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" "\t\t\t\t\t\t\"may not clone a singleton object\"\n" "\t\t\t\t}\n" "\t\t\t}\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 8bb214a..d871d57 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -14,31 +14,6 @@ ::namespace eval ::oo { # ---------------------------------------------------------------------- # - # UpdateClassDelegatesAfterClone -- - # - # Support code that is like [MixinClassDelegates] except for when a - # class is cloned. - # - # ---------------------------------------------------------------------- - - proc UpdateClassDelegatesAfterClone {originObject targetObject} { - # Rebuild the class inheritance delegation class - set originDelegate [DelegateName $originObject] - set targetDelegate [DelegateName $targetObject] - if { - [info object isa class $originDelegate] - && ![info object isa class $targetDelegate] - } then { - copy $originDelegate $targetDelegate - objdefine $targetObject ::oo::objdefine::mixin -set \ - {*}[lmap c [info object mixin $targetObject] { - if {$c eq $originDelegate} {set targetDelegate} {set c} - }] - } - } - - # ---------------------------------------------------------------------- - # # Slot -- # # The class of slot operations, which are basically lists at the low @@ -116,9 +91,21 @@ # ---------------------------------------------------------------------- define class method -unexport {originObject} { + set targetObject [self] next $originObject # Rebuild the class inheritance delegation class - ::oo::UpdateClassDelegatesAfterClone $originObject [self] + set originDelegate [::oo::DelegateName $originObject] + set targetDelegate [::oo::DelegateName $targetObject] + if { + [info object isa class $originDelegate] + && ![info object isa class $targetDelegate] + } then { + ::oo::copy $originDelegate $targetDelegate + ::oo::objdefine $targetObject mixin -set \ + {*}[lmap c [info object mixin $targetObject] { + if {$c eq $originDelegate} {set targetDelegate} {set c} + }] + } } # ---------------------------------------------------------------------- @@ -139,11 +126,11 @@ set object [next {*}$args] ::oo::objdefine $object { method destroy {} { - ::return -code error -errorcode {TCL OO SINGLETON} \ + return -code error -errorcode {TCL OO SINGLETON} \ "may not destroy a singleton object" } method -unexport {originObject} { - ::return -code error -errorcode {TCL OO SINGLETON} \ + return -code error -errorcode {TCL OO SINGLETON} \ "may not clone a singleton object" } } -- cgit v0.12 From 800194c7f4ddd68ec444f5a350867e546283e35c Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 14:23:56 +0000 Subject: Tweak to [configurable] to not call [next] twice --- generic/tclOOScript.h | 2 +- tools/tclOOScript.tcl | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 0bec4fa..318a7ac 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -115,7 +115,7 @@ static const char *tclOOSetupScript = "\tclass create configurable\n" "\tdefine configurable superclass -set class\n" "\tdefine configurable constructor {{definitionScript \"\"}} {\n" -"\t\tnext {mixin ::oo::configuresupport::configurable}\n" +"\t\too::define [self] {mixin -append ::oo::configuresupport::configurable}\n" "\t\tnext $definitionScript\n" "\t}\n" "\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index d871d57..66e125d 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -232,7 +232,7 @@ class create configurable define configurable superclass -set class define configurable constructor {{definitionScript ""}} { - next {mixin ::oo::configuresupport::configurable} + ::oo::define [self] {mixin -append ::oo::configuresupport::configurable} next $definitionScript } -- cgit v0.12 From cca1a031f796787ad1f40e39cf6d88c163c41e6f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 14:52:30 +0000 Subject: Fix memory debugging info --- generic/tclStringObj.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 76ad05e..19cda6f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -235,6 +235,10 @@ Tcl_NewStringObj( { return Tcl_DbNewStringObj(bytes, length, "unknown", 0); } + +// Redefine the macro +#define Tcl_NewStringObj(bytes, len) \ + Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewStringObj( -- cgit v0.12 From 63e9714b2ebee7046c5a8506b54e836c3f567a86 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 15:02:51 +0000 Subject: Start making TclOO faster to initialise (backport) --- generic/tclOO.c | 28 ++++++++++++++++++++++++ generic/tclOOBasic.c | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOInt.h | 2 ++ generic/tclOOScript.h | 8 ------- tools/tclOOScript.tcl | 20 ----------------- 5 files changed, 89 insertions(+), 28 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 76e2016..09071e6 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -428,6 +428,10 @@ InitFoundation( * ensemble. */ + CreateCmdInNS(interp, fPtr->helpersNs, "callback", + TclOOCallbackObjCmd, NULL, NULL, 0); + CreateCmdInNS(interp, fPtr->helpersNs, "mymethod", + TclOOCallbackObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->helpersNs, "next", NULL, TclOONextObjCmd, TclCompileObjectNextCmd); CreateCmdInNS(interp, fPtr->helpersNs, "nextto", @@ -3144,6 +3148,30 @@ Tcl_GetObjectName( /* * ---------------------------------------------------------------------- * + * TclOOObjectMyName -- + * + * Utility function that returns the name of the object's [my], or NULL + * if it has been deleted (or otherwise doesn't exist). + * + * ---------------------------------------------------------------------- + */ +Tcl_Obj * +TclOOObjectMyName( + Tcl_Interp *interp, + Object *oPtr) +{ + Tcl_Obj *namePtr; + if (!oPtr->myCommand) { + return NULL; + } + TclNewObj(namePtr); + Tcl_GetCommandFullName(interp, oPtr->myCommand, namePtr); + return namePtr; +} + +/* + * ---------------------------------------------------------------------- + * * assorted trivial 'getter' functions * * ---------------------------------------------------------------------- diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index f7bb969..092bc0d 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1373,6 +1373,65 @@ TclOOCopyObjectCmd( } /* + * ---------------------------------------------------------------------- + * + * TclOOCallbackObjCmd -- + * + * Implementation of the [callback] command, which constructs callbacks + * into the current object. + * + * ---------------------------------------------------------------------- + */ +int +TclOOCallbackObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + CallContext *contextPtr; + Tcl_Obj *namePtr, *listPtr; + + /* + * Start with sanity checks on the calling context to make sure that we + * are invoked from a suitable method context. If so, we can safely + * retrieve the handle to the object call context. + */ + + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); + OO_ERROR(interp, CONTEXT_REQUIRED); + return TCL_ERROR; + } + + contextPtr = (CallContext *) framePtr->clientData; + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "method ..."); + return TCL_ERROR; + } + + // Get the [my] real name. + namePtr = TclOOObjectMyName(interp, contextPtr->oPtr); + if (!namePtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no possible safe callback without my", TCL_AUTO_LENGTH)); + OO_ERROR(interp, NO_MY); + return TCL_ERROR; + } + + // No check that the method exists; could be dynamically added. + + listPtr = Tcl_NewListObj(1, &namePtr); + (void) TclListObjAppendElements(NULL, listPtr, objc-1, objv+1); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index ec91971..4e7d4d0 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -513,6 +513,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjSelfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePropertyCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition; +MODULE_SCOPE Tcl_ObjCmdProc TclOOCallbackObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd; @@ -608,6 +609,7 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, MODULE_SCOPE void TclOODefineBasicMethods(Class *clsPtr, const DeclaredClassMethod *dcm); MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); +MODULE_SCOPE Tcl_Obj * TclOOObjectMyName(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOOReleaseClassContents(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 98fa20e..50d827f 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -30,14 +30,6 @@ static const char *tclOOSetupScript = "\t::namespace path {}\n" "\tnamespace eval Helpers {\n" "\t\tnamespace path {}\n" -"\t\tproc callback {method args} {\n" -"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n" -"\t\t}\n" -"\t\tnamespace export callback\n" -"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n" -"\t\tnamespace export -clear\n" -"\t\trename tmp::callback mymethod\n" -"\t\tnamespace delete tmp\n" "\t\tproc classvariable {name args} {\n" "\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" "\t\t\tforeach v [list $name {*}$args] {\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 2110861..cb77bb3 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -22,26 +22,6 @@ # ------------------------------------------------------------------ # - # callback, mymethod -- - # - # Create a script prefix that calls a method on the current - # object. Same operation, two names. - # - # ------------------------------------------------------------------ - - proc callback {method args} { - list [uplevel 1 {::namespace which my}] $method {*}$args - } - - # Make the [callback] command appear as [mymethod] too. - namespace export callback - namespace eval tmp {namespace import ::oo::Helpers::callback} - namespace export -clear - rename tmp::callback mymethod - namespace delete tmp - - # ------------------------------------------------------------------ - # # classvariable -- # # Link to a variable in the class of the current object. -- cgit v0.12 From ff93032670a4b3e36a90eb3f6725e6dff64d4b6f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 17:15:48 +0000 Subject: Accelerate definition of [oo::define initialise]. (backport) --- generic/tclOO.c | 2 ++ generic/tclOODefineCmds.c | 47 +++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOInt.h | 1 + generic/tclOOScript.h | 11 ----------- tests/ooUtil.test | 10 ++-------- tools/tclOOScript.tcl | 26 -------------------------- 6 files changed, 52 insertions(+), 45 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 09071e6..a4c4da1 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -31,6 +31,8 @@ static const struct { {"destructor", TclOODefineDestructorObjCmd, 0}, {"export", TclOODefineExportObjCmd, 0}, {"forward", TclOODefineForwardObjCmd, 0}, + {"initialise", TclOODefineInitialiseObjCmd, 0}, + {"initialize", TclOODefineInitialiseObjCmd, 0}, {"method", TclOODefineMethodObjCmd, 0}, {"private", TclOODefinePrivateObjCmd, 0}, {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index e029649..5b6de0e 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2032,6 +2032,53 @@ TclOODefineForwardObjCmd( /* * ---------------------------------------------------------------------- * + * TclOODefineInitialiseObjCmd -- + * + * Implementation of the "initialise" subcommand of the "oo::define" + * command. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineInitialiseObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Object object; + Tcl_Obj *lambdaWords[3], *applyArgs[2]; + int result; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "body"); + return TCL_ERROR; + } + + // Build the lambda + object = TclOOGetDefineCmdContext(interp); + if (object == NULL) { + return TCL_ERROR; + } + lambdaWords[0] = Tcl_NewObj(); + lambdaWords[1] = objv[1]; + lambdaWords[2] = TclNewNamespaceObj(Tcl_GetObjectNamespace(object)); + + // Delegate to [apply] to run it + applyArgs[0] = Tcl_NewStringObj("apply", -1); + applyArgs[1] = Tcl_NewListObj(3, lambdaWords); + Tcl_IncrRefCount(applyArgs[0]); + Tcl_IncrRefCount(applyArgs[1]); + result = Tcl_ApplyObjCmd(NULL, interp, 2, applyArgs); + Tcl_DecrRefCount(applyArgs[0]); + Tcl_DecrRefCount(applyArgs[1]); + return result; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineMethodObjCmd -- * * Implementation of the "method" subcommand of the "oo::define" and diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 4e7d4d0..59a0cb6 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -504,6 +504,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDestructorObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineExportObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineForwardObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineInitialiseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineRenameMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineUnexportObjCmd; diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 50d827f..ff29535 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -121,17 +121,6 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t\t::tailcall forward $name myclass $name\n" "\t}\n" -"\tproc define::initialise {body} {\n" -"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n" -"\t\t::tailcall apply [::list {} $body $clsns]\n" -"\t}\n" -"\tnamespace eval define {\n" -"\t\t::namespace export initialise\n" -"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n" -"\t\t::namespace export -clear\n" -"\t\t::rename tmp::initialise initialize\n" -"\t\t::namespace delete tmp\n" -"\t}\n" "\tdefine Slot {\n" "\t\tmethod Get -unexport {} {\n" "\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n" diff --git a/tests/ooUtil.test b/tests/ooUtil.test index 20607b0..5a8a25b 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -366,7 +366,7 @@ test ooUtil-3.4 {TIP 478: class initialisation} -setup { trace add execution oo::define::initialise enter appendToResultVar oo::class create ::cls { superclass parent - initialize {proc xyzzy {} {}} + initialise {proc xyzzy {} {}} } return $result } -cleanup { @@ -375,13 +375,7 @@ test ooUtil-3.4 {TIP 478: class initialisation} -setup { } rename ::appendToResultVar {} parent destroy -} -result {{initialize {proc xyzzy {} {}}} enter} -test ooUtil-3.5 {TIP 478: class initialisation} -body { - oo::define oo::object { - ::list [::namespace which initialise] [::namespace which initialize] \ - [::namespace origin initialise] [::namespace origin initialize] - } -} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise} +} -result {{initialise {proc xyzzy {} {}}} enter} test ooUtil-4.1 {TIP 478: singleton} -setup { oo::class create parent diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index cb77bb3..b60542f 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -193,32 +193,6 @@ # ---------------------------------------------------------------------- # - # oo::define::initialise, oo::define::initialize -- - # - # Do specific initialisation for a class. See define(n) for details. - # - # Note that the ::oo::define namespace is semi-public and a bit weird - # anyway, so we don't regard the namespace path as being under control: - # fully qualified names are used for everything. - # - # ---------------------------------------------------------------------- - - proc define::initialise {body} { - ::set clsns [::info object namespace [::uplevel 1 self]] - ::tailcall apply [::list {} $body $clsns] - } - - # Make the [initialise] definition appear as [initialize] too - namespace eval define { - ::namespace export initialise - ::namespace eval tmp {::namespace import ::oo::define::initialise} - ::namespace export -clear - ::rename tmp::initialise initialize - ::namespace delete tmp - } - - # ---------------------------------------------------------------------- - # # Slot -- # # The class of slot operations, which are basically lists at the low -- cgit v0.12 From a83fb66df9efd409bf5b52860e816152d1443f8f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 17:17:22 +0000 Subject: Slightly chisel down the execution time of the oo init script (backport) --- generic/tclOOScript.h | 97 +++++++++++++-------------- tools/tclOOScript.tcl | 179 ++++++++++++++++++++++++-------------------------- 2 files changed, 131 insertions(+), 145 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index ff29535..7b8a69d 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,46 +27,41 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\t::namespace path {}\n" -"\tnamespace eval Helpers {\n" -"\t\tnamespace path {}\n" -"\t\tproc classvariable {name args} {\n" -"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" -"\t\t\tforeach v [list $name {*}$args] {\n" -"\t\t\t\tif {[string match *(*) $v]} {\n" -"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" -"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" -"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t\t}\n" -"\t\t\t\tif {[string match *::* $v]} {\n" -"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" -"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" -"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t\t}\n" -"\t\t\t\tlappend vs $v $v\n" +"\tproc Helpers::classvariable {name args} {\n" +"\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" +"\t\tforeach v [list $name {*}$args] {\n" +"\t\t\tif {[string match *(*) $v]} {\n" +"\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" +"\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" +"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" "\t\t\t}\n" -"\t\t\ttailcall namespace upvar $ns {*}$vs\n" +"\t\t\tif {[string match *::* $v]} {\n" +"\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" +"\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" +"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" +"\t\t\t}\n" +"\t\t\tlappend vs $v $v\n" "\t\t}\n" -"\t\tproc link {args} {\n" -"\t\t\tset ns [uplevel 1 {::namespace current}]\n" -"\t\t\tforeach link $args {\n" -"\t\t\t\tif {[llength $link] == 2} {\n" -"\t\t\t\t\tlassign $link src dst\n" -"\t\t\t\t} elseif {[llength $link] == 1} {\n" -"\t\t\t\t\tlassign $link src\n" -"\t\t\t\t\tset dst $src\n" -"\t\t\t\t} else {\n" -"\t\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n" -"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" -"\t\t\t\t}\n" -"\t\t\t\tif {![string match ::* $src]} {\n" -"\t\t\t\t\tset src [string cat $ns :: $src]\n" -"\t\t\t\t}\n" -"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" -"\t\t\t\ttrace add command ${ns}::my delete [list \\\n" -"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" +"\t\ttailcall namespace upvar $ns {*}$vs\n" +"\t}\n" +"\tproc Helpers::link {args} {\n" +"\t\tset ns [uplevel 1 {::namespace current}]\n" +"\t\tforeach link $args {\n" +"\t\t\tif {[llength $link] == 2} {\n" +"\t\t\t\tlassign $link src dst\n" +"\t\t\t} elseif {[llength $link] == 1} {\n" +"\t\t\t\tlassign $link src\n" +"\t\t\t\tset dst $src\n" +"\t\t\t} else {\n" +"\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n" +"\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" "\t\t\t}\n" -"\t\t\treturn\n" +"\t\t\tif {![string match ::* $src]} {\n" +"\t\t\t\tset src [string cat $ns :: $src]\n" +"\t\t\t}\n" +"\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" +"\t\t\ttrace add command ${ns}::my delete [list \\\n" +"\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" "\t\t}\n" "\t}\n" "\tproc UnlinkLinkedCommand {cmd args} {\n" @@ -239,21 +234,19 @@ static const char *tclOOSetupScript = "\t\tsuperclass class\n" "\t\tunexport create createWithNamespace new\n" "\t}\n" -"\tnamespace eval configuresupport {\n" -"\t\t::namespace eval configurableclass {\n" -"\t\t\t::proc properties args {::tailcall property {*}$args}\n" -"\t\t\t::namespace path ::oo::define\n" -"\t\t\t::namespace export property\n" -"\t\t}\n" -"\t\t::namespace eval configurableobject {\n" -"\t\t\t::proc properties args {::tailcall property {*}$args}\n" -"\t\t\t::namespace path ::oo::objdefine\n" -"\t\t\t::namespace export property\n" -"\t\t}\n" -"\t\t::oo::define configurable {\n" -"\t\t\tdefinitionnamespace -instance configurableobject\n" -"\t\t\tdefinitionnamespace -class configurableclass\n" -"\t\t}\n" +"\tnamespace eval configuresupport::configurableclass {\n" +"\t\t::proc properties args {::tailcall property {*}$args}\n" +"\t\t::namespace path ::oo::define\n" +"\t\t::namespace export property\n" +"\t}\n" +"\tnamespace eval configuresupport::configurableobject {\n" +"\t\t::proc properties args {::tailcall property {*}$args}\n" +"\t\t::namespace path ::oo::objdefine\n" +"\t\t::namespace export property\n" +"\t}\n" +"\tdefine configuresupport::configurable {\n" +"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" +"\t\tdefinitionnamespace -class configuresupport::configurableclass\n" "\t}\n" "\tclass create configurable {\n" "\t\tsuperclass class\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index b60542f..442756d 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -12,73 +12,68 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. ::namespace eval ::oo { - ::namespace path {} # # Commands that are made available to objects by default. # - namespace eval Helpers { - namespace path {} - # ------------------------------------------------------------------ - # - # classvariable -- - # - # Link to a variable in the class of the current object. - # - # ------------------------------------------------------------------ + # ------------------------------------------------------------------ + # + # classvariable -- + # + # Link to a variable in the class of the current object. + # + # ------------------------------------------------------------------ - proc classvariable {name args} { - # Get a reference to the class's namespace - set ns [info object namespace [uplevel 1 {self class}]] - # Double up the list of variable names - foreach v [list $name {*}$args] { - if {[string match *(*) $v]} { - set reason "can't create a scalar variable that looks like an array element" - return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \ - [format {bad variable name "%s": %s} $v $reason] - } - if {[string match *::* $v]} { - set reason "can't create a local variable with a namespace separator in it" - return -code error -errorcode {TCL UPVAR INVERTED} \ - [format {bad variable name "%s": %s} $v $reason] - } - lappend vs $v $v + proc Helpers::classvariable {name args} { + # Get a reference to the class's namespace + set ns [info object namespace [uplevel 1 {self class}]] + # Double up the list of variable names + foreach v [list $name {*}$args] { + if {[string match *(*) $v]} { + set reason "can't create a scalar variable that looks like an array element" + return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \ + [format {bad variable name "%s": %s} $v $reason] + } + if {[string match *::* $v]} { + set reason "can't create a local variable with a namespace separator in it" + return -code error -errorcode {TCL UPVAR INVERTED} \ + [format {bad variable name "%s": %s} $v $reason] } - # Lastly, link the caller's local variables to the class's variables - tailcall namespace upvar $ns {*}$vs + lappend vs $v $v } + # Lastly, link the caller's local variables to the class's variables + tailcall namespace upvar $ns {*}$vs + } - # ------------------------------------------------------------------ - # - # link -- - # - # Make a command that invokes a method on the current object. - # The name of the command and the name of the method match by - # default. - # - # ------------------------------------------------------------------ + # ------------------------------------------------------------------ + # + # link -- + # + # Make a command that invokes a method on the current object. + # The name of the command and the name of the method match by + # default. + # + # ------------------------------------------------------------------ - proc link {args} { - set ns [uplevel 1 {::namespace current}] - foreach link $args { - if {[llength $link] == 2} { - lassign $link src dst - } elseif {[llength $link] == 1} { - lassign $link src - set dst $src - } else { - return -code error -errorcode {TCL OO CMDLINK_FORMAT} \ - "bad link description; must only have one or two elements" - } - if {![string match ::* $src]} { - set src [string cat $ns :: $src] - } - interp alias {} $src {} ${ns}::my $dst - trace add command ${ns}::my delete [list \ - ::oo::UnlinkLinkedCommand $src] + proc Helpers::link {args} { + set ns [uplevel 1 {::namespace current}] + foreach link $args { + if {[llength $link] == 2} { + lassign $link src dst + } elseif {[llength $link] == 1} { + lassign $link src + set dst $src + } else { + return -code error -errorcode {TCL OO CMDLINK_FORMAT} \ + "bad link description; must only have one or two elements" } - return + if {![string match ::* $src]} { + set src [string cat $ns :: $src] + } + interp alias {} $src {} ${ns}::my $dst + trace add command ${ns}::my delete [list \ + ::oo::UnlinkLinkedCommand $src] } } @@ -437,47 +432,45 @@ # # ---------------------------------------------------------------------- - namespace eval configuresupport { - # ------------------------------------------------------------------ - # - # oo::configuresupport::configurableclass, - # oo::configuresupport::configurableobject -- - # - # Namespaces used as implementation vectors for oo::define and - # oo::objdefine when the class/instance is configurable. - # Note that these also contain commands implemented in C, - # especially the [property] definition command. - # - # ------------------------------------------------------------------ + # ------------------------------------------------------------------ + # + # oo::configuresupport::configurableclass, + # oo::configuresupport::configurableobject -- + # + # Namespaces used as implementation vectors for oo::define and + # oo::objdefine when the class/instance is configurable. + # Note that these also contain commands implemented in C, + # especially the [property] definition command. + # + # ------------------------------------------------------------------ - ::namespace eval configurableclass { - # Plural alias just in case; deliberately NOT documented! - ::proc properties args {::tailcall property {*}$args} - ::namespace path ::oo::define - ::namespace export property - } + namespace eval configuresupport::configurableclass { + # Plural alias just in case; deliberately NOT documented! + ::proc properties args {::tailcall property {*}$args} + ::namespace path ::oo::define + ::namespace export property + } - ::namespace eval configurableobject { - # Plural alias just in case; deliberately NOT documented! - ::proc properties args {::tailcall property {*}$args} - ::namespace path ::oo::objdefine - ::namespace export property - } + namespace eval configuresupport::configurableobject { + # Plural alias just in case; deliberately NOT documented! + ::proc properties args {::tailcall property {*}$args} + ::namespace path ::oo::objdefine + ::namespace export property + } - # ------------------------------------------------------------------ - # - # oo::configuresupport::configurable -- - # - # The class that contains the implementation of the actual - # 'configure' method (mixed into actually configurable classes). - # The 'configure' method is in tclOOBasic.c. - # - # ------------------------------------------------------------------ + # ------------------------------------------------------------------ + # + # oo::configuresupport::configurable -- + # + # The class that contains the implementation of the actual + # 'configure' method (mixed into actually configurable classes). + # The 'configure' method is in tclOOBasic.c. + # + # ------------------------------------------------------------------ - ::oo::define configurable { - definitionnamespace -instance configurableobject - definitionnamespace -class configurableclass - } + define configuresupport::configurable { + definitionnamespace -instance configuresupport::configurableobject + definitionnamespace -class configuresupport::configurableclass } # ---------------------------------------------------------------------- -- cgit v0.12 From a93fc665255dad6ed3709382516517fa6984a89e Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 17:18:32 +0000 Subject: Speed up TclOO init; no directing via unknown method handler for slots of classes we define ourselves (backport) --- generic/tclOOScript.h | 8 ++++---- tools/tclOOScript.tcl | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 7b8a69d..a9b262c 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -210,8 +210,8 @@ static const char *tclOOSetupScript = "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" "\t}\n" "\tclass create singleton {\n" -"\t\tsuperclass class\n" -"\t\tvariable object\n" +"\t\tsuperclass -set class\n" +"\t\tvariable -set object\n" "\t\tunexport create createWithNamespace\n" "\t\tmethod new args {\n" "\t\t\tif {![info exists object] || ![info object isa object $object]} {\n" @@ -231,7 +231,7 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t}\n" "\tclass create abstract {\n" -"\t\tsuperclass class\n" +"\t\tsuperclass -set class\n" "\t\tunexport create createWithNamespace new\n" "\t}\n" "\tnamespace eval configuresupport::configurableclass {\n" @@ -249,7 +249,7 @@ static const char *tclOOSetupScript = "\t\tdefinitionnamespace -class configuresupport::configurableclass\n" "\t}\n" "\tclass create configurable {\n" -"\t\tsuperclass class\n" +"\t\tsuperclass -set class\n" "\t\tconstructor {{definitionScript \"\"}} {\n" "\t\t\tnext {mixin ::oo::configuresupport::configurable}\n" "\t\t\tnext $definitionScript\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 442756d..542b711 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -372,8 +372,8 @@ # ---------------------------------------------------------------------- class create singleton { - superclass class - variable object + superclass -set class + variable -set object unexport create createWithNamespace method new args { if {![info exists object] || ![info object isa object $object]} { @@ -403,7 +403,7 @@ # ---------------------------------------------------------------------- class create abstract { - superclass class + superclass -set class unexport create createWithNamespace new } @@ -486,7 +486,7 @@ # ---------------------------------------------------------------------- class create configurable { - superclass class + superclass -set class constructor {{definitionScript ""}} { next {mixin ::oo::configuresupport::configurable} -- cgit v0.12 From 1154dfa4f03f90bf76c0b9b82ed7667cd7ce2bf6 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 17:31:18 +0000 Subject: Rewrite slots in C to get a performance boost. (backport) --- generic/tclOO.c | 12 + generic/tclOODefineCmds.c | 609 ++++++++++++++++++++++++++++++++++++++++++++-- generic/tclOOInt.h | 4 + generic/tclOOScript.h | 55 ----- tools/tclOOScript.tcl | 94 +------ 5 files changed, 604 insertions(+), 170 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index a4c4da1..563832a 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -369,6 +369,10 @@ InitFoundation( 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"); + TclNewLiteralStringObj(fPtr->slotDefOpName, "--default-operation"); Tcl_IncrRefCount(fPtr->unknownMethodNameObj); Tcl_IncrRefCount(fPtr->constructorName); Tcl_IncrRefCount(fPtr->destructorName); @@ -376,6 +380,10 @@ InitFoundation( Tcl_IncrRefCount(fPtr->defineName); Tcl_IncrRefCount(fPtr->myName); Tcl_IncrRefCount(fPtr->mcdName); + Tcl_IncrRefCount(fPtr->slotGetName); + Tcl_IncrRefCount(fPtr->slotSetName); + Tcl_IncrRefCount(fPtr->slotResolveName); + Tcl_IncrRefCount(fPtr->slotDefOpName); TclCreateObjCommandInNs(interp, "UnknownDefinition", fPtr->ooNs, TclOOUnknownDefinition, NULL, NULL); @@ -619,6 +627,10 @@ KillFoundation( TclDecrRefCount(fPtr->defineName); TclDecrRefCount(fPtr->myName); TclDecrRefCount(fPtr->mcdName); + TclDecrRefCount(fPtr->slotGetName); + TclDecrRefCount(fPtr->slotSetName); + TclDecrRefCount(fPtr->slotResolveName); + TclDecrRefCount(fPtr->slotDefOpName); TclOODecrRefCount(fPtr->objectCls->thisPtr); TclOODecrRefCount(fPtr->classCls->thisPtr); diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 5b6de0e..d9a637a 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -39,15 +39,25 @@ typedef struct DeclaredSlot { const Tcl_MethodType resolverType; } DeclaredSlot; -#define SLOT(name,getter,setter,resolver) \ +#define SLOT(name,getter,setter,resolver) \ {"::oo::" name, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ + {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter", \ getter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ + {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter", \ setter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \ + {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver", \ resolver, NULL, NULL}} +typedef struct DeclaredSlotMethod { + const char *name; + int flags; + const Tcl_MethodType implType; +} DeclaredSlotMethod; + +#define SLOT_METHOD(name,impl,flags) \ + {name, flags, {TCL_OO_METHOD_VERSION_1, \ + "core method: " name " slot", impl, NULL, NULL}} + /* * A [string match] pattern used to determine if a method should be exported. */ @@ -78,6 +88,33 @@ static inline void RecomputeClassCacheFlag(Object *oPtr); static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, int useClass, Tcl_Obj *const fromPtr, Tcl_Obj *const toPtr); +static int Slot_Append(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_AppendNew(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Clear(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Prepend(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Remove(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Resolve(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Set(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Unimplemented(void *, + Tcl_Interp *interp, Tcl_ObjectContext, + int, Tcl_Obj *const *); +static int Slot_Unknown(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); static int ClassFilter_Get(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -175,6 +212,20 @@ static const DeclaredSlot slots[] = { {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; +static const DeclaredSlotMethod slotMethods[] = { + SLOT_METHOD("Get", Slot_Unimplemented, 0), + SLOT_METHOD("Resolve", Slot_Resolve, 0), + SLOT_METHOD("Set", Slot_Unimplemented, 0), + SLOT_METHOD("-append", Slot_Append, PUBLIC_METHOD), + SLOT_METHOD("-appendifnew", Slot_AppendNew, PUBLIC_METHOD), + SLOT_METHOD("-clear", Slot_Clear, PUBLIC_METHOD), + SLOT_METHOD("-prepend", Slot_Prepend, PUBLIC_METHOD), + SLOT_METHOD("-remove", Slot_Remove, PUBLIC_METHOD), + SLOT_METHOD("-set", Slot_Set, PUBLIC_METHOD), + SLOT_METHOD("unknown", Slot_Unknown, 0), + {NULL, 0, {0, 0, 0, 0, 0}} +}; + /* * How to build the in-namespace name of a private variable. This is a pattern * used with Tcl_ObjPrintf(). @@ -2397,50 +2448,560 @@ int TclOODefineSlots( Foundation *fPtr) { - const DeclaredSlot *slotInfoPtr; Tcl_Interp *interp = fPtr->interp; - Tcl_Obj *getName, *setName, *resolveName; Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0); - Class *slotCls; + Tcl_Class slotCls; + const DeclaredSlotMethod *smPtr; + const DeclaredSlot *slotPtr; if (object == NULL) { return TCL_ERROR; } - slotCls = ((Object *) object)->classPtr; + slotCls = (Tcl_Class) ((Object *) object)->classPtr; if (slotCls == NULL) { return TCL_ERROR; } - TclNewLiteralStringObj(getName, "Get"); - TclNewLiteralStringObj(setName, "Set"); - TclNewLiteralStringObj(resolveName, "Resolve"); - for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { + for (smPtr = slotMethods; smPtr->name; smPtr++) { + Tcl_Obj *name = Tcl_NewStringObj(smPtr->name, -1); + Tcl_NewMethod(interp, slotCls, name, smPtr->flags, + &smPtr->implType, NULL); + Tcl_BounceRefCount(name); + } + + for (slotPtr = slots ; slotPtr->name ; slotPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE, - NULL, 0); + slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0); if (slotObject == NULL) { continue; } - TclNewInstanceMethod(interp, slotObject, getName, 0, - &slotInfoPtr->getterType, NULL); - TclNewInstanceMethod(interp, slotObject, setName, 0, - &slotInfoPtr->setterType, NULL); - if (slotInfoPtr->resolverType.callProc) { - TclNewInstanceMethod(interp, slotObject, resolveName, 0, - &slotInfoPtr->resolverType, NULL); + TclNewInstanceMethod(interp, slotObject, fPtr->slotGetName, 0, + &slotPtr->getterType, NULL); + TclNewInstanceMethod(interp, slotObject, fPtr->slotSetName, 0, + &slotPtr->setterType, NULL); + if (slotPtr->resolverType.callProc) { + TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0, + &slotPtr->resolverType, NULL); + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * CallSlotGet, CallSlotSet, CallSlotResolve, ResolveAll -- + * + * How to call the standard low-level methods of a slot. + * ResolveAll is the lifting of CallSlotResolve to work over a whole + * list of items. + * + * ---------------------------------------------------------------------- + */ + +// Call [$slot Get] to retrieve the list of contents of the slot +static inline Tcl_Obj * +CallSlotGet( + Tcl_Interp *interp, + Object *slot) +{ + Tcl_Obj *getArgs[2]; + int code; + + getArgs[0] = slot->fPtr->myName; + getArgs[1] = slot->fPtr->slotGetName; + code = TclOOPrivateObjectCmd(slot, interp, 2, getArgs); + if (code != TCL_OK) { + return NULL; + } + return Tcl_GetObjResult(interp); +} + +// Call [$slot Set $list] to set the list of contents of the slot +static inline int +CallSlotSet( + Tcl_Interp *interp, + Object *slot, + Tcl_Obj *list) +{ + Tcl_Obj *setArgs[3]; + setArgs[0] = slot->fPtr->myName; + setArgs[1] = slot->fPtr->slotSetName; + setArgs[2] = list; + return TclOOPrivateObjectCmd(slot, interp, 3, setArgs); +} + +// Call [$slot Resolve $item] to convert a slot item into canonical form +static inline Tcl_Obj * +CallSlotResolve( + Tcl_Interp *interp, + Object *slot, + Tcl_Obj *item) +{ + Tcl_Obj *resolveArgs[3]; + int code; + + resolveArgs[0] = slot->fPtr->myName; + resolveArgs[1] = slot->fPtr->slotResolveName; + resolveArgs[2] = item; + code = TclOOPrivateObjectCmd(slot, interp, 3, resolveArgs); + if (code != TCL_OK) { + return NULL; + } + return Tcl_GetObjResult(interp); +} + +static inline Tcl_Obj * +ResolveAll( + Tcl_Interp *interp, + Object *slot, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp, + sizeof(Tcl_Obj *) * objc); + Tcl_Obj *resolvedList; + int i; + + for (i = 0; i < objc; i++) { + resolvedItems[i] = CallSlotResolve(interp, slot, objv[i]); + if (resolvedItems[i] == NULL) { + for (int j = 0; j < i; j++) { + Tcl_DecrRefCount(resolvedItems[j]); + } + TclStackFree(interp, (void *) resolvedItems); + return NULL; + } + Tcl_IncrRefCount(resolvedItems[i]); + Tcl_ResetResult(interp); + } + resolvedList = Tcl_NewListObj(objc, resolvedItems); + for (i = 0; i < objc; i++) { + TclDecrRefCount(resolvedItems[i]); + } + TclStackFree(interp, (void *) resolvedItems); + return resolvedList; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_Append -- + * + * Implementation of the "-append" slot operation. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_Append( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context), code; + Tcl_Obj *resolved, *list; + + if (skip == objc) { + return TCL_OK; + } + + // Resolve all values + resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (resolved == NULL) { + return TCL_ERROR; + } + + // Get slot contents; store in list + list = CallSlotGet(interp, oPtr); + if (list == NULL) { + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_IncrRefCount(list); + Tcl_ResetResult(interp); + + // Append + if (Tcl_IsShared(list)) { + Tcl_Obj *dup = Tcl_DuplicateObj(list); + Tcl_IncrRefCount(dup); + Tcl_DecrRefCount(list); + list = dup; + } + if (Tcl_ListObjAppendList(interp, list, resolved) != TCL_OK) { + Tcl_DecrRefCount(list); + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_DecrRefCount(resolved); + + // Set slot contents + code = CallSlotSet(interp, oPtr, list); + Tcl_DecrRefCount(list); + return code; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_AppendNew -- + * + * Implementation of the "-appendifnew" slot operation. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_AppendNew( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context), code; + Tcl_Obj *resolved, *list, **listv; + Tcl_Size listc, i; + Tcl_HashTable unique; + + if (skip == objc) { + return TCL_OK; + } + + // Resolve all values + resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (resolved == NULL) { + return TCL_ERROR; + } + + // Get slot contents; store in list + list = CallSlotGet(interp, oPtr); + if (list == NULL) { + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_IncrRefCount(list); + Tcl_ResetResult(interp); + + // Prepare a set of items in the list to set + if (TclListObjGetElements(interp, list, &listc, &listv) != TCL_OK) { + Tcl_DecrRefCount(list); + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_InitObjHashTable(&unique); + for (i=0 ; i= objc) { + Tcl_Obj *args[2]; + args[0] = oPtr->fPtr->myName; + args[1] = oPtr->fPtr->slotDefOpName; + return TclOOPrivateObjectCmd(oPtr, interp, 2, args); + } else if (TclGetString(objv[skip])[0] != '-') { + Tcl_Obj **args = (Tcl_Obj **) TclStackAlloc(interp, + sizeof(Tcl_Obj *) * (objc - skip + 2)); + args[0] = oPtr->fPtr->myName; + args[1] = oPtr->fPtr->slotDefOpName; + memcpy(args+2, objv+skip, sizeof(Tcl_Obj*) * (objc - skip)); + code = TclOOPrivateObjectCmd(oPtr, interp, objc - skip + 2, args); + TclStackFree(interp, args); + return code; + } + return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip); +} + +/* + * ---------------------------------------------------------------------- + * * ClassFilter_Get, ClassFilter_Set -- * * Implementation of the "filter" slot accessors of the "oo::define" diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 59a0cb6..bd11638 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -407,6 +407,10 @@ struct Foundation { 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. */ + Tcl_Obj *slotDefOpName; /* The "--default-operation" name used by slots. */ }; /* diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index a9b262c..80c4c68 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -117,62 +117,7 @@ static const char *tclOOSetupScript = "\t\t::tailcall forward $name myclass $name\n" "\t}\n" "\tdefine Slot {\n" -"\t\tmethod Get -unexport {} {\n" -"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n" -"\t\t}\n" -"\t\tmethod Set -unexport list {\n" -"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n" -"\t\t}\n" -"\t\tmethod Resolve -unexport list {\n" -"\t\t\treturn $list\n" -"\t\t}\n" -"\t\tmethod -set -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\ttailcall my Set $args\n" -"\t\t}\n" -"\t\tmethod -append -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [list {*}$current {*}$args]\n" -"\t\t}\n" -"\t\tmethod -appendifnew -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\tforeach a $args {\n" -"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n" -"\t\t\t\tif {$a ni $current} {\n" -"\t\t\t\t\tlappend current $a\n" -"\t\t\t\t}\n" -"\t\t\t}\n" -"\t\t\ttailcall my Set $current\n" -"\t\t}\n" -"\t\tmethod -clear -export {} {tailcall my Set {}}\n" -"\t\tmethod -prepend -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [list {*}$args {*}$current]\n" -"\t\t}\n" -"\t\tmethod -remove -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [lmap val $current {\n" -"\t\t\t\tif {$val in $args} continue else {set val}\n" -"\t\t\t}]\n" -"\t\t}\n" "\t\tforward --default-operation my -append\n" -"\t\tmethod unknown -unexport {args} {\n" -"\t\t\tset def --default-operation\n" -"\t\t\tif {[llength $args] == 0} {\n" -"\t\t\t\ttailcall my $def\n" -"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n" -"\t\t\t\ttailcall my $def {*}$args\n" -"\t\t\t}\n" -"\t\t\tnext {*}$args\n" -"\t\t}\n" "\t\tunexport destroy\n" "\t}\n" "\tobjdefine define::superclass forward --default-operation my -set\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 542b711..e829fcf 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -198,103 +198,15 @@ define Slot { # ------------------------------------------------------------------ # - # Slot Get -- + # Slot --default-operation -- # - # Basic slot getter. Retrieves the contents of the slot. - # Particular slots must provide concrete non-erroring - # implementation. + # If a slot can't figure out what method to call directly, it + # uses --default-operation. # # ------------------------------------------------------------------ - method Get -unexport {} { - return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented" - } - - # ------------------------------------------------------------------ - # - # Slot Set -- - # - # Basic slot setter. Sets the contents of the slot. Particular - # slots must provide concrete non-erroring implementation. - # - # ------------------------------------------------------------------ - - method Set -unexport list { - return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented" - } - - # ------------------------------------------------------------------ - # - # Slot Resolve -- - # - # Helper that lets a slot convert a list of arguments of a - # particular type to their canonical forms. Defaults to doing - # nothing (suitable for simple strings). - # - # ------------------------------------------------------------------ - - method Resolve -unexport list { - return $list - } - - # ------------------------------------------------------------------ - # - # Slot -set, -append, -clear, --default-operation -- - # - # Standard public slot operations. If a slot can't figure out - # what method to call directly, it uses --default-operation. - # - # ------------------------------------------------------------------ - - method -set -export args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - tailcall my Set $args - } - method -append -export args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - set current [uplevel 1 [list $my Get]] - tailcall my Set [list {*}$current {*}$args] - } - method -appendifnew -export args { - set my [namespace which my] - set current [uplevel 1 [list $my Get]] - foreach a $args { - set a [uplevel 1 [list $my Resolve $a]] - if {$a ni $current} { - lappend current $a - } - } - tailcall my Set $current - } - method -clear -export {} {tailcall my Set {}} - method -prepend -export args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - set current [uplevel 1 [list $my Get]] - tailcall my Set [list {*}$args {*}$current] - } - method -remove -export args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - set current [uplevel 1 [list $my Get]] - tailcall my Set [lmap val $current { - if {$val in $args} continue else {set val} - }] - } - # Default handling forward --default-operation my -append - method unknown -unexport {args} { - set def --default-operation - if {[llength $args] == 0} { - tailcall my $def - } elseif {![string match -* [lindex $args 0]]} { - tailcall my $def {*}$args - } - next {*}$args - } # Hide destroy unexport destroy -- cgit v0.12 From cd0fea576340809a36adce9bc95749dbd0587123 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 17:31:50 +0000 Subject: Slightly faster way to write the init script (backport) --- generic/tclOOScript.h | 59 +++++++++++++++++------------------- tools/tclOOScript.tcl | 84 +++++++++++++++++++++++---------------------------- 2 files changed, 65 insertions(+), 78 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 80c4c68..6b0c5bd 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -116,10 +116,8 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t\t::tailcall forward $name myclass $name\n" "\t}\n" -"\tdefine Slot {\n" -"\t\tforward --default-operation my -append\n" -"\t\tunexport destroy\n" -"\t}\n" +"\tdefine Slot forward --default-operation my -append\n" +"\tdefine Slot unexport destroy\n" "\tobjdefine define::superclass forward --default-operation my -set\n" "\tobjdefine define::mixin forward --default-operation my -set\n" "\tobjdefine objdefine::mixin forward --default-operation my -set\n" @@ -154,31 +152,29 @@ static const char *tclOOSetupScript = "\t\tnext $originObject\n" "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" "\t}\n" -"\tclass create singleton {\n" -"\t\tsuperclass -set class\n" -"\t\tvariable -set object\n" -"\t\tunexport create createWithNamespace\n" -"\t\tmethod new args {\n" -"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n" -"\t\t\t\tset object [next {*}$args]\n" -"\t\t\t\t::oo::objdefine $object {\n" -"\t\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" -"\t\t\t\t\t}\n" -"\t\t\t\t\tmethod -unexport {originObject} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" -"\t\t\t\t\t}\n" +"\tclass create singleton\n" +"\tdefine singleton superclass -set class\n" +"\tdefine singleton variable -set object\n" +"\tdefine singleton unexport create createWithNamespace\n" +"\tdefine singleton method new args {\n" +"\t\tif {![info exists object] || ![info object isa object $object]} {\n" +"\t\t\tset object [next {*}$args]\n" +"\t\t\t::oo::objdefine $object {\n" +"\t\t\t\tmethod destroy {} {\n" +"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\t\t\t\"may not destroy a singleton object\"\n" +"\t\t\t\t}\n" +"\t\t\t\tmethod -unexport {originObject} {\n" +"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\t\t\t\"may not clone a singleton object\"\n" "\t\t\t\t}\n" "\t\t\t}\n" -"\t\t\treturn $object\n" "\t\t}\n" +"\t\treturn $object\n" "\t}\n" -"\tclass create abstract {\n" -"\t\tsuperclass -set class\n" -"\t\tunexport create createWithNamespace new\n" -"\t}\n" +"\tclass create abstract\n" +"\tdefine abstract superclass -set class\n" +"\tdefine abstract unexport create createWithNamespace new\n" "\tnamespace eval configuresupport::configurableclass {\n" "\t\t::proc properties args {::tailcall property {*}$args}\n" "\t\t::namespace path ::oo::define\n" @@ -193,14 +189,13 @@ static const char *tclOOSetupScript = "\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" "\t\tdefinitionnamespace -class configuresupport::configurableclass\n" "\t}\n" -"\tclass create configurable {\n" -"\t\tsuperclass -set class\n" -"\t\tconstructor {{definitionScript \"\"}} {\n" -"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n" -"\t\t\tnext $definitionScript\n" -"\t\t}\n" -"\t\tdefinitionnamespace -class configuresupport::configurableclass\n" +"\tclass create configurable\n" +"\tdefine configurable superclass -set class\n" +"\tdefine configurable constructor {{definitionScript \"\"}} {\n" +"\t\tnext {mixin ::oo::configuresupport::configurable}\n" +"\t\tnext $definitionScript\n" "\t}\n" +"\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n" "}\n" /* !END!: Do not edit above this line. */ ; diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index e829fcf..2b9e2a4 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -195,22 +195,18 @@ # # ---------------------------------------------------------------------- - define Slot { - # ------------------------------------------------------------------ - # - # Slot --default-operation -- - # - # If a slot can't figure out what method to call directly, it - # uses --default-operation. - # - # ------------------------------------------------------------------ - - # Default handling - forward --default-operation my -append - - # Hide destroy - unexport destroy - } + # ------------------------------------------------------------------ + # + # Slot --default-operation -- + # + # If a slot can't figure out what method to call directly, it + # uses --default-operation. + # + # ------------------------------------------------------------------ + define Slot forward --default-operation my -append + + # Hide destroy + define Slot unexport destroy # Set the default operation differently for these slots objdefine define::superclass forward --default-operation my -set @@ -283,26 +279,25 @@ # # ---------------------------------------------------------------------- - class create singleton { - superclass -set class - variable -set object - unexport create createWithNamespace - method new args { - if {![info exists object] || ![info object isa object $object]} { - set object [next {*}$args] - ::oo::objdefine $object { - method destroy {} { - ::return -code error -errorcode {TCL OO SINGLETON} \ - "may not destroy a singleton object" - } - method -unexport {originObject} { - ::return -code error -errorcode {TCL OO SINGLETON} \ - "may not clone a singleton object" - } + class create singleton + define singleton superclass -set class + define singleton variable -set object + define singleton unexport create createWithNamespace + define singleton method new args { + if {![info exists object] || ![info object isa object $object]} { + set object [next {*}$args] + ::oo::objdefine $object { + method destroy {} { + ::return -code error -errorcode {TCL OO SINGLETON} \ + "may not destroy a singleton object" + } + method -unexport {originObject} { + ::return -code error -errorcode {TCL OO SINGLETON} \ + "may not clone a singleton object" } } - return $object } + return $object } # ---------------------------------------------------------------------- @@ -314,10 +309,9 @@ # # ---------------------------------------------------------------------- - class create abstract { - superclass -set class - unexport create createWithNamespace new - } + class create abstract + define abstract superclass -set class + define abstract unexport create createWithNamespace new # ---------------------------------------------------------------------- # @@ -397,16 +391,14 @@ # # ---------------------------------------------------------------------- - class create configurable { - superclass -set class - - constructor {{definitionScript ""}} { - next {mixin ::oo::configuresupport::configurable} - next $definitionScript - } - - definitionnamespace -class configuresupport::configurableclass + class create configurable + define configurable superclass -set class + define configurable constructor {{definitionScript ""}} { + next {mixin ::oo::configuresupport::configurable} + next $definitionScript } + + define configurable definitionnamespace -class configuresupport::configurableclass } # Local Variables: -- cgit v0.12 From 8bced55797a51e000c81d99fe17d2679991f0d59 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 17:35:43 +0000 Subject: Move another command into C: classvariable (backport) --- generic/tclOO.c | 2 ++ generic/tclOOBasic.c | 96 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOInt.h | 1 + generic/tclOOScript.h | 17 --------- tools/tclOOScript.tcl | 29 ---------------- 5 files changed, 99 insertions(+), 46 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 563832a..d9144fd 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -442,6 +442,8 @@ InitFoundation( TclOOCallbackObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->helpersNs, "mymethod", TclOOCallbackObjCmd, NULL, NULL, 0); + CreateCmdInNS(interp, fPtr->helpersNs, "classvariable", + TclOOClassVariableObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->helpersNs, "next", NULL, TclOONextObjCmd, TclCompileObjectNextCmd); CreateCmdInNS(interp, fPtr->helpersNs, "nextto", diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 092bc0d..342fa9e 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1432,6 +1432,102 @@ TclOOCallbackObjCmd( } /* + * ---------------------------------------------------------------------- + * + * TclOOClassVariableObjCmd -- + * + * Implementation of the [classvariable] command, which links to + * variables in the class of the current object. + * + * ---------------------------------------------------------------------- + */ +int +TclOOClassVariableObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + CallContext *contextPtr; + Class *clsPtr; + Tcl_Namespace *clsNsPtr, *ourNsPtr; + Var *arrayPtr, *otherPtr; + int i; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ..."); + return TCL_ERROR; + } + + /* + * Start with sanity checks on the calling context to make sure that we + * are invoked from a suitable method context. If so, we can safely + * retrieve the handle to the object call context. + */ + + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); + OO_ERROR(interp, CONTEXT_REQUIRED); + return TCL_ERROR; + } + + // Get a reference to the class's namespace + contextPtr = (CallContext *) framePtr->clientData; + clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; + if (clsPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method not defined by a class", TCL_AUTO_LENGTH)); + OO_ERROR(interp, UNMATCHED_CONTEXT); + return TCL_ERROR; + } + clsNsPtr = clsPtr->thisPtr->namespacePtr; + + // Check the list of variable names + for (i = 1; i < objc; i++) { + const char *varName = TclGetString(objv[i]); + if (Tcl_StringMatch(varName, "*(*)")) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad variable name \"%s\": can't create a %s", + varName, "scalar variable that looks like an array element")); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); + return TCL_ERROR; + } + if (Tcl_StringMatch(varName, "*::*")) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad variable name \"%s\": can't create a %s", + varName, "local variable with a namespace separator in it")); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); + return TCL_ERROR; + } + } + + // Lastly, link the caller's local variables to the class's variables + ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + for (i = 1; i < objc; i++) { + // Locate the other variable. + iPtr->varFramePtr->nsPtr = (Namespace *) clsNsPtr; + otherPtr = TclObjLookupVarEx(interp, objv[i], NULL, + (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), + "access", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); + iPtr->varFramePtr->nsPtr = (Namespace *) ourNsPtr; + if (otherPtr == NULL) { + return TCL_ERROR; + } + + // Create the new variable and link it to otherPtr. + if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, -1) != TCL_OK) { + return TCL_ERROR; + } + } + + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index bd11638..abb26b8 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -519,6 +519,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePropertyCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition; MODULE_SCOPE Tcl_ObjCmdProc TclOOCallbackObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOClassVariableObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd; diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 6b0c5bd..dcc44c0 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,23 +27,6 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\tproc Helpers::classvariable {name args} {\n" -"\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" -"\t\tforeach v [list $name {*}$args] {\n" -"\t\t\tif {[string match *(*) $v]} {\n" -"\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" -"\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" -"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t}\n" -"\t\t\tif {[string match *::* $v]} {\n" -"\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" -"\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" -"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t}\n" -"\t\t\tlappend vs $v $v\n" -"\t\t}\n" -"\t\ttailcall namespace upvar $ns {*}$vs\n" -"\t}\n" "\tproc Helpers::link {args} {\n" "\t\tset ns [uplevel 1 {::namespace current}]\n" "\t\tforeach link $args {\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 2b9e2a4..3f34c56 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -19,35 +19,6 @@ # ------------------------------------------------------------------ # - # classvariable -- - # - # Link to a variable in the class of the current object. - # - # ------------------------------------------------------------------ - - proc Helpers::classvariable {name args} { - # Get a reference to the class's namespace - set ns [info object namespace [uplevel 1 {self class}]] - # Double up the list of variable names - foreach v [list $name {*}$args] { - if {[string match *(*) $v]} { - set reason "can't create a scalar variable that looks like an array element" - return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \ - [format {bad variable name "%s": %s} $v $reason] - } - if {[string match *::* $v]} { - set reason "can't create a local variable with a namespace separator in it" - return -code error -errorcode {TCL UPVAR INVERTED} \ - [format {bad variable name "%s": %s} $v $reason] - } - lappend vs $v $v - } - # Lastly, link the caller's local variables to the class's variables - tailcall namespace upvar $ns {*}$vs - } - - # ------------------------------------------------------------------ - # # link -- # # Make a command that invokes a method on the current object. -- cgit v0.12 From 61e2cc66b9aa6f9aa0cb06dd99a5cdb118999c58 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 17:36:48 +0000 Subject: Move a bit of internal machinery (backport) --- generic/tclOO.c | 1 + generic/tclOOBasic.c | 37 ++++++++++++++++++++++++++++++++++++- generic/tclOOInt.h | 1 + generic/tclOOScript.h | 3 --- tools/tclOOScript.tcl | 14 -------------- 5 files changed, 38 insertions(+), 18 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index d9144fd..ced2cb1 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -454,6 +454,7 @@ InitFoundation( CreateCmdInNS(interp, fPtr->ooNs, "define", TclOODefineObjCmd, NULL, NULL); CreateCmdInNS(interp, fPtr->ooNs, "objdefine", TclOOObjDefObjCmd, NULL, NULL); CreateCmdInNS(interp, fPtr->ooNs, "copy", TclOOCopyObjectCmd, NULL, NULL); + CreateCmdInNS(interp, fPtr->ooNs, "DelegateName", TclOODelegateNameObjCmd, NULL, NULL, 0); TclOOInitInfo(interp); diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 342fa9e..4d34a9c 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1519,7 +1519,8 @@ TclOOClassVariableObjCmd( } // Create the new variable and link it to otherPtr. - if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, -1) != TCL_OK) { + if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, + TCL_INDEX_NONE) != TCL_OK) { return TCL_ERROR; } } @@ -1528,6 +1529,40 @@ TclOOClassVariableObjCmd( } /* + * ---------------------------------------------------------------------- + * + * TclOODelegateNameObjCmd -- + * + * Implementation of the [oo::DelegateName] command, which is a utility + * that gets the name of the class delegate for a class. It's trivial, + * but makes working with them much easier as delegate names are + * intentionally hard to create by accident. + * + * Not part of TclOO public API. No public documentation. + * + * ---------------------------------------------------------------------- + */ +int +TclOODelegateNameObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "class"); + return TCL_ERROR; + } + Class *clsPtr = TclOOGetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s:: oo ::delegate", + clsPtr->thisPtr->namespacePtr->fullName)); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index abb26b8..d5dc36c 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -521,6 +521,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition; MODULE_SCOPE Tcl_ObjCmdProc TclOOCallbackObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOClassVariableObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODelegateNameObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd; diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index dcc44c0..643e536 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -52,9 +52,6 @@ static const char *tclOOSetupScript = "\t\t\trename $cmd {}\n" "\t\t}\n" "\t}\n" -"\tproc DelegateName {class} {\n" -"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n" -"\t}\n" "\tproc MixinClassDelegates {class} {\n" "\t\tif {![info object isa class $class]} {\n" "\t\t\treturn\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 3f34c56..2cf40e1 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -65,20 +65,6 @@ # ---------------------------------------------------------------------- # - # DelegateName -- - # - # Utility that gets the name of the class delegate for a class. It's - # trivial, but makes working with them much easier as delegate names are - # intentionally hard to create by accident. - # - # ---------------------------------------------------------------------- - - proc DelegateName {class} { - string cat [info object namespace $class] {:: oo ::delegate} - } - - # ---------------------------------------------------------------------- - # # MixinClassDelegates -- # # Support code called *after* [oo::define] inside the constructor of a -- cgit v0.12 From 0a21b6eed51f2f8acc6fcfd64559626b6c97b6d9 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 19:14:27 +0000 Subject: Convert MixinClassDelegates to an internal function entirely in C (backport) --- generic/tclOO.c | 3 - generic/tclOOBasic.c | 165 +++++++++++++++++++++++++++++++++++++++++++------- generic/tclOOInt.h | 2 - generic/tclOOScript.h | 17 ------ tools/tclOOScript.tcl | 27 --------- 5 files changed, 142 insertions(+), 72 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index ced2cb1..e77934c 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -368,7 +368,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"); @@ -379,7 +378,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); @@ -629,7 +627,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 4d34a9c..8655e16 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,126 @@ 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) +{ + Class **mixins; + int i; + + if (clsPtr->thisPtr->mixins.num == 0) { + TclOOObjectSetMixins(clsPtr->thisPtr, 1, &delegatePtr); + return; + } + mixins = (Class **) TclStackAlloc(interp, + sizeof(Class *) * (clsPtr->thisPtr->mixins.num + 1)); + for (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, *delegatePtr; + if (clsPtr) { + delegatePtr = TclOOGetClassFromObj(interp, delegateName); + if (delegatePtr) { + SetDelegateSuperclasses(interp, clsPtr, delegatePtr); + InstallDelegateAsMixin(interp, clsPtr, delegatePtr); + } + } +} + +/* + * ---------------------------------------------------------------------- + * * TclOO_Class_Constructor -- * * Implementation for oo::class constructor. @@ -84,9 +204,9 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj **invoke, *nameObj; - size_t skip = Tcl_ObjectContextSkippedArgs(context); + Tcl_Obj **invoke, *delegateName; + if ((size_t) objc > skip + 1) { Tcl_WrongNumArgs(interp, skip, objv, "?definitionScript?"); @@ -101,18 +221,21 @@ TclOO_Class_Constructor( * argument to [oo::define]. [Bug 680503] */ - nameObj = Tcl_ObjPrintf("%s:: oo ::delegate", + 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); } /* @@ -132,8 +255,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 +266,29 @@ 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_Obj *delegateName = (Tcl_Obj *) data[2]; Tcl_InterpState saved; - int code; 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; - } + + 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 d5dc36c..4383b91 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 From 10b1362daa6a99d02ce1f417bb2643f1fc6fa89d Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 19:22:05 +0000 Subject: Move [link] into C. (backport) --- generic/tclInt.h | 4 ++ generic/tclInterp.c | 20 ++++----- generic/tclOO.c | 14 +++++++ generic/tclOOBasic.c | 110 ++++++++++++++++++++++++++++++++++++++++++++++---- generic/tclOOInt.h | 2 + generic/tclOOScript.h | 25 ------------ tools/tclOOScript.tcl | 51 ----------------------- 7 files changed, 131 insertions(+), 95 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index c227b0c..c450c80 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3318,6 +3318,10 @@ MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next, int loc); MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start, const char *end); +MODULE_SCOPE int TclAliasCreate(Tcl_Interp *interp, + Tcl_Interp *childInterp, Tcl_Interp *parentInterp, + Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc, + Tcl_Obj *const objv[]); MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size len); MODULE_SCOPE void TclAppendUtfToUtf(Tcl_Obj *objPtr, diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 90af06e..5e54749 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -221,10 +221,6 @@ enum LimitHandlerFlags { * Prototypes for local static functions: */ -static int AliasCreate(Tcl_Interp *interp, - Tcl_Interp *childInterp, Tcl_Interp *parentInterp, - Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc, - Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, Tcl_Interp *childInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, @@ -701,7 +697,7 @@ NRInterpCmd( return TCL_ERROR; } - return AliasCreate(interp, childInterp, parentInterp, objv[3], + return TclAliasCreate(interp, childInterp, parentInterp, objv[3], objv[5], objc - 6, objv + 6); } @@ -1232,7 +1228,7 @@ Tcl_CreateAlias( targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, + result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, argc, objv); for (i = 0; i < argc; i++) { @@ -1279,7 +1275,7 @@ Tcl_CreateAliasObj( targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, + result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, objc, objv); Tcl_DecrRefCount(childObjPtr); @@ -1452,7 +1448,7 @@ TclPreventAliasLoop( /* *---------------------------------------------------------------------- * - * AliasCreate -- + * TclAliasCreate -- * * Helper function to do the work to actually create an alias. * @@ -1466,8 +1462,8 @@ TclPreventAliasLoop( *---------------------------------------------------------------------- */ -static int -AliasCreate( +int +TclAliasCreate( Tcl_Interp *interp, /* Interp for error reporting. */ Tcl_Interp *childInterp, /* Interp where alias cmd will live or from * which alias will be deleted. */ @@ -2468,7 +2464,7 @@ ChildCreate( TclNewLiteralStringObj(clockObj, "clock"); Tcl_IncrRefCount(clockObj); - status = AliasCreate(interp, childInterp, parentInterp, clockObj, + status = TclAliasCreate(interp, childInterp, parentInterp, clockObj, clockObj, 0, NULL); Tcl_DecrRefCount(clockObj); if (status != TCL_OK) { @@ -2558,7 +2554,7 @@ NRChildCmd( return AliasDelete(interp, childInterp, objv[2]); } } else { - return AliasCreate(interp, childInterp, interp, objv[2], + return TclAliasCreate(interp, childInterp, interp, objv[2], objv[3], objc - 4, objv + 4); } } diff --git a/generic/tclOO.c b/generic/tclOO.c index e77934c..0f400e7 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -442,6 +442,8 @@ InitFoundation( TclOOCallbackObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->helpersNs, "classvariable", TclOOClassVariableObjCmd, NULL, NULL, 0); + CreateCmdInNS(interp, fPtr->helpersNs, "link", + TclOOLinkObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->helpersNs, "next", NULL, TclOONextObjCmd, TclCompileObjectNextCmd); CreateCmdInNS(interp, fPtr->helpersNs, "nextto", @@ -814,6 +816,7 @@ AllocObject( oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, MyClassDeleted); + oPtr->linkedCmdsList = NULL; return oPtr; } @@ -857,7 +860,18 @@ MyDeleted( * squelched. */ { Object *oPtr = (Object *) clientData; + Tcl_Size linkc, i; + Tcl_Obj **linkv, *link; + if (oPtr->linkedCmdsList) { + TclListObjGetElements(NULL, oPtr->linkedCmdsList, &linkc, &linkv); + for (i=0 ; ifPtr->interp, TclGetString(link)); + } + Tcl_DecrRefCount(oPtr->linkedCmdsList); + oPtr->linkedCmdsList = NULL; + } oPtr->myCommand = NULL; } diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 8655e16..740e2cb 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1023,6 +1023,102 @@ TclOO_Object_VarName( /* * ---------------------------------------------------------------------- * + * TclOOLinkObjCmd -- + * + * Implementation of the [link] command, that makes a command that + * invokes a method on the current object. The name of the command and + * the name of the method match by default. Note that this command is + * only ever to be used inside the body of a procedure-like method, + * and is typically intended for constructors. + * + * ---------------------------------------------------------------------- + */ +int +TclOOLinkObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + /* Set up common bits. */ + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; + CallContext *context; + Object *oPtr; + Tcl_Obj *myCmd, **linkv, *src, *dst; + Tcl_Size linkc; + const char *srcStr; + int i; + + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); + OO_ERROR(interp, CONTEXT_REQUIRED); + return TCL_ERROR; + } + context = (CallContext *) framePtr->clientData; + oPtr = context->oPtr; + if (!oPtr->myCommand) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot link to non-existent callback handle")); + OO_ERROR(interp, MY_GONE); + return TCL_ERROR; + } + myCmd = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, oPtr->myCommand, myCmd); + if (!oPtr->linkedCmdsList) { + oPtr->linkedCmdsList = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(oPtr->linkedCmdsList); + } + + /* For each argument */ + for (i=1; ioPtr->namespacePtr->fullName, srcStr); + } + + /* Make the alias command */ + if (TclAliasCreate(interp, interp, interp, src, myCmd, 1, &dst) != TCL_OK) { + Tcl_BounceRefCount(myCmd); + Tcl_BounceRefCount(src); + return TCL_ERROR; + } + + /* Remember the alias for cleanup if necessary */ + Tcl_ListObjAppendElement(NULL, oPtr->linkedCmdsList, src); + } + Tcl_BounceRefCount(myCmd); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * TclOONextObjCmd, TclOONextToObjCmd -- * * Implementation of the [next] and [nextto] commands. Note that these @@ -1533,7 +1629,7 @@ TclOOCallbackObjCmd( return TCL_ERROR; } - // Get the [my] real name. + /* Get the [my] real name. */ namePtr = TclOOObjectMyName(interp, contextPtr->oPtr); if (!namePtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -1542,7 +1638,7 @@ TclOOCallbackObjCmd( return TCL_ERROR; } - // No check that the method exists; could be dynamically added. + /* No check that the method exists; could be dynamically added. */ listPtr = Tcl_NewListObj(1, &namePtr); (void) TclListObjAppendElements(NULL, listPtr, objc-1, objv+1); @@ -1594,7 +1690,7 @@ TclOOClassVariableObjCmd( return TCL_ERROR; } - // Get a reference to the class's namespace + /* Get a reference to the class's namespace */ contextPtr = (CallContext *) framePtr->clientData; clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; if (clsPtr == NULL) { @@ -1605,7 +1701,7 @@ TclOOClassVariableObjCmd( } clsNsPtr = clsPtr->thisPtr->namespacePtr; - // Check the list of variable names + /* Check the list of variable names */ for (i = 1; i < objc; i++) { const char *varName = TclGetString(objv[i]); if (Tcl_StringMatch(varName, "*(*)")) { @@ -1624,10 +1720,10 @@ TclOOClassVariableObjCmd( } } - // Lastly, link the caller's local variables to the class's variables + /* Lastly, link the caller's local variables to the class's variables */ ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; for (i = 1; i < objc; i++) { - // Locate the other variable. + /* Locate the other variable. */ iPtr->varFramePtr->nsPtr = (Namespace *) clsNsPtr; otherPtr = TclObjLookupVarEx(interp, objv[i], NULL, (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), @@ -1637,7 +1733,7 @@ TclOOClassVariableObjCmd( return TCL_ERROR; } - // Create the new variable and link it to otherPtr. + /* Create the new variable and link it to otherPtr. */ if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, TCL_INDEX_NONE) != TCL_OK) { return TCL_ERROR; diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 4383b91..e7a3d1c 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -255,6 +255,7 @@ struct Object { PropertyStorage properties; /* Information relating to the lists of * properties that this object *claims* to * support. */ + Tcl_Obj *linkedCmdsList; /* List of names of linked commands. */ }; enum ObjectFlags { @@ -520,6 +521,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOOCallbackObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOClassVariableObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODelegateNameObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOLinkObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd; diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index bd3721b..f7b023e 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,31 +27,6 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\tproc Helpers::link {args} {\n" -"\t\tset ns [uplevel 1 {::namespace current}]\n" -"\t\tforeach link $args {\n" -"\t\t\tif {[llength $link] == 2} {\n" -"\t\t\t\tlassign $link src dst\n" -"\t\t\t} elseif {[llength $link] == 1} {\n" -"\t\t\t\tlassign $link src\n" -"\t\t\t\tset dst $src\n" -"\t\t\t} else {\n" -"\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n" -"\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" -"\t\t\t}\n" -"\t\t\tif {![string match ::* $src]} {\n" -"\t\t\t\tset src [string cat $ns :: $src]\n" -"\t\t\t}\n" -"\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" -"\t\t\ttrace add command ${ns}::my delete [list \\\n" -"\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" -"\t\t}\n" -"\t}\n" -"\tproc UnlinkLinkedCommand {cmd args} {\n" -"\t\tif {[namespace which $cmd] ne {}} {\n" -"\t\t\trename $cmd {}\n" -"\t\t}\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 4509202..1564645 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -12,57 +12,6 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. ::namespace eval ::oo { - - # - # Commands that are made available to objects by default. - # - - # ------------------------------------------------------------------ - # - # link -- - # - # Make a command that invokes a method on the current object. - # The name of the command and the name of the method match by - # default. - # - # ------------------------------------------------------------------ - - proc Helpers::link {args} { - set ns [uplevel 1 {::namespace current}] - foreach link $args { - if {[llength $link] == 2} { - lassign $link src dst - } elseif {[llength $link] == 1} { - lassign $link src - set dst $src - } else { - return -code error -errorcode {TCL OO CMDLINK_FORMAT} \ - "bad link description; must only have one or two elements" - } - if {![string match ::* $src]} { - set src [string cat $ns :: $src] - } - interp alias {} $src {} ${ns}::my $dst - trace add command ${ns}::my delete [list \ - ::oo::UnlinkLinkedCommand $src] - } - } - - # ---------------------------------------------------------------------- - # - # UnlinkLinkedCommand -- - # - # Callback used to remove linked command when the underlying mechanism - # that supports it is deleted. - # - # ---------------------------------------------------------------------- - - proc UnlinkLinkedCommand {cmd args} { - if {[namespace which $cmd] ne {}} { - rename $cmd {} - } - } - # ---------------------------------------------------------------------- # # UpdateClassDelegatesAfterClone -- -- cgit v0.12 From 7e4c95c24ea85cfe56f17aa415c3dfc920d271a3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 22 Aug 2025 19:25:13 +0000 Subject: Fix memory debugging info --- generic/tclStringObj.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c7812b6..7405f4d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -257,6 +257,10 @@ Tcl_NewStringObj( { return Tcl_DbNewStringObj(bytes, length, "unknown", 0); } + +/* Redefine the macro */ +#define Tcl_NewStringObj(bytes, len) \ + Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewStringObj( -- cgit v0.12 From 538ca551b7a17836f31775f41ca46227a6c2ea10 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 19:28:48 +0000 Subject: Move another definition (classmethod) into C. (backport) --- generic/tclOO.c | 1 + generic/tclOODefineCmds.c | 69 +++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOInt.h | 1 + generic/tclOOScript.h | 13 --------- tools/tclOOScript.tcl | 28 ------------------- 5 files changed, 71 insertions(+), 41 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 0f400e7..ba770f4 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -25,6 +25,7 @@ static const struct { Tcl_ObjCmdProc *objProc; int flag; } defineCmds[] = { + {"classmethod", TclOODefineClassMethodObjCmd, 0}, {"constructor", TclOODefineConstructorObjCmd, 0}, {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index d9a637a..ab6b398 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2228,6 +2228,75 @@ TclOODefineMethodObjCmd( /* * ---------------------------------------------------------------------- * + * TclOODefineClassMethodObjCmd -- + * + * Implementation of the "classmethod" subcommand of the "oo::define" + * command. Defines a class method. See define(n) for details. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineClassMethodObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Class *clsPtr; + int isPublic; + Tcl_Obj *forwardArgs[2], *prefixObj; + Method *mPtr; + + if (objc != 2 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?args body?"); + return TCL_ERROR; + } + clsPtr = TclOOGetClassDefineCmdContext(interp); + if (!clsPtr) { + return TCL_ERROR; + } + + isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) + ? PUBLIC_METHOD : 0; + + // Create the method on the delegate class if the caller gave arguments and body + if (objc == 4) { + Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate", + clsPtr->thisPtr->namespacePtr->fullName); + Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName); + + Tcl_DecrRefCount(delegateName); + if (!delegatePtr) { + return TCL_ERROR; + } + if (IsPrivateDefine(interp)) { + isPublic = 0; + } + if (TclOONewProcMethod(interp, delegatePtr, isPublic, objv[1], + objv[2], objv[3], NULL) == NULL) { + return TCL_ERROR; + } + } + + // Make the connection to the delegate by forwarding + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } + forwardArgs[0] = Tcl_NewStringObj("myclass", -1); + forwardArgs[1] = objv[1]; + prefixObj = Tcl_NewListObj(2, forwardArgs); + mPtr = TclOONewForwardMethod(interp, clsPtr, isPublic, objv[1], prefixObj); + if (mPtr == NULL) { + Tcl_DecrRefCount(prefixObj); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineRenameMethodObjCmd -- * * Implementation of the "renamemethod" subcommand of the "oo::define" diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index e7a3d1c..70b4a32 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -501,6 +501,7 @@ struct DeclaredClassMethod { MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDefnNsObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd; diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index f7b023e..79379d3 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -41,19 +41,6 @@ static const char *tclOOSetupScript = "\t\t\t\t}]\n" "\t\t}\n" "\t}\n" -"\tproc define::classmethod {name args} {\n" -"\t\t::set argc [::llength [::info level 0]]\n" -"\t\t::if {$argc == 3} {\n" -"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n" -"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n" -"\t\t\t\t[::lindex [::info level 0] 0]]\n" -"\t\t}\n" -"\t\t::set cls [::uplevel 1 self]\n" -"\t\t::if {$argc == 4} {\n" -"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n" -"\t\t}\n" -"\t\t::tailcall forward $name myclass $name\n" -"\t}\n" "\tdefine Slot forward --default-operation my -append\n" "\tdefine Slot unexport destroy\n" "\tobjdefine define::superclass forward --default-operation my -set\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 1564645..8bb214a 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -39,34 +39,6 @@ # ---------------------------------------------------------------------- # - # oo::define::classmethod -- - # - # Defines a class method. See define(n) for details. - # - # Note that the ::oo::define namespace is semi-public and a bit weird - # anyway, so we don't regard the namespace path as being under control: - # fully qualified names are used for everything. - # - # ---------------------------------------------------------------------- - - proc define::classmethod {name args} { - # Create the method on the class if the caller gave arguments and body - ::set argc [::llength [::info level 0]] - ::if {$argc == 3} { - ::return -code error -errorcode {TCL WRONGARGS} [::format \ - {wrong # args: should be "%s name ?args body?"} \ - [::lindex [::info level 0] 0]] - } - ::set cls [::uplevel 1 self] - ::if {$argc == 4} { - ::oo::define [::oo::DelegateName $cls] method $name {*}$args - } - # Make the connection by forwarding - ::tailcall forward $name myclass $name - } - - # ---------------------------------------------------------------------- - # # Slot -- # # The class of slot operations, which are basically lists at the low -- cgit v0.12 From 05ad3060a8dd619bdd049fe4e312269f20b1ac66 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 19:29:51 +0000 Subject: Combine UpdateClassDelegatesAfterClone into its caller. (backport) --- generic/tclOOScript.h | 32 +++++++++++++++----------------- tools/tclOOScript.tcl | 43 +++++++++++++++---------------------------- 2 files changed, 30 insertions(+), 45 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 79379d3..0bec4fa 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,20 +27,6 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" -"\t\tset originDelegate [DelegateName $originObject]\n" -"\t\tset targetDelegate [DelegateName $targetObject]\n" -"\t\tif {\n" -"\t\t\t[info object isa class $originDelegate]\n" -"\t\t\t&& ![info object isa class $targetDelegate]\n" -"\t\t} then {\n" -"\t\t\tcopy $originDelegate $targetDelegate\n" -"\t\t\tobjdefine $targetObject ::oo::objdefine::mixin -set \\\n" -"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n" -"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n" -"\t\t\t\t}]\n" -"\t\t}\n" -"\t}\n" "\tdefine Slot forward --default-operation my -append\n" "\tdefine Slot unexport destroy\n" "\tobjdefine define::superclass forward --default-operation my -set\n" @@ -74,8 +60,20 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t}\n" "\tdefine class method -unexport {originObject} {\n" +"\t\tset targetObject [self]\n" "\t\tnext $originObject\n" -"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" +"\t\tset originDelegate [::oo::DelegateName $originObject]\n" +"\t\tset targetDelegate [::oo::DelegateName $targetObject]\n" +"\t\tif {\n" +"\t\t\t[info object isa class $originDelegate]\n" +"\t\t\t&& ![info object isa class $targetDelegate]\n" +"\t\t} then {\n" +"\t\t\t::oo::copy $originDelegate $targetDelegate\n" +"\t\t\t::oo::objdefine $targetObject mixin -set \\\n" +"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n" +"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n" +"\t\t\t\t}]\n" +"\t\t}\n" "\t}\n" "\tclass create singleton\n" "\tdefine singleton superclass -set class\n" @@ -86,11 +84,11 @@ static const char *tclOOSetupScript = "\t\t\tset object [next {*}$args]\n" "\t\t\t::oo::objdefine $object {\n" "\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" "\t\t\t\t\t\t\"may not destroy a singleton object\"\n" "\t\t\t\t}\n" "\t\t\t\tmethod -unexport {originObject} {\n" -"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" "\t\t\t\t\t\t\"may not clone a singleton object\"\n" "\t\t\t\t}\n" "\t\t\t}\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 8bb214a..d871d57 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -14,31 +14,6 @@ ::namespace eval ::oo { # ---------------------------------------------------------------------- # - # UpdateClassDelegatesAfterClone -- - # - # Support code that is like [MixinClassDelegates] except for when a - # class is cloned. - # - # ---------------------------------------------------------------------- - - proc UpdateClassDelegatesAfterClone {originObject targetObject} { - # Rebuild the class inheritance delegation class - set originDelegate [DelegateName $originObject] - set targetDelegate [DelegateName $targetObject] - if { - [info object isa class $originDelegate] - && ![info object isa class $targetDelegate] - } then { - copy $originDelegate $targetDelegate - objdefine $targetObject ::oo::objdefine::mixin -set \ - {*}[lmap c [info object mixin $targetObject] { - if {$c eq $originDelegate} {set targetDelegate} {set c} - }] - } - } - - # ---------------------------------------------------------------------- - # # Slot -- # # The class of slot operations, which are basically lists at the low @@ -116,9 +91,21 @@ # ---------------------------------------------------------------------- define class method -unexport {originObject} { + set targetObject [self] next $originObject # Rebuild the class inheritance delegation class - ::oo::UpdateClassDelegatesAfterClone $originObject [self] + set originDelegate [::oo::DelegateName $originObject] + set targetDelegate [::oo::DelegateName $targetObject] + if { + [info object isa class $originDelegate] + && ![info object isa class $targetDelegate] + } then { + ::oo::copy $originDelegate $targetDelegate + ::oo::objdefine $targetObject mixin -set \ + {*}[lmap c [info object mixin $targetObject] { + if {$c eq $originDelegate} {set targetDelegate} {set c} + }] + } } # ---------------------------------------------------------------------- @@ -139,11 +126,11 @@ set object [next {*}$args] ::oo::objdefine $object { method destroy {} { - ::return -code error -errorcode {TCL OO SINGLETON} \ + return -code error -errorcode {TCL OO SINGLETON} \ "may not destroy a singleton object" } method -unexport {originObject} { - ::return -code error -errorcode {TCL OO SINGLETON} \ + return -code error -errorcode {TCL OO SINGLETON} \ "may not clone a singleton object" } } -- cgit v0.12 From 102d340fa6a18773ccc29cb792c78c0775f704ab Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 19:30:49 +0000 Subject: Tweak to [configurable] to not call [next] twice (backport) --- generic/tclOOScript.h | 2 +- tools/tclOOScript.tcl | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 0bec4fa..318a7ac 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -115,7 +115,7 @@ static const char *tclOOSetupScript = "\tclass create configurable\n" "\tdefine configurable superclass -set class\n" "\tdefine configurable constructor {{definitionScript \"\"}} {\n" -"\t\tnext {mixin ::oo::configuresupport::configurable}\n" +"\t\too::define [self] {mixin -append ::oo::configuresupport::configurable}\n" "\t\tnext $definitionScript\n" "\t}\n" "\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index d871d57..66e125d 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -232,7 +232,7 @@ class create configurable define configurable superclass -set class define configurable constructor {{definitionScript ""}} { - next {mixin ::oo::configuresupport::configurable} + ::oo::define [self] {mixin -append ::oo::configuresupport::configurable} next $definitionScript } -- cgit v0.12 From 14b58a3e203bd9d593055a6a131e747e815b4e2d Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 19:36:33 +0000 Subject: Make code style be a bit closer to the one used in 9.0 --- generic/tclOODefineCmds.c | 55 +++++++++++++++++++++++++---------------------- 1 file changed, 29 insertions(+), 26 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index ab6b398..6da3a33 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2107,7 +2107,7 @@ TclOODefineInitialiseObjCmd( return TCL_ERROR; } - // Build the lambda + /* Build the lambda */ object = TclOOGetDefineCmdContext(interp); if (object == NULL) { return TCL_ERROR; @@ -2116,7 +2116,7 @@ TclOODefineInitialiseObjCmd( lambdaWords[1] = objv[1]; lambdaWords[2] = TclNewNamespaceObj(Tcl_GetObjectNamespace(object)); - // Delegate to [apply] to run it + /* Delegate to [apply] to run it */ applyArgs[0] = Tcl_NewStringObj("apply", -1); applyArgs[1] = Tcl_NewListObj(3, lambdaWords); Tcl_IncrRefCount(applyArgs[0]); @@ -2260,7 +2260,10 @@ TclOODefineClassMethodObjCmd( isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) ? PUBLIC_METHOD : 0; - // Create the method on the delegate class if the caller gave arguments and body + /* + * Create the method on the delegate class if the caller gave arguments + * and body. + */ if (objc == 4) { Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate", clsPtr->thisPtr->namespacePtr->fullName); @@ -2279,7 +2282,7 @@ TclOODefineClassMethodObjCmd( } } - // Make the connection to the delegate by forwarding + /* Make the connection to the delegate by forwarding */ if (IsPrivateDefine(interp)) { isPublic = TRUE_PRIVATE_METHOD; } @@ -2570,7 +2573,7 @@ TclOODefineSlots( * ---------------------------------------------------------------------- */ -// Call [$slot Get] to retrieve the list of contents of the slot +/* Call [$slot Get] to retrieve the list of contents of the slot */ static inline Tcl_Obj * CallSlotGet( Tcl_Interp *interp, @@ -2588,7 +2591,7 @@ CallSlotGet( return Tcl_GetObjResult(interp); } -// Call [$slot Set $list] to set the list of contents of the slot +/* Call [$slot Set $list] to set the list of contents of the slot */ static inline int CallSlotSet( Tcl_Interp *interp, @@ -2602,7 +2605,7 @@ CallSlotSet( return TclOOPrivateObjectCmd(slot, interp, 3, setArgs); } -// Call [$slot Resolve $item] to convert a slot item into canonical form +/* Call [$slot Resolve $item] to convert a slot item into canonical form */ static inline Tcl_Obj * CallSlotResolve( Tcl_Interp *interp, @@ -2679,13 +2682,13 @@ Slot_Append( return TCL_OK; } - // Resolve all values + /* Resolve all values */ resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); if (resolved == NULL) { return TCL_ERROR; } - // Get slot contents; store in list + /* Get slot contents; store in list */ list = CallSlotGet(interp, oPtr); if (list == NULL) { Tcl_DecrRefCount(resolved); @@ -2694,7 +2697,7 @@ Slot_Append( Tcl_IncrRefCount(list); Tcl_ResetResult(interp); - // Append + /* Append */ if (Tcl_IsShared(list)) { Tcl_Obj *dup = Tcl_DuplicateObj(list); Tcl_IncrRefCount(dup); @@ -2708,7 +2711,7 @@ Slot_Append( } Tcl_DecrRefCount(resolved); - // Set slot contents + /* Set slot contents */ code = CallSlotSet(interp, oPtr, list); Tcl_DecrRefCount(list); return code; @@ -2741,13 +2744,13 @@ Slot_AppendNew( return TCL_OK; } - // Resolve all values + /* Resolve all values */ resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); if (resolved == NULL) { return TCL_ERROR; } - // Get slot contents; store in list + /* Get slot contents; store in list */ list = CallSlotGet(interp, oPtr); if (list == NULL) { Tcl_DecrRefCount(resolved); @@ -2756,7 +2759,7 @@ Slot_AppendNew( Tcl_IncrRefCount(list); Tcl_ResetResult(interp); - // Prepare a set of items in the list to set + /* Prepare a set of items in the list to set */ if (TclListObjGetElements(interp, list, &listc, &listv) != TCL_OK) { Tcl_DecrRefCount(list); Tcl_DecrRefCount(resolved); @@ -2767,7 +2770,7 @@ Slot_AppendNew( Tcl_CreateHashEntry(&unique, listv[i], NULL); } - // Append the new items if they're not already there + /* Append the new items if they're not already there */ if (Tcl_IsShared(list)) { Tcl_Obj *dup = Tcl_DuplicateObj(list); Tcl_IncrRefCount(dup); @@ -2785,7 +2788,7 @@ Slot_AppendNew( Tcl_DecrRefCount(resolved); Tcl_DeleteHashTable(&unique); - // Set slot contents + /* Set slot contents */ code = CallSlotSet(interp, oPtr, list); Tcl_DecrRefCount(list); return code; @@ -2847,14 +2850,14 @@ Slot_Prepend( return TCL_OK; } - // Resolve all values + /* Resolve all values */ list = ResolveAll(interp, oPtr, objc - skip, objv + skip); if (list == NULL) { return TCL_ERROR; } Tcl_IncrRefCount(list); - // Get slot contents and append to list + /* Get slot contents and append to list */ oldList = CallSlotGet(interp, oPtr); if (oldList == NULL) { Tcl_DecrRefCount(list); @@ -2863,7 +2866,7 @@ Slot_Prepend( Tcl_ListObjAppendList(NULL, list, oldList); Tcl_ResetResult(interp); - // Set slot contents + /* Set slot contents */ code = CallSlotSet(interp, oPtr, list); Tcl_DecrRefCount(list); return code; @@ -2896,13 +2899,13 @@ Slot_Remove( return TCL_OK; } - // Resolve all values + /* Resolve all values */ resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); if (resolved == NULL) { return TCL_ERROR; } - // Get slot contents; store in list + /* Get slot contents; store in list */ oldList = CallSlotGet(interp, oPtr); if (oldList == NULL) { Tcl_DecrRefCount(resolved); @@ -2911,7 +2914,7 @@ Slot_Remove( Tcl_IncrRefCount(oldList); Tcl_ResetResult(interp); - // Prepare a set of items in the list to remove + /* Prepare a set of items in the list to remove */ TclListObjGetElements(NULL, resolved, &listc, &listv); Tcl_InitObjHashTable(&removeSet); for (i=0 ; i Date: Sat, 23 Aug 2025 07:57:28 +0000 Subject: corrections (createhashentry is different in 9.1) and cleanup (I like command tables) --- generic/tclOO.c | 57 ++++++++++++++++++++++++++++++----------------- generic/tclOODefineCmds.c | 9 ++++---- 2 files changed, 41 insertions(+), 25 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index ba770f4..0da8b7f 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -17,10 +17,36 @@ #include "tclOOInt.h" /* + * Commands in oo and oo::Helpers. + */ + +static const struct StdCommands { + const char *name; + Tcl_ObjCmdProc *objProc; + Tcl_ObjCmdProc *nreProc; + CompileProc *compileProc; +} ooCmds[] = { + {"define", TclOODefineObjCmd, NULL, NULL}, + {"objdefine", TclOOObjDefObjCmd, NULL, NULL}, + {"copy", TclOOCopyObjectCmd, NULL, NULL}, + {"DelegateName", TclOODelegateNameObjCmd, NULL, NULL}, + {NULL, NULL, NULL, NULL} +}, helpCmds[] = { + {"callback", TclOOCallbackObjCmd, NULL, NULL}, + {"mymethod", TclOOCallbackObjCmd, NULL, NULL}, + {"classvariable", TclOOClassVariableObjCmd, NULL, NULL}, + {"link", TclOOLinkObjCmd, NULL, NULL}, + {"next", NULL, TclOONextObjCmd, TclCompileObjectNextCmd}, + {"nextto", NULL, TclOONextToObjCmd, TclCompileObjectNextToCmd}, + {"self", TclOOSelfObjCmd, NULL, TclCompileObjectSelfCmd}, + {NULL, NULL, NULL, NULL} +}; + +/* * Commands in oo::define and oo::objdefine. */ -static const struct { +static const struct DefineCommands { const char *name; Tcl_ObjCmdProc *objProc; int flag; @@ -437,25 +463,16 @@ InitFoundation( * ensemble. */ - CreateCmdInNS(interp, fPtr->helpersNs, "callback", - TclOOCallbackObjCmd, NULL, NULL, 0); - CreateCmdInNS(interp, fPtr->helpersNs, "mymethod", - TclOOCallbackObjCmd, NULL, NULL, 0); - CreateCmdInNS(interp, fPtr->helpersNs, "classvariable", - TclOOClassVariableObjCmd, NULL, NULL, 0); - CreateCmdInNS(interp, fPtr->helpersNs, "link", - TclOOLinkObjCmd, NULL, NULL, 0); - CreateCmdInNS(interp, fPtr->helpersNs, "next", - NULL, TclOONextObjCmd, TclCompileObjectNextCmd); - CreateCmdInNS(interp, fPtr->helpersNs, "nextto", - NULL, TclOONextToObjCmd, TclCompileObjectNextToCmd); - CreateCmdInNS(interp, fPtr->helpersNs, "self", - TclOOSelfObjCmd, NULL, TclCompileObjectSelfCmd); - - CreateCmdInNS(interp, fPtr->ooNs, "define", TclOODefineObjCmd, NULL, NULL); - CreateCmdInNS(interp, fPtr->ooNs, "objdefine", TclOOObjDefObjCmd, NULL, NULL); - CreateCmdInNS(interp, fPtr->ooNs, "copy", TclOOCopyObjectCmd, NULL, NULL); - CreateCmdInNS(interp, fPtr->ooNs, "DelegateName", TclOODelegateNameObjCmd, NULL, NULL, 0); + for (i = 0 ; helpCmds[i].name ; i++) { + CreateCmdInNS(interp, fPtr->helpersNs, helpCmds[i].name, + helpCmds[i].objProc, helpCmds[i].nreProc, + helpCmds[i].compileProc); + } + for (i = 0 ; ooCmds[i].name ; i++) { + CreateCmdInNS(interp, fPtr->ooNs, ooCmds[i].name, + ooCmds[i].objProc, ooCmds[i].nreProc, + ooCmds[i].compileProc); + } TclOOInitInfo(interp); diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 6da3a33..8d99b07 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2735,7 +2735,7 @@ Slot_AppendNew( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - int skip = Tcl_ObjectContextSkippedArgs(context), code; + int skip = Tcl_ObjectContextSkippedArgs(context), code, isNew; Tcl_Obj *resolved, *list, **listv; Tcl_Size listc, i; Tcl_HashTable unique; @@ -2767,7 +2767,7 @@ Slot_AppendNew( } Tcl_InitObjHashTable(&unique); for (i=0 ; i Date: Sun, 24 Aug 2025 06:52:11 +0000 Subject: Complete the moving of the definition of slots entirely into C --- generic/tclOO.c | 69 +++++++++---------- generic/tclOODefineCmds.c | 164 +++++++++++++++++++++++++++++++--------------- generic/tclOOScript.h | 7 +- tools/tclOOScript.tcl | 27 -------- 4 files changed, 144 insertions(+), 123 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index b50919b..1fa9470 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -52,31 +52,31 @@ static const struct DefineCommands { Tcl_ObjCmdProc *objProc; int flag; } defineCmds[] = { - {"classmethod", TclOODefineClassMethodObjCmd, 0}, - {"constructor", TclOODefineConstructorObjCmd, 0}, + {"classmethod", TclOODefineClassMethodObjCmd, 0}, + {"constructor", TclOODefineConstructorObjCmd, 0}, {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, - {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, - {"destructor", TclOODefineDestructorObjCmd, 0}, - {"export", TclOODefineExportObjCmd, 0}, - {"forward", TclOODefineForwardObjCmd, 0}, - {"initialise", TclOODefineInitialiseObjCmd, 0}, - {"initialize", TclOODefineInitialiseObjCmd, 0}, - {"method", TclOODefineMethodObjCmd, 0}, - {"private", TclOODefinePrivateObjCmd, 0}, - {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, - {"self", TclOODefineSelfObjCmd, 0}, - {"unexport", TclOODefineUnexportObjCmd, 0}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, + {"destructor", TclOODefineDestructorObjCmd, 0}, + {"export", TclOODefineExportObjCmd, 0}, + {"forward", TclOODefineForwardObjCmd, 0}, + {"initialise", TclOODefineInitialiseObjCmd, 0}, + {"initialize", TclOODefineInitialiseObjCmd, 0}, + {"method", TclOODefineMethodObjCmd, 0}, + {"private", TclOODefinePrivateObjCmd, 0}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, + {"self", TclOODefineSelfObjCmd, 0}, + {"unexport", TclOODefineUnexportObjCmd, 0}, {NULL, NULL, 0} }, objdefCmds[] = { - {"class", TclOODefineClassObjCmd, 1}, - {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, - {"export", TclOODefineExportObjCmd, 1}, - {"forward", TclOODefineForwardObjCmd, 1}, - {"method", TclOODefineMethodObjCmd, 1}, - {"private", TclOODefinePrivateObjCmd, 1}, - {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, - {"self", TclOODefineObjSelfObjCmd, 0}, - {"unexport", TclOODefineUnexportObjCmd, 1}, + {"class", TclOODefineClassObjCmd, 1}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, + {"export", TclOODefineExportObjCmd, 1}, + {"forward", TclOODefineForwardObjCmd, 1}, + {"method", TclOODefineMethodObjCmd, 1}, + {"private", TclOODefinePrivateObjCmd, 1}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, + {"self", TclOODefineObjSelfObjCmd, 0}, + {"unexport", TclOODefineUnexportObjCmd, 1}, {NULL, NULL, 0} }; @@ -97,7 +97,7 @@ static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method **newMPtrPtr); static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, Method *mPtr, Tcl_Obj *namePtr); -static void DeletedHelpersNamespace(void *clientData); +static Tcl_NamespaceDeleteProc DeletedHelpersNamespace; static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; @@ -106,23 +106,17 @@ static void InitClassSystemRoots(Tcl_Interp *interp, Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); static Tcl_InterpDeleteProc KillFoundation; -static void MyDeleted(void *clientData); -static void ObjectNamespaceDeleted(void *clientData); +static Tcl_CmdDeleteProc MyDeleted; +static Tcl_NamespaceDeleteProc ObjectNamespaceDeleted; static Tcl_CommandTraceProc ObjectRenamedTrace; static inline void RemoveClass(Class **list, size_t num, size_t idx); static inline void RemoveObject(Object **list, size_t num, size_t idx); static inline void SquelchCachedName(Object *oPtr); -static int PublicNRObjectCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static int PrivateNRObjectCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static int MyClassNRObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static void MyClassDeleted(void *clientData); +static Tcl_ObjCmdProc PublicNRObjectCmd; +static Tcl_ObjCmdProc PrivateNRObjectCmd; +static Tcl_ObjCmdProc MyClassNRObjCmd; +static Tcl_CmdDeleteProc MyClassDeleted; /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -173,8 +167,9 @@ static const char initScript[] = "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" #endif "package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};" -"namespace eval ::oo { variable version " TCLOO_VERSION " };" -"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; +"namespace eval ::oo {" +" variable version " TCLOO_VERSION " patchlevel " TCLOO_PATCHLEVEL +"};"; /* "tcl_findLibrary tcloo $oo::version $oo::version" */ /* " tcloo.tcl OO_LIBRARY oo::library;"; */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 40c4fe0..0b1495a 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -37,16 +37,17 @@ typedef struct DeclaredSlot { const Tcl_MethodType getterType; const Tcl_MethodType setterType; const Tcl_MethodType resolverType; + const char *defaultOp; // The default op, if not set by the class } DeclaredSlot; -#define SLOT(name,getter,setter,resolver) \ +#define SLOT(name,getter,setter,resolver,defOp) \ {"::oo::" name, \ {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter", \ getter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter", \ setter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver", \ - resolver, NULL, NULL}} + resolver, NULL, NULL}, (defOp)} typedef struct DeclaredSlotMethod { const char *name; @@ -190,26 +191,26 @@ static int ResolveClass(void *clientData, */ static const DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilter_Get, ClassFilter_Set, NULL), - SLOT("define::mixin", ClassMixin_Get, ClassMixin_Set, ResolveClass), - SLOT("define::superclass", ClassSuper_Get, ClassSuper_Set, ResolveClass), - SLOT("define::variable", ClassVars_Get, ClassVars_Set, NULL), - SLOT("objdefine::filter", ObjFilter_Get, ObjFilter_Set, NULL), - SLOT("objdefine::mixin", ObjMixin_Get, ObjMixin_Set, ResolveClass), - SLOT("objdefine::variable", ObjVars_Get, ObjVars_Set, NULL), + SLOT("define::filter", ClassFilter_Get, ClassFilter_Set, NULL, NULL), + SLOT("define::mixin", ClassMixin_Get, ClassMixin_Set, ResolveClass, "-set"), + SLOT("define::superclass", ClassSuper_Get, ClassSuper_Set, ResolveClass, "-set"), + SLOT("define::variable", ClassVars_Get, ClassVars_Set, NULL, NULL), + SLOT("objdefine::filter", ObjFilter_Get, ObjFilter_Set, NULL, NULL), + SLOT("objdefine::mixin", ObjMixin_Get, ObjMixin_Set, ResolveClass, "-set"), + SLOT("objdefine::variable", ObjVars_Get, ObjVars_Set, NULL, NULL), SLOT("configuresupport::readableproperties", Configurable_ClassReadableProps_Get, - Configurable_ClassReadableProps_Set, NULL), + Configurable_ClassReadableProps_Set, NULL, NULL), SLOT("configuresupport::writableproperties", Configurable_ClassWritableProps_Get, - Configurable_ClassWritableProps_Set, NULL), + Configurable_ClassWritableProps_Set, NULL, NULL), SLOT("configuresupport::objreadableproperties", Configurable_ObjectReadableProps_Get, - Configurable_ObjectReadableProps_Set, NULL), + Configurable_ObjectReadableProps_Set, NULL, NULL), SLOT("configuresupport::objwritableproperties", Configurable_ObjectWritableProps_Get, - Configurable_ObjectWritableProps_Set, NULL), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} + Configurable_ObjectWritableProps_Set, NULL, NULL), + {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, 0} }; static const DeclaredSlotMethod slotMethods[] = { @@ -2349,6 +2350,75 @@ TclOODefineRenameMethodObjCmd( } /* + * Unexporting is done by removing the PUBLIC_METHOD flag from the method + * record. If there is no such method in this object or class (i.e. the method + * comes from something inherited from or that we're an instance of) then we + * put in a blank record without that flag; such records are skipped over by + * the call chain engine *except* for their flags member. + * + * Caller has the responsibility to update any epochs if necessary. + */ + +static int +UnexportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, namePtr, + &isNew); + Method *mPtr; + if (isNew) { + mPtr = (Method *) Tcl_Alloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); + mPtr->refCount = 1; + mPtr->namePtr = namePtr; + Tcl_IncrRefCount(namePtr); + Tcl_SetHashValue(hPtr, mPtr); + } else { + mPtr = (Method *) Tcl_GetHashValue(hPtr); + } + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +static int +UnexportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = (Tcl_HashTable *) + Tcl_Alloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } + + int isNew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, namePtr, + &isNew); + Method *mPtr; + if (isNew) { + mPtr = (Method *) Tcl_Alloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); + mPtr->refCount = 1; + mPtr->namePtr = namePtr; + Tcl_IncrRefCount(namePtr); + Tcl_SetHashValue(hPtr, mPtr); + } else { + mPtr = (Method *) Tcl_GetHashValue(hPtr); + } + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +/* * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- @@ -2368,10 +2438,8 @@ TclOODefineUnexportObjCmd( { int isInstanceUnexport = (clientData != NULL); Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; Class *clsPtr; - int i, isNew, changed = 0; + int i, changed = 0; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); @@ -2391,42 +2459,10 @@ TclOODefineUnexportObjCmd( } for (i = 1; i < objc; i++) { - /* - * Unexporting is done by removing the PUBLIC_METHOD flag from the - * method record. If there is no such method in this object or class - * (i.e. the method comes from something inherited from or that we're - * an instance of) then we put in a blank record without that flag; - * such records are skipped over by the call chain engine *except* for - * their flags member. - */ - if (isInstanceUnexport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); + changed |= UnexportInstanceMethod(oPtr, objv[i]); } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - changed = 1; + changed |= UnexportMethod(clsPtr, objv[i]); } } @@ -2504,8 +2540,9 @@ Tcl_ClassSetDestructor( * * TclOODefineSlots -- * - * Create the "::oo::Slot" class and its standard instances. Class - * definition is empty at the stage (added by scripting). + * Create the "::oo::Slot" class and its standard instances. These are + * basically lists at the low level of TclOO; this provides a more + * consistent interface to them. * * ---------------------------------------------------------------------- */ @@ -2533,6 +2570,19 @@ TclOODefineSlots( Tcl_BounceRefCount(name); } + // If a slot can't figure out what method to call directly, it uses + // --default-operation. That defaults to -append; we set that here. + Tcl_Obj *defaults[] = { + fPtr->myName, + Tcl_NewStringObj("-append", TCL_AUTO_LENGTH) + }; + TclOONewForwardMethod(interp, (Class *) slotCls, 0, + fPtr->slotDefOpName, Tcl_NewListObj(2, defaults)); + + // Hide the destroy method. (We're definitely taking a ref to the name.) + UnexportMethod((Class *) slotCls, + Tcl_NewStringObj("destroy", TCL_AUTO_LENGTH)); + for (const DeclaredSlot *slotPtr = slots ; slotPtr->name ; slotPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(interp, slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0); @@ -2548,6 +2598,14 @@ TclOODefineSlots( TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0, &slotPtr->resolverType, NULL); } + if (slotPtr->defaultOp) { + Tcl_Obj *slotDefaults[] = { + fPtr->myName, + Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH) + }; + TclOONewForwardInstanceMethod(interp, (Object *) slotObject, 0, + fPtr->slotDefOpName, Tcl_NewListObj(2, slotDefaults)); + } } return TCL_OK; } diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 318a7ac..4c5f1a2 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,11 +27,6 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\tdefine Slot forward --default-operation my -append\n" -"\tdefine Slot unexport destroy\n" -"\tobjdefine define::superclass forward --default-operation my -set\n" -"\tobjdefine define::mixin forward --default-operation my -set\n" -"\tobjdefine objdefine::mixin forward --default-operation my -set\n" "\tdefine object method -unexport {originObject} {\n" "\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" "\t\t\tset args [info args $p]\n" @@ -115,7 +110,7 @@ static const char *tclOOSetupScript = "\tclass create configurable\n" "\tdefine configurable superclass -set class\n" "\tdefine configurable constructor {{definitionScript \"\"}} {\n" -"\t\too::define [self] {mixin -append ::oo::configuresupport::configurable}\n" +"\t\t::oo::define [self] {mixin -append ::oo::configuresupport::configurable}\n" "\t\tnext $definitionScript\n" "\t}\n" "\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 66e125d..6b17483 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -14,33 +14,6 @@ ::namespace eval ::oo { # ---------------------------------------------------------------------- # - # Slot -- - # - # The class of slot operations, which are basically lists at the low - # level of TclOO; this provides a more consistent interface to them. - # - # ---------------------------------------------------------------------- - - # ------------------------------------------------------------------ - # - # Slot --default-operation -- - # - # If a slot can't figure out what method to call directly, it - # uses --default-operation. - # - # ------------------------------------------------------------------ - define Slot forward --default-operation my -append - - # Hide destroy - define Slot unexport destroy - - # Set the default operation differently for these slots - objdefine define::superclass forward --default-operation my -set - objdefine define::mixin forward --default-operation my -set - objdefine objdefine::mixin forward --default-operation my -set - - # ---------------------------------------------------------------------- - # # oo::object -- # # Handler for cloning objects that clones basic bits (only!) of the -- cgit v0.12 From 7f743eb32b2e6643b071cdd82b1110d77b3b1a99 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 24 Aug 2025 10:40:58 +0000 Subject: Tinkering, making code simpler or easier to maintain --- generic/tclOODefineCmds.c | 220 +++++++++++++++++++++++++--------------------- generic/tclOOScript.h | 22 ++--- tools/tclOOScript.tcl | 32 ++++--- win/Makefile.in | 2 +- 4 files changed, 151 insertions(+), 125 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 0b1495a..e3fbe3f 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1231,6 +1231,119 @@ MagicDefinitionInvoke( /* * ---------------------------------------------------------------------- * + * ExportMethod, UnexportMethod, ExportInstanceMethod, UnexportInstanceMethod -- + * + * Exporting and unexporting are done by setting or removing the + * PUBLIC_METHOD flag on the method record. If there is no such method in + * this class or object (i.e. the method comes from something inherited + * from or that we're an instance of) then we put in a blank record just + * to hold that flag (or its absence); such records are skipped over by + * the call chain engine *except* for their flags member. + * + * Caller has the responsibility to update any epochs if necessary. + * + * ---------------------------------------------------------------------- + */ + +// Make a blank method record or look up the existing one. +static inline Method * +GetOrCreateMethod( + Tcl_HashTable *tablePtr, + Tcl_Obj *namePtr, + int *isNew) +{ + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, namePtr, + isNew); + if (*isNew) { + Method *mPtr = (Method *) Tcl_Alloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); + mPtr->refCount = 1; + mPtr->namePtr = namePtr; + Tcl_IncrRefCount(namePtr); + Tcl_SetHashValue(hPtr, mPtr); + return mPtr; + } else { + return (Method *) Tcl_GetHashValue(hPtr); + } +} + +static int +ExportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew); + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { + mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; + isNew = 1; + } + return isNew; +} + +static int +UnexportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew); + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +// Make the table of methods in the instance if it doesn't already exist. +static inline void +InitMethodTable( + Object *oPtr) +{ + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } +} + +static int +ExportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + InitMethodTable(oPtr); + + int isNew; + Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew); + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { + mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; + isNew = 1; + } + return isNew; +} + +static int +UnexportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + InitMethodTable(oPtr); + + int isNew; + Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew); + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineObjCmd -- * * Implementation of the "oo::define" command. Works by effectively doing @@ -1939,22 +2052,18 @@ TclOODefineExportObjCmd( Tcl_Obj *const *objv) { int isInstanceExport = (clientData != NULL); - Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; - Class *clsPtr; - int i, isNew, changed = 0; + int i, changed = 0; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } - oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } - clsPtr = oPtr->classPtr; + Class *clsPtr = oPtr->classPtr; if (!isInstanceExport && !clsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", TCL_AUTO_LENGTH)); @@ -1973,33 +2082,9 @@ TclOODefineExportObjCmd( */ if (isInstanceExport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); + changed |= ExportInstanceMethod(oPtr, objv[i]); } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { - mPtr->flags |= PUBLIC_METHOD; - mPtr->flags &= ~TRUE_PRIVATE_METHOD; - changed = 1; + changed |= ExportMethod(clsPtr, objv[i]); } } @@ -2350,75 +2435,6 @@ TclOODefineRenameMethodObjCmd( } /* - * Unexporting is done by removing the PUBLIC_METHOD flag from the method - * record. If there is no such method in this object or class (i.e. the method - * comes from something inherited from or that we're an instance of) then we - * put in a blank record without that flag; such records are skipped over by - * the call chain engine *except* for their flags member. - * - * Caller has the responsibility to update any epochs if necessary. - */ - -static int -UnexportMethod( - Class *clsPtr, - Tcl_Obj *namePtr) -{ - int isNew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, namePtr, - &isNew); - Method *mPtr; - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = namePtr; - Tcl_IncrRefCount(namePtr); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - isNew = 1; - } - return isNew; -} - -static int -UnexportInstanceMethod( - Object *oPtr, - Tcl_Obj *namePtr) -{ - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - - int isNew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, namePtr, - &isNew); - Method *mPtr; - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = namePtr; - Tcl_IncrRefCount(namePtr); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - isNew = 1; - } - return isNew; -} - -/* * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 4c5f1a2..390b034 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -72,24 +72,24 @@ static const char *tclOOSetupScript = "\t}\n" "\tclass create singleton\n" "\tdefine singleton superclass -set class\n" -"\tdefine singleton variable -set object\n" "\tdefine singleton unexport create createWithNamespace\n" "\tdefine singleton method new args {\n" +"\t\tvariable object\n" "\t\tif {![info exists object] || ![info object isa object $object]} {\n" "\t\t\tset object [next {*}$args]\n" -"\t\t\t::oo::objdefine $object {\n" -"\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\"may not destroy a singleton object\"\n" -"\t\t\t\t}\n" -"\t\t\t\tmethod -unexport {originObject} {\n" -"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\"may not clone a singleton object\"\n" -"\t\t\t\t}\n" -"\t\t\t}\n" +"\t\t\t::oo::objdefine $object mixin -prepend ::oo::SingletonInstance\n" "\t\t}\n" "\t\treturn $object\n" "\t}\n" +"\tclass create SingletonInstance\n" +"\tdefine SingletonInstance method destroy {} {\n" +"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\"may not destroy a singleton object\"\n" +"\t}\n" +"\tdefine SingletonInstance method -unexport {originObject} {\n" +"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\"may not clone a singleton object\"\n" +"\t}\n" "\tclass create abstract\n" "\tdefine abstract superclass -set class\n" "\tdefine abstract unexport create createWithNamespace new\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 6b17483..b17d7d0 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -92,27 +92,37 @@ class create singleton define singleton superclass -set class - define singleton variable -set object define singleton unexport create createWithNamespace define singleton method new args { + variable object if {![info exists object] || ![info object isa object $object]} { set object [next {*}$args] - ::oo::objdefine $object { - method destroy {} { - return -code error -errorcode {TCL OO SINGLETON} \ - "may not destroy a singleton object" - } - method -unexport {originObject} { - return -code error -errorcode {TCL OO SINGLETON} \ - "may not clone a singleton object" - } - } + ::oo::objdefine $object mixin -prepend ::oo::SingletonInstance } return $object } # ---------------------------------------------------------------------- # + # oo::SingletonInstance -- + # + # A mixin used to make an object so it won't be destroyed or cloned (or + # at least not easily). + # + # ---------------------------------------------------------------------- + + class create SingletonInstance + define SingletonInstance method destroy {} { + return -code error -errorcode {TCL OO SINGLETON} \ + "may not destroy a singleton object" + } + define SingletonInstance method -unexport {originObject} { + return -code error -errorcode {TCL OO SINGLETON} \ + "may not clone a singleton object" + } + + # ---------------------------------------------------------------------- + # # oo::abstract -- # # A metaclass that is used to make classes that can't be directly diff --git a/win/Makefile.in b/win/Makefile.in index 5457bcb..d0e264a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -758,7 +758,7 @@ tclWinPanic.${OBJEXT}: tclWinPanic.c .rc.$(RES): $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@ - +tclOO.${OBJEXT}: tclOO.c tclOOScript.h #-------------------------------------------------------------------------- # Minizip implementation -- cgit v0.12 From 535d9351df50c446d68d2a5b243b4cbbfb5aa666 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Aug 2025 08:51:05 +0000 Subject: Fix handling of i386-x86_64 in platform extension. Add testcases for this (and other) situation --- library/platform/platform.tcl | 10 ++++++---- tests/platform.test | 34 +++++++++++++++++++++++++++++++++- 2 files changed, 39 insertions(+), 5 deletions(-) diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl index 3bf1ff6..e93e2df 100644 --- a/library/platform/platform.tcl +++ b/library/platform/platform.tcl @@ -347,13 +347,14 @@ proc ::platform::patterns {id} { # 10.5+,11.0+ if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} { + foreach {major minor} [split $v.15 .] break switch -exact -- $cpu { ix86 { lappend alt i386-x86_64 lappend alt universal } x86_64 { - if {[lindex [split $::tcl_platform(osVersion) .] 0] < 19} { + if {$major < 11 && $minor < 15} { set alt i386-x86_64 } else { set alt {} @@ -366,8 +367,6 @@ proc ::platform::patterns {id} { } if {$v ne ""} { - foreach {major minor} [split $v .] break - set res {} if {$major > 26} { # Add x.0 to x.minor to patterns. @@ -451,6 +450,9 @@ proc ::platform::patterns {id} { if {$cpu ne "arm"} { lappend res macosx${major}.${j}-${cpu} } + if {($cpu eq "x86_64") && ($j == 14)} { + set alt i386-x86_64 + } foreach a $alt { lappend res macosx${major}.${j}-$a } @@ -465,7 +467,7 @@ proc ::platform::patterns {id} { lappend res macosx${major}.${j}-$a } } - # Add unversioned patterns for 10.3/10.4 builds. + # Add unversioned patterns for 10.3/10.4 builds. lappend res macosx-${cpu} foreach a $alt { lappend res macosx-$a diff --git a/tests/platform.test b/tests/platform.test index faab6d9..9ef0b9c 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -4,7 +4,7 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1999 by Scriptics Corporation +# Copyright (c) 1999 Scriptics Corporation # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -78,6 +78,38 @@ test platform-4.2 {format of platform::generic result} -match regexp -body { platform::generic } -result {^([^-]+-)+[^-]+$} +test platform-5.0 {format of platform::generic result} -setup { + set old_machine $::tcl_platform(machine) + set old_os $::tcl_platform(os) + set old_wordsize $::tcl_platform(wordSize) + set old_version $tcl_platform(osVersion) + set ::tcl_platform(machine) arm + set ::tcl_platform(os) Darwin + set ::tcl_platform(wordSize) 8 + set ::tcl_platform(osVersion) 20.1 +} -body { + set res {} + set l {macosx10.15-x86_64 macosx10.14-x86_64 macosx10.13-x86_64 macosx10.12-x86_64 macosx10.11-x86_64 macosx10.10-x86_64 macosx10.9-x86_64 tcl} + set id [platform::identify] + set l [linsert $l 0 [string range $id 0 end-3]-x86_64] + set l [linsert $l 0 $id] + lappend res $id + lappend res [platform::patterns $id] + set res +} -cleanup { + set ::tcl_platform(machine) $old_machine + set ::tcl_platform(os) $old_os + set ::tcl_platform(wordSize) $old_wordsize + set ::tcl_platform(osVersion) $old_version + unset res l old_machine old_os old_wordsize old_version +} -result {macosx11.0-arm {macosx11.0-arm macosx11.0-x86_64 macosx10.15-x86_64 macosx10.14-x86_64 macosx10.13-x86_64 macosx10.12-x86_64 macosx10.11-x86_64 macosx10.10-x86_64 macosx10.9-x86_64 macosx10.8-x86_64 macosx10.7-x86_64 macosx10.6-x86_64 macosx10.5-x86_64 macosx-arm macosx-x86_64 tcl}} +test platform-5.1 {format of platform::patterns macosx11.0-x86_64} -body { + platform::patterns macosx11.0-x86_64 +} -result {macosx11.0-x86_64 macosx10.15-x86_64 macosx10.14-x86_64 macosx10.14-i386-x86_64 macosx10.13-x86_64 macosx10.13-i386-x86_64 macosx10.12-x86_64 macosx10.12-i386-x86_64 macosx10.11-x86_64 macosx10.11-i386-x86_64 macosx10.10-x86_64 macosx10.10-i386-x86_64 macosx10.9-x86_64 macosx10.9-i386-x86_64 macosx10.8-x86_64 macosx10.8-i386-x86_64 macosx10.7-x86_64 macosx10.7-i386-x86_64 macosx10.6-x86_64 macosx10.6-i386-x86_64 macosx10.5-x86_64 macosx10.5-i386-x86_64 macosx-x86_64 macosx-i386-x86_64 tcl} +test platform-5.2 {format of platform::patterns macosx11.0-arm} -body { + platform::patterns macosx11.0-arm +} -result {macosx11.0-arm macosx11.0-x86_64 macosx10.15-x86_64 macosx10.14-x86_64 macosx10.13-x86_64 macosx10.12-x86_64 macosx10.11-x86_64 macosx10.10-x86_64 macosx10.9-x86_64 macosx10.8-x86_64 macosx10.7-x86_64 macosx10.6-x86_64 macosx10.5-x86_64 macosx-arm macosx-x86_64 tcl} + # cleanup cleanupTests -- cgit v0.12 From a95bde48906c8729d4d76c10bfd700439c2c7196 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Aug 2025 09:37:02 +0000 Subject: Fix testcase oo-1.21 --- tests/oo.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/oo.test b/tests/oo.test index 21c8f9e..7d5ea37 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -390,7 +390,7 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { }] {lsort [lsearch -all -not -inline $x *::delegate]} } -cleanup { interp delete $fresh -} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} +} -result {{} {::oo::SingletonInstance ::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::SingletonInstance ::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-1.22 {basic test of OO functionality: nested ownership destruction order} -setup { oo::class create parent } -body { -- cgit v0.12