From 0d73b8a7c0c6e90b6c3ed7fcde7b69916b23bedd Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
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 ; 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 {
-- 
cgit v0.12


From 4f178616784e701a7b93586556ffbf292dd173aa Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 10 Sep 2018 08:33:11 +0000
Subject: Tests and docs

---
 doc/define.n  | 64 +++++++++++++++++++++++++++++++++++++++++++++++----
 tests/oo.test | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-----
 2 files changed, 128 insertions(+), 10 deletions(-)

diff --git a/doc/define.n b/doc/define.n
index 6353d00..1030096 100644
--- a/doc/define.n
+++ b/doc/define.n
@@ -426,7 +426,7 @@ Some of the configurable definitions of a class or object are \fIslotted
 definitions\fR. This means that the configuration is implemented by a slot
 object, that is an instance of the class \fBoo::Slot\fR, which manages a list
 of values (class names, variable names, etc.) that comprises the contents of
-the slot. The class defines three operations (as methods) that may be done on
+the slot. The class defines five operations (as methods) that may be done on
 the slot:
 .TP
 \fIslot\fR \fB\-append\fR ?\fImember ...\fR?
@@ -437,6 +437,16 @@ This appends the given \fImember\fR elements to the slot definition.
 .
 This sets the slot definition to the empty list.
 .TP
+\fIslot\fR \fB\-prepend\fR ?\fImember ...\fR?
+.VS TIP516
+This prepends the given \fImember\fR elements to the slot definition.
+.VE TIP516
+.TP
+\fIslot\fR \fB\-remove\fR ?\fImember ...\fR?
+.VS TIP516
+This removes the given \fImember\fR elements from the slot definition.
+.VE TIP516
+.TP
 \fIslot\fR \fB\-set\fR ?\fImember ...\fR?
 .
 This replaces the slot definition with the given \fImember\fR elements.
@@ -454,15 +464,53 @@ and these methods which provide the implementation interface:
 .TP
 \fIslot\fR \fBGet\fR
 .
-Returns a list that is the current contents of the slot. This method must
+Returns a list that is the current contents of the slot, but does not modify
+the slot. This method must always be called from a stack frame created by a
+call to \fBoo::define\fR or \fBoo::objdefine\fR. This method \fIshould not\fR
+return an error unless it is called from outside a definition context or with
+the wrong number of arguments.
+.RS
+.PP
+.VS TIP516
+The elements of the list should be fully resolved, if that is a meaningful
+concept to the slot.
+.VE TIP516
+.RE
+.TP
+\fIslot\fR \fBResolve\fR \fIelementList\fR
+.VS TIP516
+Returns a list that is the elements of \fIelementList\fR with a resolution
+operation applied to each of them, but does not modify the slot. For slots of
+simple strings, this is an operation that does nothing. For slots of classes,
+this maps each class name to its fully qualified class name.  This method must
 always be called from a stack frame created by a call to \fBoo::define\fR or
-\fBoo::objdefine\fR.
+\fBoo::objdefine\fR.  This method \fIshould not\fR return an error unless it
+is called from outside a definition context or with the wrong number of
+arguments.
+.RS
+.PP
+Implementations \fIshould not\fR reorder or filter elements in this operation;
+uniqueness and ordering constraints should be enforced in the \fBSet\fR
+method. This is because this method is not normally presented with the full
+contents of the slot (except via the \fB\-set\fR slot operation).
+.RE
+.VE TIP516
 .TP
 \fIslot\fR \fBSet \fIelementList\fR
 .
 Sets the contents of the slot to the list \fIelementList\fR and returns the
 empty string. This method must always be called from a stack frame created by
-a call to \fBoo::define\fR or \fBoo::objdefine\fR.
+a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method may return an
+error if it rejects the change to the slot contents (e.g., because of invalid
+values) as well as if it is called from outside a definition context or with
+the wrong number of arguments.
+.RS
+.PP
+This method \fImay\fR reorder and filter the elements if this is necessary in
+order to satisfy the underlying constraints of the slot. (For example, slots
+of classes enforce a uniqueness constraint that places each element in the
+earliest location in the slot that it can.)
+.RE
 .PP
 The implementation of these methods is slot-dependent (and responsible for
 accessing the correct part of the class or object definition). Slots also have
@@ -470,6 +518,14 @@ an unknown method handler to tie all these pieces together, and they hide
 their \fBdestroy\fR method so that it is not invoked inadvertently. It is
 \fIrecommended\fR that any user changes to the slot mechanism be restricted to
 defining new operations whose names start with a hyphen.
+.PP
+.VS TIP516
+Most slot operations will initially \fBResolve\fR their argument list, combine
+it with the results of the \fBGet\fR method, and then \fBSet\fR the result.
+Some operations omit one or both of the first two steps; omitting the third
+would result in an idempotent read-only operation (but the standard mechanism
+for reading from slots is via \fBinfo class\fR and \fBinfo object\fR).
+.VE TIP516
 .SH EXAMPLES
 This example demonstrates how to use both forms of the \fBoo::define\fR and
 \fBoo::objdefine\fR commands (they work in the same way), as well as
diff --git a/tests/oo.test b/tests/oo.test
index 2dc9e2a..1093f8d 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -13,13 +13,11 @@ if {"::tcltest" in [namespace children]} {
     namespace import -force ::tcltest::*
 }
 
-
 # The foundational objects oo::object and oo::class are sensitive to reference
 # counting errors and are deallocated only when an interp is deleted, so in
 # this test suite, interp creation and interp deletion are often used in
 # leaktests in order to leverage this sensitivity.
 
-
 testConstraint memory [llength [info commands memory]]
 if {[testConstraint memory]} {
     proc getbytes {} {
@@ -3838,6 +3836,11 @@ proc SampleSlotSetup script {
 		lappend ops [info level] Set $lst
 		return
 	    }
+	    method Resolve {lst} {
+		variable ops
+		lappend ops [info level] Resolve $lst
+		return $lst
+	    }
 	}
     }
     append script0 \n$script
@@ -3872,7 +3875,7 @@ test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
 	[sampleSlot contents] [sampleSlot ops]
 } -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+}] -result {0 {} {a b c g h i} {1 Resolve {g h i} 1 Get 1 Set {a b c g h i}}}
 test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
     SampleSlot create sampleSlot
 }] -body {
@@ -3880,7 +3883,7 @@ test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
 	[sampleSlot contents] [sampleSlot ops]
 } -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-}] -result {0 {} {d e f} {1 Set {d e f}}}
+}] -result {0 {} {d e f} {1 Resolve {d e f} 1 Set {d e f}}}
 test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
     SampleSlot create sampleSlot
 }] -body {
@@ -3888,7 +3891,23 @@ test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
 	[sampleSlot contents] [sampleSlot ops]
 } -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
+}] -result {0 {} {} {d e f g h i} {1 Resolve {d e f} 1 Set {d e f} 1 Resolve {g h i} 1 Get 1 Set {d e f g h i}}}
+test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
+    SampleSlot create sampleSlot
+}] -body {
+    list [info level] [sampleSlot -prepend g h i] \
+	[sampleSlot contents] [sampleSlot ops]
+} -cleanup [SampleSlotCleanup {
+    rename sampleSlot {}
+}] -result {0 {} {g h i a b c} {1 Resolve {g h i} 1 Get 1 Set {g h i a b c}}}
+test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
+    SampleSlot create sampleSlot
+}] -body {
+    list [info level] [sampleSlot -remove c a] \
+	[sampleSlot contents] [sampleSlot ops]
+} -cleanup [SampleSlotCleanup {
+    rename sampleSlot {}
+}] -result {0 {} b {1 Resolve {c a} 1 Get 1 Set b}}
 
 test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
     set s [SampleSlot new]
@@ -3911,7 +3930,7 @@ test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
     list [$s destroy; $s unknown] [$s contents] [$s ops]
 } -cleanup [SampleSlotCleanup {
     rename $s {}
-}] -result {{} unknown {1 Set destroy 1 Set unknown}}
+}] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}}
 test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
     set s [SampleSlot new]
 }] -body {
@@ -3969,6 +3988,49 @@ test oo-34.8 {TIP 380: slots - presence} {
 test oo-34.9 {TIP 380: slots - presence} {
     getMethods oo::objdefine::variable
 } {{-append -clear -prepend -remove -set} {Get Set}}
+test oo-34.10 {TIP 516: slots - resolution} -setup {
+    oo::class create parent
+    set result {}
+    oo::class create 516a { superclass parent }
+    oo::class create 516b { superclass parent }
+    oo::class create 516c { superclass parent }
+    namespace eval 516test {
+	oo::class create 516a { superclass parent }
+	oo::class create 516b { superclass parent }
+	oo::class create 516c { superclass parent }
+    }
+} -body {
+    # Must find the right classes when making the mixin
+    namespace eval 516test {
+	oo::define 516a {
+	    mixin 516b 516c
+	}
+    }
+    lappend result [info class mixin 516test::516a]
+    # Must not remove class with just simple name match 
+    oo::define 516test::516a {
+	mixin -remove 516b
+    }
+    lappend result [info class mixin 516test::516a]
+    # Must remove class with resolved name match
+    oo::define 516test::516a {
+	mixin -remove 516test::516c
+    }
+    lappend result [info class mixin 516test::516a]
+    # Must remove class with resolved name match even after renaming, but only
+    # with the renamed name; it is a slot of classes, not strings!
+    rename 516test::516b 516test::516d
+    oo::define 516test::516a {
+	mixin -remove 516test::516b
+    }
+    lappend result [info class mixin 516test::516a]
+    oo::define 516test::516a {
+	mixin -remove 516test::516d
+    }
+    lappend result [info class mixin 516test::516a]
+} -cleanup {
+    parent destroy
+} -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}}
 
 test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
     oo::class create fruit {
-- 
cgit v0.12


From 90e3bdc291f94c2e3ff1c4e5b0edb6e203966147 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 11 Sep 2018 07:44:04 +0000
Subject: Simplify the slot resolution protocol

---
 doc/define.n              | 25 +++++++++--------
 generic/tclOODefineCmds.c | 68 ++++++++++++++++++++++++-----------------------
 generic/tclOOScript.h     |  9 ++++---
 generic/tclOOScript.tcl   |  9 ++++---
 tests/oo.test             | 10 +++----
 5 files changed, 62 insertions(+), 59 deletions(-)

diff --git a/doc/define.n b/doc/define.n
index 1030096..883d5fa 100644
--- a/doc/define.n
+++ b/doc/define.n
@@ -477,22 +477,21 @@ concept to the slot.
 .VE TIP516
 .RE
 .TP
-\fIslot\fR \fBResolve\fR \fIelementList\fR
+\fIslot\fR \fBResolve\fR \fIslotElement\fR
 .VS TIP516
-Returns a list that is the elements of \fIelementList\fR with a resolution
-operation applied to each of them, but does not modify the slot. For slots of
-simple strings, this is an operation that does nothing. For slots of classes,
-this maps each class name to its fully qualified class name.  This method must
-always be called from a stack frame created by a call to \fBoo::define\fR or
-\fBoo::objdefine\fR.  This method \fIshould not\fR return an error unless it
-is called from outside a definition context or with the wrong number of
-arguments.
+Returns \fIslotElement\fR with a resolution operation applied to it, but does
+not modify the slot. For slots of simple strings, this is an operation that
+does nothing, whereas for slots of classes, this maps a class name to its
+fully-qualified class name.  This method must always be called from a stack
+frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR.  This
+method \fIshould not\fR return an error unless it is called from outside a
+definition context or with the wrong number of arguments; unresolvable
+arguments should be returned as is (as not all slot operations strictly
+require that values are resolvable to work).
 .RS
 .PP
-Implementations \fIshould not\fR reorder or filter elements in this operation;
-uniqueness and ordering constraints should be enforced in the \fBSet\fR
-method. This is because this method is not normally presented with the full
-contents of the slot (except via the \fB\-set\fR slot operation).
+Implementations \fIshould not\fR enforce uniqueness and ordering constraints
+in this method; that is the responsibility of the \fBSet\fR method.
 .RE
 .VE TIP516
 .TP
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index e4a30bb..b68cb0c 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -112,7 +112,7 @@ 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,
+static int		ResolveClass(ClientData clientData,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
 
@@ -122,11 +122,11 @@ static int		ResolveClasses(ClientData clientData,
 
 static const struct DeclaredSlot slots[] = {
     SLOT("define::filter",      ClassFilterGet, ClassFilterSet, NULL),
-    SLOT("define::mixin",       ClassMixinGet,  ClassMixinSet, ResolveClasses),
-    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet, ResolveClasses),
+    SLOT("define::mixin",       ClassMixinGet,  ClassMixinSet, ResolveClass),
+    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet, ResolveClass),
     SLOT("define::variable",    ClassVarsGet,   ClassVarsSet, NULL),
     SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet, NULL),
-    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet, ResolveClasses),
+    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet, ResolveClass),
     SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet, NULL),
     {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
 };
@@ -2827,54 +2827,56 @@ ObjVarsSet(
     return TCL_OK;
 }
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ResolveClass --
+ *
+ *	Implementation of the "Resolve" support method for some slots (those
+ *	that are slots around a list of classes). This resolves possible class
+ *	names to their fully-qualified names if possible.
+ *
+ * ----------------------------------------------------------------------
+ */
 
 static int
-ResolveClasses(
+ResolveClass(
     ClientData clientData,
     Tcl_Interp *interp,
     Tcl_ObjectContext context,
     int objc,
     Tcl_Obj *const *objv)
 {
+    int idx = Tcl_ObjectContextSkippedArgs(context);
     Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
-    int cmdc, i, mustReset = 0;
-    Tcl_Obj **cmdv, **cmdv2;
+    Class *clsPtr;
 
-    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
-	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
-		"list");
-	return TCL_ERROR;
-    } else if (oPtr == NULL) {
+    /*
+     * Check if were called wrongly. The definition context isn't used...
+     * except that GetClassInOuterContext() assumes that it is there.
+     */
+
+    if (oPtr == NULL) {
 	return TCL_ERROR;
-    }
-    objv += Tcl_ObjectContextSkippedArgs(context);
-    if (Tcl_ListObjGetElements(interp, objv[0], &cmdc,
-	    &cmdv) != TCL_OK) {
+    } else if (objc != idx + 1) {
+	Tcl_WrongNumArgs(interp, idx, objv, "slotElement");
 	return TCL_ERROR;
     }
 
-    cmdv2 = TclStackAlloc(interp, sizeof(Tcl_Obj *) * cmdc);
-
     /*
-     * Resolve each o
+     * Resolve the class if possible. If not, remove any resolution error and
+     * return what we've got anyway as the failure might not be fatal overall.
      */
 
-    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) {
+    clsPtr = GetClassInOuterContext(interp, objv[idx],
+	    "USER SHOULD NOT SEE THIS MESSAGE");
+    if (clsPtr == NULL) {
 	Tcl_ResetResult(interp);
+	Tcl_SetObjResult(interp, objv[idx]);
+    } else {
+	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
     }
-    Tcl_SetObjResult(interp, Tcl_NewListObj(cmdc, cmdv2));
-    TclStackFree(interp, cmdv2);
+
     return TCL_OK;
 }
 
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 5627bf8..2213ce3 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -151,25 +151,26 @@ static const char *tclOOSetupScript =
 "\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\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 args {\n"
 "\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\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 -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 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 args {\n"
 "\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\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"
diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl
index 30af82a..a48eab5 100644
--- a/generic/tclOOScript.tcl
+++ b/generic/tclOOScript.tcl
@@ -298,25 +298,26 @@
 	# ------------------------------------------------------------------
 
 	method -set args {
-	    set args [uplevel 1 [list [namespace which my] Resolve $args]]
+	    set my [namespace which my]
+	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
 	    tailcall my Set $args
 	}
 	method -append args {
 	    set my [namespace which my]
-	    set args [uplevel 1 [list $my Resolve $args]]
+	    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 -clear {} {tailcall my Set {}}
 	method -prepend args {
 	    set my [namespace which my]
-	    set args [uplevel 1 [list $my Resolve $args]]
+	    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 args {
 	    set my [namespace which my]
-	    set args [uplevel 1 [list $my Resolve $args]]
+	    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}
diff --git a/tests/oo.test b/tests/oo.test
index 1093f8d..033daf5 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -3875,7 +3875,7 @@ test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
 	[sampleSlot contents] [sampleSlot ops]
 } -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-}] -result {0 {} {a b c g h i} {1 Resolve {g h i} 1 Get 1 Set {a b c g h i}}}
+}] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}}
 test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
     SampleSlot create sampleSlot
 }] -body {
@@ -3883,7 +3883,7 @@ test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
 	[sampleSlot contents] [sampleSlot ops]
 } -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-}] -result {0 {} {d e f} {1 Resolve {d e f} 1 Set {d e f}}}
+}] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}}
 test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
     SampleSlot create sampleSlot
 }] -body {
@@ -3891,7 +3891,7 @@ test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
 	[sampleSlot contents] [sampleSlot ops]
 } -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-}] -result {0 {} {} {d e f g h i} {1 Resolve {d e f} 1 Set {d e f} 1 Resolve {g h i} 1 Get 1 Set {d e f g h i}}}
+}] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}}
 test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
     SampleSlot create sampleSlot
 }] -body {
@@ -3899,7 +3899,7 @@ test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
 	[sampleSlot contents] [sampleSlot ops]
 } -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-}] -result {0 {} {g h i a b c} {1 Resolve {g h i} 1 Get 1 Set {g h i a b c}}}
+}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}}
 test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
     SampleSlot create sampleSlot
 }] -body {
@@ -3907,7 +3907,7 @@ test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
 	[sampleSlot contents] [sampleSlot ops]
 } -cleanup [SampleSlotCleanup {
     rename sampleSlot {}
-}] -result {0 {} b {1 Resolve {c a} 1 Get 1 Set b}}
+}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}}
 
 test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
     set s [SampleSlot new]
-- 
cgit v0.12