Implementation of TIP 516

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 ; i<cmdc ; i++) {
+	Class *clsPtr = GetClassInOuterContext(interp, cmdv[i],
+		"USER SHOULD NOT SEE THIS MESSAGE");
+	if (clsPtr == NULL) {
+	    cmdv2[i] = cmdv[i];
+	    mustReset = 1;
+	} else {
+	    cmdv2[i] = TclOOObjectName(interp, clsPtr->thisPtr);
+	}
+    }
+
+    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 {