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