From 0d73b8a7c0c6e90b6c3ed7fcde7b69916b23bedd Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 8 Sep 2018 12:52:06 +0000 Subject: Implementation of TIP 516 --- generic/tclOODefineCmds.c | 86 +++++++++++++++++++++++++++++++++++++++++------ generic/tclOOScript.h | 28 +++++++++++++-- generic/tclOOScript.tcl | 39 +++++++++++++++++++-- tests/oo.test | 16 ++++----- 4 files changed, 144 insertions(+), 25 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 3c27236..e4a30bb 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -37,14 +37,17 @@ struct DeclaredSlot { const char *name; const Tcl_MethodType getterType; const Tcl_MethodType setterType; + const Tcl_MethodType resolverType; }; -#define SLOT(name,getter,setter) \ +#define SLOT(name,getter,setter,resolver) \ {"::oo::" name, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ getter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ - setter, NULL, NULL}} + setter, NULL, NULL}, \ + {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ + resolver, NULL, NULL}} /* * Forward declarations. @@ -109,20 +112,23 @@ static int ObjVarsGet(ClientData clientData, static int ObjVarsSet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); +static int ResolveClasses(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); /* * Now define the slots used in declarations. */ static const struct DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilterGet, ClassFilterSet), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet), - SLOT("define::variable", ClassVarsGet, ClassVarsSet), - SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet), - SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet), - SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} + SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), + SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClasses), + SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClasses), + SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL), + SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), + SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClasses), + SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), + {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; /* @@ -2063,6 +2069,7 @@ TclOODefineSlots( const struct DeclaredSlot *slotInfoPtr; Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); + Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1); Class *slotCls; slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) @@ -2072,9 +2079,10 @@ TclOODefineSlots( } Tcl_IncrRefCount(getName); Tcl_IncrRefCount(setName); + Tcl_IncrRefCount(resolveName); for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0); + (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); if (slotObject == NULL) { continue; @@ -2083,9 +2091,14 @@ TclOODefineSlots( &slotInfoPtr->getterType, NULL); Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, &slotInfoPtr->setterType, NULL); + if (slotInfoPtr->resolverType.callProc) { + Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, + &slotInfoPtr->resolverType, NULL); + } } Tcl_DecrRefCount(getName); Tcl_DecrRefCount(setName); + Tcl_DecrRefCount(resolveName); return TCL_OK; } @@ -2814,6 +2827,57 @@ ObjVarsSet( return TCL_OK; } + +static int +ResolveClasses( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int cmdc, i, mustReset = 0; + Tcl_Obj **cmdv, **cmdv2; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "list"); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + if (Tcl_ListObjGetElements(interp, objv[0], &cmdc, + &cmdv) != TCL_OK) { + return TCL_ERROR; + } + + cmdv2 = TclStackAlloc(interp, sizeof(Tcl_Obj *) * cmdc); + + /* + * Resolve each o + */ + + for (i=0 ; ithisPtr); + } + } + + if (mustReset) { + Tcl_ResetResult(interp); + } + Tcl_SetObjResult(interp, Tcl_NewListObj(cmdc, cmdv2)); + TclStackFree(interp, cmdv2); + return TCL_OK; +} + /* * Local Variables: * mode: c diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index e63bd86..5627bf8 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -147,12 +147,34 @@ static const char *tclOOSetupScript = "\t\tmethod Set list {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" -"\t\tmethod -set args {tailcall my Set $args}\n" +"\t\tmethod Resolve list {\n" +"\t\t\treturn $list\n" +"\t\t}\n" +"\t\tmethod -set args {\n" +"\t\t\tset args [uplevel 1 [list [namespace which my] Resolve $args]]\n" +"\t\t\ttailcall my Set $args\n" +"\t\t}\n" "\t\tmethod -append args {\n" -"\t\t\tset current [uplevel 1 [list [namespace which my] Get]]\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\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 -clear {} {tailcall my Set {}}\n" +"\t\tmethod -prepend args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\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 args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\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 {args} {\n" "\t\t\tset def --default-operation\n" @@ -163,7 +185,7 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t\tnext {*}$args\n" "\t\t}\n" -"\t\texport -set -append -clear\n" +"\t\texport -set -append -clear -prepend -remove\n" "\t\tunexport unknown destroy\n" "\t}\n" "\tobjdefine define::superclass forward --default-operation my -set\n" diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index d3706ce..30af82a 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -276,6 +276,20 @@ # ------------------------------------------------------------------ # + # 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 list { + return $list + } + + # ------------------------------------------------------------------ + # # Slot -set, -append, -clear, --default-operation -- # # Standard public slot operations. If a slot can't figure out @@ -283,12 +297,31 @@ # # ------------------------------------------------------------------ - method -set args {tailcall my Set $args} + method -set args { + set args [uplevel 1 [list [namespace which my] Resolve $args]] + tailcall my Set $args + } method -append args { - set current [uplevel 1 [list [namespace which my] Get]] + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$current {*}$args] } method -clear {} {tailcall my Set {}} + method -prepend args { + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + set current [uplevel 1 [list $my Get]] + tailcall my Set [list {*}$args {*}$current] + } + method -remove args { + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + 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 @@ -303,7 +336,7 @@ } # Set up what is exported and what isn't - export -set -append -clear + export -set -append -clear -prepend -remove unexport unknown destroy } diff --git a/tests/oo.test b/tests/oo.test index a303309..2dc9e2a 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3920,7 +3920,7 @@ test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { } -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} }] -result \ - {unknown method "-grill": must be -append, -clear, -set, contents or ops} + {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] @@ -3950,25 +3950,25 @@ proc getMethods obj { } test oo-34.3 {TIP 380: slots - presence} { getMethods oo::define::filter -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.4 {TIP 380: slots - presence} { getMethods oo::define::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.5 {TIP 380: slots - presence} { getMethods oo::define::superclass -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.6 {TIP 380: slots - presence} { getMethods oo::define::variable -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.7 {TIP 380: slots - presence} { getMethods oo::objdefine::filter -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.8 {TIP 380: slots - presence} { getMethods oo::objdefine::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { -- cgit v0.12