Rewrite slots in C to get a performance boost. (backport)

5 files changed, 604 insertions, 170 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index a4c4da1..563832a 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -369,6 +369,10 @@ InitFoundation(
     TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
     TclNewLiteralStringObj(fPtr->myName, "my");
     TclNewLiteralStringObj(fPtr->mcdName, "::oo::MixinClassDelegates");
+    TclNewLiteralStringObj(fPtr->slotGetName, "Get");
+    TclNewLiteralStringObj(fPtr->slotSetName, "Set");
+    TclNewLiteralStringObj(fPtr->slotResolveName, "Resolve");
+    TclNewLiteralStringObj(fPtr->slotDefOpName, "--default-operation");
     Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
     Tcl_IncrRefCount(fPtr->constructorName);
     Tcl_IncrRefCount(fPtr->destructorName);
@@ -376,6 +380,10 @@ InitFoundation(
     Tcl_IncrRefCount(fPtr->defineName);
     Tcl_IncrRefCount(fPtr->myName);
     Tcl_IncrRefCount(fPtr->mcdName);
+    Tcl_IncrRefCount(fPtr->slotGetName);
+    Tcl_IncrRefCount(fPtr->slotSetName);
+    Tcl_IncrRefCount(fPtr->slotResolveName);
+    Tcl_IncrRefCount(fPtr->slotDefOpName);
 
     TclCreateObjCommandInNs(interp, "UnknownDefinition", fPtr->ooNs,
 	    TclOOUnknownDefinition, NULL, NULL);
@@ -619,6 +627,10 @@ KillFoundation(
     TclDecrRefCount(fPtr->defineName);
     TclDecrRefCount(fPtr->myName);
     TclDecrRefCount(fPtr->mcdName);
+    TclDecrRefCount(fPtr->slotGetName);
+    TclDecrRefCount(fPtr->slotSetName);
+    TclDecrRefCount(fPtr->slotResolveName);
+    TclDecrRefCount(fPtr->slotDefOpName);
     TclOODecrRefCount(fPtr->objectCls->thisPtr);
     TclOODecrRefCount(fPtr->classCls->thisPtr);
 
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 5b6de0e..d9a637a 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -39,15 +39,25 @@ typedef struct DeclaredSlot {
     const Tcl_MethodType resolverType;
 } DeclaredSlot;
 
-#define SLOT(name,getter,setter,resolver)				\
+#define SLOT(name,getter,setter,resolver) \
     {"::oo::" name,							\
-	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
+	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter",	\
 		    getter, NULL, NULL},				\
-	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
+	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter",	\
 		    setter, NULL, NULL},				\
-	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
+	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver",	\
 		    resolver, NULL, NULL}}
 
+typedef struct DeclaredSlotMethod {
+    const char *name;
+    int flags;
+    const Tcl_MethodType implType;
+} DeclaredSlotMethod;
+
+#define SLOT_METHOD(name,impl,flags) \
+    {name, flags, {TCL_OO_METHOD_VERSION_1,				\
+	    "core method: " name " slot", impl, NULL, NULL}}
+
 /*
  * A [string match] pattern used to determine if a method should be exported.
  */
@@ -78,6 +88,33 @@ static inline void	RecomputeClassCacheFlag(Object *oPtr);
 static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
 			    int useClass, Tcl_Obj *const fromPtr,
 			    Tcl_Obj *const toPtr);
+static int		Slot_Append(void *,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		Slot_AppendNew(void *,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		Slot_Clear(void *,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		Slot_Prepend(void *,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		Slot_Remove(void *,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		Slot_Resolve(void *,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		Slot_Set(void *,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		Slot_Unimplemented(void *,
+			    Tcl_Interp *interp, Tcl_ObjectContext,
+			    int, Tcl_Obj *const *);
+static int		Slot_Unknown(void *,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
 static int		ClassFilter_Get(void *clientData,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
@@ -175,6 +212,20 @@ static const DeclaredSlot slots[] = {
     {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
 };
 
+static const DeclaredSlotMethod slotMethods[] = {
+    SLOT_METHOD("Get",		Slot_Unimplemented, 0),
+    SLOT_METHOD("Resolve",	Slot_Resolve,	0),
+    SLOT_METHOD("Set",		Slot_Unimplemented, 0),
+    SLOT_METHOD("-append",	Slot_Append,	PUBLIC_METHOD),
+    SLOT_METHOD("-appendifnew",	Slot_AppendNew,	PUBLIC_METHOD),
+    SLOT_METHOD("-clear",	Slot_Clear,	PUBLIC_METHOD),
+    SLOT_METHOD("-prepend",	Slot_Prepend,	PUBLIC_METHOD),
+    SLOT_METHOD("-remove",	Slot_Remove,	PUBLIC_METHOD),
+    SLOT_METHOD("-set",		Slot_Set,	PUBLIC_METHOD),
+    SLOT_METHOD("unknown",	Slot_Unknown,	0),
+    {NULL, 0, {0, 0, 0, 0, 0}}
+};
+
 /*
  * How to build the in-namespace name of a private variable. This is a pattern
  * used with Tcl_ObjPrintf().
@@ -2397,50 +2448,560 @@ int
 TclOODefineSlots(
     Foundation *fPtr)
 {
-    const DeclaredSlot *slotInfoPtr;
     Tcl_Interp *interp = fPtr->interp;
-    Tcl_Obj *getName, *setName, *resolveName;
     Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class)
 	    fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0);
-    Class *slotCls;
+    Tcl_Class slotCls;
+    const DeclaredSlotMethod *smPtr;
+    const DeclaredSlot *slotPtr;
 
     if (object == NULL) {
 	return TCL_ERROR;
     }
-    slotCls = ((Object *) object)->classPtr;
+    slotCls = (Tcl_Class) ((Object *) object)->classPtr;
     if (slotCls == NULL) {
 	return TCL_ERROR;
     }
 
-    TclNewLiteralStringObj(getName, "Get");
-    TclNewLiteralStringObj(setName, "Set");
-    TclNewLiteralStringObj(resolveName, "Resolve");
-    for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
+    for (smPtr = slotMethods; smPtr->name; smPtr++) {
+	Tcl_Obj *name = Tcl_NewStringObj(smPtr->name, -1);
+	Tcl_NewMethod(interp, slotCls, name, smPtr->flags,
+		&smPtr->implType, NULL);
+	Tcl_BounceRefCount(name);
+    }
+
+    for (slotPtr = slots ; slotPtr->name ; slotPtr++) {
 	Tcl_Object slotObject = Tcl_NewObjectInstance(interp,
-		(Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE,
-		NULL, 0);
+		slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0);
 
 	if (slotObject == NULL) {
 	    continue;
 	}
-	TclNewInstanceMethod(interp, slotObject, getName, 0,
-		&slotInfoPtr->getterType, NULL);
-	TclNewInstanceMethod(interp, slotObject, setName, 0,
-		&slotInfoPtr->setterType, NULL);
-	if (slotInfoPtr->resolverType.callProc) {
-	    TclNewInstanceMethod(interp, slotObject, resolveName, 0,
-		    &slotInfoPtr->resolverType, NULL);
+	TclNewInstanceMethod(interp, slotObject, fPtr->slotGetName, 0,
+		&slotPtr->getterType, NULL);
+	TclNewInstanceMethod(interp, slotObject, fPtr->slotSetName, 0,
+		&slotPtr->setterType, NULL);
+	if (slotPtr->resolverType.callProc) {
+	    TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0,
+		    &slotPtr->resolverType, NULL);
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * CallSlotGet, CallSlotSet, CallSlotResolve, ResolveAll --
+ *
+ *	How to call the standard low-level methods of a slot.
+ *	ResolveAll is the lifting of CallSlotResolve to work over a whole
+ *	list of items.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+// Call [$slot Get] to retrieve the list of contents of the slot
+static inline Tcl_Obj *
+CallSlotGet(
+    Tcl_Interp *interp,
+    Object *slot)
+{
+    Tcl_Obj *getArgs[2];
+    int code;
+    
+    getArgs[0] = slot->fPtr->myName;
+    getArgs[1] = slot->fPtr->slotGetName;
+    code = TclOOPrivateObjectCmd(slot, interp, 2, getArgs);
+    if (code != TCL_OK) {
+	return NULL;
+    }
+    return Tcl_GetObjResult(interp);
+}
+
+// Call [$slot Set $list] to set the list of contents of the slot
+static inline int
+CallSlotSet(
+    Tcl_Interp *interp,
+    Object *slot,
+    Tcl_Obj *list)
+{
+    Tcl_Obj *setArgs[3];
+    setArgs[0] = slot->fPtr->myName;
+    setArgs[1] = slot->fPtr->slotSetName;
+    setArgs[2] = list;
+    return TclOOPrivateObjectCmd(slot, interp, 3, setArgs);
+}
+
+// Call [$slot Resolve $item] to convert a slot item into canonical form
+static inline Tcl_Obj *
+CallSlotResolve(
+    Tcl_Interp *interp,
+    Object *slot,
+    Tcl_Obj *item)
+{
+    Tcl_Obj *resolveArgs[3];
+    int code;
+
+    resolveArgs[0] = slot->fPtr->myName;
+    resolveArgs[1] = slot->fPtr->slotResolveName;
+    resolveArgs[2] = item;
+    code = TclOOPrivateObjectCmd(slot, interp, 3, resolveArgs);
+    if (code != TCL_OK) {
+	return NULL;
+    }
+    return Tcl_GetObjResult(interp);
+}
+
+static inline Tcl_Obj *
+ResolveAll(
+    Tcl_Interp *interp,
+    Object *slot,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp,
+	    sizeof(Tcl_Obj *) * objc);
+    Tcl_Obj *resolvedList;
+    int i;
+
+    for (i = 0; i < objc; i++) {
+	resolvedItems[i] = CallSlotResolve(interp, slot, objv[i]);
+	if (resolvedItems[i] == NULL) {
+	    for (int j = 0; j < i; j++) {
+		Tcl_DecrRefCount(resolvedItems[j]);
+	    }
+	    TclStackFree(interp, (void *) resolvedItems);
+	    return NULL;
+	}
+	Tcl_IncrRefCount(resolvedItems[i]);
+	Tcl_ResetResult(interp);
+    }
+    resolvedList = Tcl_NewListObj(objc, resolvedItems);
+    for (i = 0; i < objc; i++) {
+	TclDecrRefCount(resolvedItems[i]);
+    }
+    TclStackFree(interp, (void *) resolvedItems);
+    return resolvedList;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Append --
+ *
+ *	Implementation of the "-append" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_Append(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    int skip = Tcl_ObjectContextSkippedArgs(context), code;
+    Tcl_Obj *resolved, *list;
+
+    if (skip == objc) {
+	return TCL_OK;
+    }
+
+    // Resolve all values
+    resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+    if (resolved == NULL) {
+	return TCL_ERROR;
+    }
+
+    // Get slot contents; store in list
+    list = CallSlotGet(interp, oPtr);
+    if (list == NULL) {
+	Tcl_DecrRefCount(resolved);
+	return TCL_ERROR;
+    }
+    Tcl_IncrRefCount(list);
+    Tcl_ResetResult(interp);
+
+    // Append
+    if (Tcl_IsShared(list)) {
+	Tcl_Obj *dup = Tcl_DuplicateObj(list);
+	Tcl_IncrRefCount(dup);
+	Tcl_DecrRefCount(list);
+	list = dup;
+    }
+    if (Tcl_ListObjAppendList(interp, list, resolved) != TCL_OK) {
+	Tcl_DecrRefCount(list);
+	Tcl_DecrRefCount(resolved);
+	return TCL_ERROR;
+    }
+    Tcl_DecrRefCount(resolved);
+
+    // Set slot contents
+    code = CallSlotSet(interp, oPtr, list);
+    Tcl_DecrRefCount(list);
+    return code;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_AppendNew --
+ *
+ *	Implementation of the "-appendifnew" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_AppendNew(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    int skip = Tcl_ObjectContextSkippedArgs(context), code;
+    Tcl_Obj *resolved, *list, **listv;
+    Tcl_Size listc, i;
+    Tcl_HashTable unique;
+
+    if (skip == objc) {
+	return TCL_OK;
+    }
+
+    // Resolve all values
+    resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+    if (resolved == NULL) {
+	return TCL_ERROR;
+    }
+
+    // Get slot contents; store in list
+    list = CallSlotGet(interp, oPtr);
+    if (list == NULL) {
+	Tcl_DecrRefCount(resolved);
+	return TCL_ERROR;
+    }
+    Tcl_IncrRefCount(list);
+    Tcl_ResetResult(interp);
+
+    // Prepare a set of items in the list to set
+    if (TclListObjGetElements(interp, list, &listc, &listv) != TCL_OK) {
+	Tcl_DecrRefCount(list);
+	Tcl_DecrRefCount(resolved);
+	return TCL_ERROR;
+    }
+    Tcl_InitObjHashTable(&unique);
+    for (i=0 ; i<listc; i++) {
+	Tcl_CreateHashEntry(&unique, listv[i], NULL);
+    }
+
+    // Append the new items if they're not already there
+    if (Tcl_IsShared(list)) {
+	Tcl_Obj *dup = Tcl_DuplicateObj(list);
+	Tcl_IncrRefCount(dup);
+	Tcl_DecrRefCount(list);
+	list = dup;
+    }
+    TclListObjGetElements(NULL, resolved, &listc, &listv);
+    for (i=0 ; i<listc; i++) {
+	int isNew;
+	Tcl_CreateHashEntry(&unique, listv[i], &isNew);
+	if (isNew) {
+	    Tcl_ListObjAppendElement(interp, list, listv[i]);
+	}
+    }
+    Tcl_DecrRefCount(resolved);
+    Tcl_DeleteHashTable(&unique);
+
+    // Set slot contents
+    code = CallSlotSet(interp, oPtr, list);
+    Tcl_DecrRefCount(list);
+    return code;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Clear --
+ *
+ *	Implementation of the "-clear" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+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);
+    int skip = Tcl_ObjectContextSkippedArgs(context), code;
+    Tcl_Obj *list;
+
+    if (skip != objc) {
+	Tcl_WrongNumArgs(interp, skip, objv, NULL);
+	return TCL_ERROR;
+    }
+    list = Tcl_NewObj();
+    Tcl_IncrRefCount(list);
+    code = CallSlotSet(interp, oPtr, list);
+    Tcl_DecrRefCount(list);
+    return code;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Prepend --
+ *
+ *	Implementation of the "-prepend" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+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);
+    int skip = Tcl_ObjectContextSkippedArgs(context), code;
+    Tcl_Obj *list, *oldList;
+    if (skip == objc) {
+	return TCL_OK;
+    }
+
+    // Resolve all values
+    list = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+    if (list == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_IncrRefCount(list);
+
+    // Get slot contents and append to list
+    oldList = CallSlotGet(interp, oPtr);
+    if (oldList == NULL) {
+	Tcl_DecrRefCount(list);
+	return TCL_ERROR;
+    }
+    Tcl_ListObjAppendList(NULL, list, oldList);
+    Tcl_ResetResult(interp);
+
+    // Set slot contents
+    code = CallSlotSet(interp, oPtr, list);
+    Tcl_DecrRefCount(list);
+    return code;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Remove --
+ *
+ *	Implementation of the "-remove" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+static int
+Slot_Remove(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    int skip = Tcl_ObjectContextSkippedArgs(context), code;
+    Tcl_Size listc, i;
+    Tcl_Obj *resolved, *oldList, *newList, **listv;
+    Tcl_HashTable removeSet;
+
+    if (skip == objc) {
+	return TCL_OK;
+    }
+
+    // Resolve all values
+    resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+    if (resolved == NULL) {
+	return TCL_ERROR;
+    }
+
+    // Get slot contents; store in list
+    oldList = CallSlotGet(interp, oPtr);
+    if (oldList == NULL) {
+	Tcl_DecrRefCount(resolved);
+	return TCL_ERROR;
+    }
+    Tcl_IncrRefCount(oldList);
+    Tcl_ResetResult(interp);
+
+    // Prepare a set of items in the list to remove
+    TclListObjGetElements(NULL, resolved, &listc, &listv);
+    Tcl_InitObjHashTable(&removeSet);
+    for (i=0 ; i<listc; i++) {
+	Tcl_CreateHashEntry(&removeSet, listv[i], NULL);
+    }
+    Tcl_DecrRefCount(resolved);
+
+    // Append the new items from the old items if they're not in the remove set
+    if (TclListObjGetElements(interp, oldList, &listc, &listv) != TCL_OK) {
+	Tcl_DecrRefCount(oldList);
+	Tcl_DeleteHashTable(&removeSet);
+	return TCL_ERROR;
+    }
+    newList = Tcl_NewObj();
+    for (i=0 ; i<listc; i++) {
+	if (Tcl_FindHashEntry(&removeSet, listv[i]) == NULL) {
+	    Tcl_ListObjAppendElement(NULL, newList, listv[i]);
 	}
     }
-    Tcl_BounceRefCount(getName);
-    Tcl_BounceRefCount(setName);
-    Tcl_BounceRefCount(resolveName);
+    Tcl_DecrRefCount(oldList);
+    Tcl_DeleteHashTable(&removeSet);
+
+    // Set slot contents
+    Tcl_IncrRefCount(newList);
+    code = CallSlotSet(interp, oPtr, newList);
+    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 *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int skip = Tcl_ObjectContextSkippedArgs(context);
+    if (skip + 1 != objc) {
+	Tcl_WrongNumArgs(interp, skip, objv, "list");
+	return TCL_ERROR;
+    }
+    Tcl_SetObjResult(interp, objv[objc - 1]);
     return TCL_OK;
 }
 
 /*
  * ----------------------------------------------------------------------
  *
+ * Slot_Set --
+ *
+ *	Implementation of the "-set" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
+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);
+    int skip = Tcl_ObjectContextSkippedArgs(context), code;
+    Tcl_Obj *list;
+
+    // Resolve all values
+    if (skip == objc) {
+	list = Tcl_NewObj();
+    } else {
+	list = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+	if (list == NULL) {
+	    return TCL_ERROR;
+	}
+    }
+    Tcl_IncrRefCount(list);
+
+    // Set slot contents
+    code = CallSlotSet(interp, oPtr, list);
+    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 *),
+    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;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    int skip = Tcl_ObjectContextSkippedArgs(context), code;
+    if (skip >= objc) {
+	Tcl_Obj *args[2];
+	args[0] = oPtr->fPtr->myName;
+	args[1] = oPtr->fPtr->slotDefOpName;
+	return TclOOPrivateObjectCmd(oPtr, interp, 2, args);
+    } else if (TclGetString(objv[skip])[0] != '-') {
+	Tcl_Obj **args = (Tcl_Obj **) TclStackAlloc(interp,
+		sizeof(Tcl_Obj *) * (objc - skip + 2));
+	args[0] = oPtr->fPtr->myName;
+	args[1] = oPtr->fPtr->slotDefOpName;
+	memcpy(args+2, objv+skip, sizeof(Tcl_Obj*) * (objc - skip));
+	code = TclOOPrivateObjectCmd(oPtr, interp, objc - skip + 2, args);
+	TclStackFree(interp, args);
+	return code;
+    }
+    return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * ClassFilter_Get, ClassFilter_Set --
  *
  *	Implementation of the "filter" slot accessors of the "oo::define"
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 59a0cb6..bd11638 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -407,6 +407,10 @@ struct Foundation {
     Tcl_Obj *myName;		/* The "my" shared object. */
     Tcl_Obj *mcdName;		/* The shared object for calling the helper to
 				 * mix in class delegates. */
+    Tcl_Obj *slotGetName;	/* The "Get" name used by slots. */
+    Tcl_Obj *slotSetName;	/* The "Set" name used by slots. */
+    Tcl_Obj *slotResolveName;	/* The "Resolve" name used by slots. */
+    Tcl_Obj *slotDefOpName;	/* The "--default-operation" name used by slots. */
 };
 
 /*
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index a9b262c..80c4c68 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -117,62 +117,7 @@ static const char *tclOOSetupScript =
 "\t\t::tailcall forward $name myclass $name\n"
 "\t}\n"
 "\tdefine Slot {\n"
-"\t\tmethod Get -unexport {} {\n"
-"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
-"\t\t}\n"
-"\t\tmethod Set -unexport list {\n"
-"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
-"\t\t}\n"
-"\t\tmethod Resolve -unexport list {\n"
-"\t\t\treturn $list\n"
-"\t\t}\n"
-"\t\tmethod -set -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\ttailcall my Set $args\n"
-"\t\t}\n"
-"\t\tmethod -append -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
-"\t\t}\n"
-"\t\tmethod -appendifnew -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\tforeach a $args {\n"
-"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
-"\t\t\t\tif {$a ni $current} {\n"
-"\t\t\t\t\tlappend current $a\n"
-"\t\t\t\t}\n"
-"\t\t\t}\n"
-"\t\t\ttailcall my Set $current\n"
-"\t\t}\n"
-"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
-"\t\tmethod -prepend -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
-"\t\t}\n"
-"\t\tmethod -remove -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\ttailcall my Set [lmap val $current {\n"
-"\t\t\t\tif {$val in $args} continue else {set val}\n"
-"\t\t\t}]\n"
-"\t\t}\n"
 "\t\tforward --default-operation my -append\n"
-"\t\tmethod unknown -unexport {args} {\n"
-"\t\t\tset def --default-operation\n"
-"\t\t\tif {[llength $args] == 0} {\n"
-"\t\t\t\ttailcall my $def\n"
-"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
-"\t\t\t\ttailcall my $def {*}$args\n"
-"\t\t\t}\n"
-"\t\t\tnext {*}$args\n"
-"\t\t}\n"
 "\t\tunexport destroy\n"
 "\t}\n"
 "\tobjdefine define::superclass forward --default-operation my -set\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 542b711..e829fcf 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -198,103 +198,15 @@
     define Slot {
 	# ------------------------------------------------------------------
 	#
-	# Slot Get --
+	# Slot --default-operation --
 	#
-	#	Basic slot getter. Retrieves the contents of the slot.
-	#	Particular slots must provide concrete non-erroring
-	#	implementation.
+	#	If a slot can't figure out what method to call directly, it
+	#	uses --default-operation.
 	#
 	# ------------------------------------------------------------------
 
-	method Get -unexport {} {
-	    return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
-	}
-
-	# ------------------------------------------------------------------
-	#
-	# Slot Set --
-	#
-	#	Basic slot setter. Sets the contents of the slot.  Particular
-	#	slots must provide concrete non-erroring implementation.
-	#
-	# ------------------------------------------------------------------
-
-	method Set -unexport list {
-	    return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
-	}
-
-	# ------------------------------------------------------------------
-	#
-	# Slot Resolve --
-	#
-	#	Helper that lets a slot convert a list of arguments of a
-	#	particular type to their canonical forms. Defaults to doing
-	#	nothing (suitable for simple strings).
-	#
-	# ------------------------------------------------------------------
-
-	method Resolve -unexport list {
-	    return $list
-	}
-
-	# ------------------------------------------------------------------
-	#
-	# Slot -set, -append, -clear, --default-operation --
-	#
-	#	Standard public slot operations. If a slot can't figure out
-	#	what method to call directly, it uses --default-operation.
-	#
-	# ------------------------------------------------------------------
-
-	method -set -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    tailcall my Set $args
-	}
-	method -append -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    set current [uplevel 1 [list $my Get]]
-	    tailcall my Set [list {*}$current {*}$args]
-	}
-	method -appendifnew -export args {
-	    set my [namespace which my]
-	    set current [uplevel 1 [list $my Get]]
-	    foreach a $args {
-		set a [uplevel 1 [list $my Resolve $a]]
-		if {$a ni $current} {
-		    lappend current $a
-		}
-	    }
-	    tailcall my Set $current
-	}
-	method -clear -export {} {tailcall my Set {}}
-	method -prepend -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    set current [uplevel 1 [list $my Get]]
-	    tailcall my Set [list {*}$args {*}$current]
-	}
-	method -remove -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    set current [uplevel 1 [list $my Get]]
-	    tailcall my Set [lmap val $current {
-		if {$val in $args} continue else {set val}
-	    }]
-	}
-
 	# Default handling
 	forward --default-operation my -append
-	method unknown -unexport {args} {
-	    set def --default-operation
-	    if {[llength $args] == 0} {
-		tailcall my $def
-	    } elseif {![string match -* [lindex $args 0]]} {
-		tailcall my $def {*}$args
-	    }
-	    next {*}$args
-	}
 
 	# Hide destroy
 	unexport destroy