More backported initialisation acceleration of TclOO

8 files changed, 763 insertions, 469 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 0da8b7f..2e84bf8 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -51,31 +51,31 @@ static const struct DefineCommands {
     Tcl_ObjCmdProc *objProc;
     int flag;
 } defineCmds[] = {
-    {"classmethod", TclOODefineClassMethodObjCmd, 0},
-    {"constructor", TclOODefineConstructorObjCmd, 0},
+    {"classmethod",	TclOODefineClassMethodObjCmd, 0},
+    {"constructor",	TclOODefineConstructorObjCmd, 0},
     {"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
-    {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
-    {"destructor", TclOODefineDestructorObjCmd, 0},
-    {"export", TclOODefineExportObjCmd, 0},
-    {"forward", TclOODefineForwardObjCmd, 0},
-    {"initialise", TclOODefineInitialiseObjCmd, 0},
-    {"initialize", TclOODefineInitialiseObjCmd, 0},
-    {"method", TclOODefineMethodObjCmd, 0},
-    {"private", TclOODefinePrivateObjCmd, 0},
-    {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
-    {"self", TclOODefineSelfObjCmd, 0},
-    {"unexport", TclOODefineUnexportObjCmd, 0},
+    {"deletemethod",	TclOODefineDeleteMethodObjCmd, 0},
+    {"destructor",	TclOODefineDestructorObjCmd, 0},
+    {"export",		TclOODefineExportObjCmd, 0},
+    {"forward",		TclOODefineForwardObjCmd, 0},
+    {"initialise",	TclOODefineInitialiseObjCmd, 0},
+    {"initialize",	TclOODefineInitialiseObjCmd, 0},
+    {"method",		TclOODefineMethodObjCmd, 0},
+    {"private",		TclOODefinePrivateObjCmd, 0},
+    {"renamemethod",	TclOODefineRenameMethodObjCmd, 0},
+    {"self",		TclOODefineSelfObjCmd, 0},
+    {"unexport",	TclOODefineUnexportObjCmd, 0},
     {NULL, NULL, 0}
 }, objdefCmds[] = {
-    {"class", TclOODefineClassObjCmd, 1},
-    {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
-    {"export", TclOODefineExportObjCmd, 1},
-    {"forward", TclOODefineForwardObjCmd, 1},
-    {"method", TclOODefineMethodObjCmd, 1},
-    {"private", TclOODefinePrivateObjCmd, 1},
-    {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
-    {"self", TclOODefineObjSelfObjCmd, 0},
-    {"unexport", TclOODefineUnexportObjCmd, 1},
+    {"class",		TclOODefineClassObjCmd, 1},
+    {"deletemethod",	TclOODefineDeleteMethodObjCmd, 1},
+    {"export",		TclOODefineExportObjCmd, 1},
+    {"forward",		TclOODefineForwardObjCmd, 1},
+    {"method",		TclOODefineMethodObjCmd, 1},
+    {"private",		TclOODefinePrivateObjCmd, 1},
+    {"renamemethod",	TclOODefineRenameMethodObjCmd, 1},
+    {"self",		TclOODefineObjSelfObjCmd, 0},
+    {"unexport",	TclOODefineUnexportObjCmd, 1},
     {NULL, NULL, 0}
 };
 
@@ -96,7 +96,7 @@ static int		CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
 			    Method **newMPtrPtr);
 static int		CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
 			    Method *mPtr, Tcl_Obj *namePtr);
-static void		DeletedHelpersNamespace(void *clientData);
+static Tcl_NamespaceDeleteProc	DeletedHelpersNamespace;
 static Tcl_NRPostProc	FinalizeAlloc;
 static Tcl_NRPostProc	FinalizeNext;
 static Tcl_NRPostProc	FinalizeObjectCall;
@@ -105,23 +105,20 @@ static void		InitClassSystemRoots(Tcl_Interp *interp,
 			    Foundation *fPtr);
 static int		InitFoundation(Tcl_Interp *interp);
 static Tcl_InterpDeleteProc	KillFoundation;
-static void		MyDeleted(void *clientData);
-static void		ObjectNamespaceDeleted(void *clientData);
+static void		MakeAdditionalClasses(Foundation *fPtr,
+			    Tcl_Namespace *defineNs,
+			    Tcl_Namespace *objDefineNs);
+static Tcl_CmdDeleteProc	MyDeleted;
+static Tcl_NamespaceDeleteProc	ObjectNamespaceDeleted;
 static Tcl_CommandTraceProc	ObjectRenamedTrace;
 static inline void	RemoveClass(Class **list, size_t num, size_t idx);
 static inline void	RemoveObject(Object **list, size_t num, size_t idx);
 static inline void	SquelchCachedName(Object *oPtr);
 
-static int		PublicNRObjectCmd(void *clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const *objv);
-static int		PrivateNRObjectCmd(void *clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const *objv);
-static int		MyClassNRObjCmd(void *clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const *objv);
-static void		MyClassDeleted(void *clientData);
+static Tcl_ObjCmdProc	PublicNRObjectCmd;
+static Tcl_ObjCmdProc	PrivateNRObjectCmd;
+static Tcl_ObjCmdProc	MyClassNRObjCmd;
+static Tcl_CmdDeleteProc	MyClassDeleted;
 
 /*
  * Methods in the oo::object and oo::class classes. First, we define a helper
@@ -143,6 +140,7 @@ static const DeclaredClassMethod objMethods[] = {
     DCM("varname", 0,	TclOO_Object_VarName),
     {NULL, 0, {0, NULL, NULL, NULL, NULL}}
 }, clsMethods[] = {
+    DCM("<cloned>", 0,	TclOO_Class_Cloned),
     DCM("create", 1,	TclOO_Class_Create),
     DCM("new", 1,	TclOO_Class_New),
     DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
@@ -150,6 +148,13 @@ static const DeclaredClassMethod objMethods[] = {
 }, cfgMethods[] = {
     DCM("configure", 1, TclOO_Configurable_Configure),
     {NULL, 0, {0, NULL, NULL, NULL, NULL}}
+}, singletonMethods[] = {
+    DCM("new", 1,	TclOO_Singleton_New),
+    {NULL, 0, {0, NULL, NULL, NULL, NULL}}
+}, singletonInstanceMethods[] = {
+    DCM("<cloned>", 0,	TclOO_SingletonInstance_Cloned),
+    DCM("destroy", 1,	TclOO_SingletonInstance_Destroy),
+    {NULL, 0, {0, NULL, NULL, NULL, NULL}}
 };
 
 /*
@@ -163,6 +168,16 @@ static const Tcl_MethodType classConstructor = {
 };
 
 /*
+ * And the oo::configurable constructor...
+ */
+
+static const Tcl_MethodType configurableConstructor = {
+    TCL_OO_METHOD_VERSION_CURRENT,
+    "oo::configurable constructor",
+    TclOO_Configurable_Constructor, NULL, NULL
+};
+
+/*
  * Scripted parts of TclOO. First, the main script (cannot be outside this
  * file).
  */
@@ -172,8 +187,9 @@ static const char initScript[] =
 "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
 #endif
 "package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};"
-"namespace eval ::oo { variable version " TCLOO_VERSION " };"
-"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
+"namespace eval ::oo {"
+"    variable version " TCLOO_VERSION " patchlevel " TCLOO_PATCHLEVEL
+"};";
 /* "tcl_findLibrary tcloo $oo::version $oo::version" */
 /* " tcloo.tcl OO_LIBRARY oo::library;"; */
 
@@ -484,25 +500,7 @@ InitFoundation(
 	return TCL_ERROR;
     }
 
-    /*
-     * Make the configurable class and install its standard defined method.
-     */
-
-    Tcl_Object cfgCls = Tcl_NewObjectInstance(interp,
-	    (Tcl_Class) fPtr->classCls, "::oo::configuresupport::configurable",
-	    NULL, TCL_INDEX_NONE, NULL, 0);
-    TclOODefineBasicMethods(((Object *) cfgCls)->classPtr, cfgMethods);
-
-    /*
-     * Don't have handles to these namespaces, so use Tcl_CreateObjCommand.
-     */
-
-    Tcl_CreateObjCommand(interp,
-	    "::oo::configuresupport::configurableobject::property",
-	    TclOODefinePropertyCmd, (void *) 1, NULL);
-    Tcl_CreateObjCommand(interp,
-	    "::oo::configuresupport::configurableclass::property",
-	    TclOODefinePropertyCmd, (void *) 0, NULL);
+    MakeAdditionalClasses(fPtr, define, objdef);
 
     /*
      * Evaluate the remaining definitions, which are a compiled-in Tcl script.
@@ -510,7 +508,7 @@ InitFoundation(
 
     return Tcl_EvalEx(interp, tclOOSetupScript, TCL_INDEX_NONE, 0);
 }
-
+
 /*
  * ----------------------------------------------------------------------
  *
@@ -602,6 +600,157 @@ InitClassSystemRoots(
      */
 }
 
+static inline void
+MarkAsMetaclass(
+    Foundation *fPtr,
+    Class *classPtr)
+{
+    Class **supers = (Class **) Tcl_Alloc(sizeof(Class *));
+    supers[0] = fPtr->classCls;
+    AddRef(supers[0]->thisPtr);
+    TclOOSetSuperclasses(classPtr, 1, supers);
+}
+/*
+ * ----------------------------------------------------------------------
+ *
+ * MakeAdditionalClasses --
+ *	Make the extra classes in TclOO that aren't core to how it functions.
+ *
+ * ----------------------------------------------------------------------
+ */
+static void
+MakeAdditionalClasses(
+    Foundation *fPtr,
+    Tcl_Namespace *defineNs,
+    Tcl_Namespace *objDefineNs)
+{
+    Tcl_Interp *interp = fPtr->interp;
+    Object *singletonObj;	/* A metaclass that is used to make classes
+				 * that only permit one instance of them to
+				 * exist. See singleton(n). */
+    Object *singletonInst;	/* A mixin used to make an object so it won't
+				 * be destroyed or cloned (or at least not
+				 * easily). */
+    Object *abstractCls;	/* A metaclass that is used to make classes
+				 * that can't be directly instantiated. See
+				 * abstract(n). */
+    Object *cfgSupObj;		/* The class that contains the implementation
+				 * of the actual 'configure' method (mixed into
+				 * actually configurable classes). The
+				 * 'configure' method is in tclOOBasic.c. */
+    Object *configurableObj;	/* A metaclass that is used to make classes
+				 * that can be configured in their creation
+				 * phase (and later too). All the metaclass
+				 * itself does is arrange for the class created
+				 * to have a 'configure' method and for
+				 * oo::define and oo::objdefine (on the class
+				 * and its instances) to have a property
+				 * definition for setting things up for
+				 * 'configure'. */
+    Class *singletonCls, *cfgSupCls, *configurableCls;
+    Tcl_Namespace *cfgObjNs, *cfgClsNs;
+    Tcl_Obj *nsName;
+
+    /*
+     * Make the oo::singleton class, the SingletonInstance class, and install
+     * their standard defined methods.
+     */
+
+    singletonObj = (Object *) Tcl_NewObjectInstance(interp,
+	    (Tcl_Class) fPtr->classCls, "::oo::singleton",
+	    NULL, TCL_INDEX_NONE, NULL, 0);
+    singletonCls = singletonObj->classPtr;
+    TclOODefineBasicMethods(singletonCls, singletonMethods);
+    /* Set the superclass to oo::class */
+    MarkAsMetaclass(fPtr, singletonCls);
+    /* Unexport methods */
+    TclOOUnexportMethods(singletonCls, "create", "createWithNamespace", NULL);
+
+    singletonInst = (Object *) Tcl_NewObjectInstance(interp,
+	    (Tcl_Class) fPtr->classCls, "::oo::SingletonInstance",
+	    NULL, TCL_INDEX_NONE, NULL, 0);
+    TclOODefineBasicMethods(singletonInst->classPtr, singletonInstanceMethods);
+
+    /*
+     * Make the oo::abstract class.
+     */
+
+    abstractCls = (Object *) Tcl_NewObjectInstance(interp,
+	    (Tcl_Class) fPtr->classCls, "::oo::abstract",
+	    NULL, TCL_INDEX_NONE, NULL, 0);
+    /* Set the superclass to oo::class */
+    MarkAsMetaclass(fPtr, abstractCls->classPtr);
+    /* Unexport methods */
+    TclOOUnexportMethods(abstractCls->classPtr,
+	    "create", "createWithNamespace", "new", NULL);
+
+    /*
+     * Make the configurable class and install its standard defined method.
+     */
+
+    cfgSupObj = (Object *) Tcl_NewObjectInstance(interp,
+	    (Tcl_Class) fPtr->classCls, "::oo::configuresupport::configurable",
+	    NULL, TCL_INDEX_NONE, NULL, 0);
+    cfgSupCls = cfgSupObj->classPtr;
+    TclOODefineBasicMethods(cfgSupCls, cfgMethods);
+
+    /* Namespaces used as implementation vectors for oo::define and
+     * oo::objdefine when the class/instance is configurable.
+     * Note that these also contain commands implemented in C,
+     * especially the [property] definition command. */
+
+    cfgObjNs = Tcl_CreateNamespace(interp,
+	    "::oo::configuresupport::configurableobject", NULL, NULL);
+    TclCreateObjCommandInNs(interp, "property", cfgObjNs,
+	    TclOODefinePropertyCmd, INT2PTR(1) /*useInstance*/, NULL);
+    TclCreateObjCommandInNs(interp, "properties", cfgObjNs,
+	    TclOODefinePropertyCmd, INT2PTR(1) /*useInstance*/, NULL);
+    Tcl_Export(interp, cfgObjNs, "property", /*reset*/1);
+    TclSetNsPath((Namespace *) cfgObjNs, 1, &objDefineNs);
+
+    cfgClsNs = Tcl_CreateNamespace(interp,
+	    "::oo::configuresupport::configurableclass", NULL, NULL);
+    TclCreateObjCommandInNs(interp, "property", cfgClsNs,
+	    TclOODefinePropertyCmd, INT2PTR(0) /*useInstance*/, NULL);
+    TclCreateObjCommandInNs(interp, "properties", cfgClsNs,
+	    TclOODefinePropertyCmd, INT2PTR(0) /*useInstance*/, NULL);
+    Tcl_Export(interp, cfgClsNs, "property", /*reset*/1);
+    TclSetNsPath((Namespace *) cfgClsNs, 1, &defineNs);
+
+    /* The oo::configurable class itself, a metaclass to apply
+     * oo::configuresupport::configurable correctly. */
+
+    configurableObj = (Object *) Tcl_NewObjectInstance(interp,
+	    (Tcl_Class) fPtr->classCls, "::oo::configurable",
+	    NULL, TCL_INDEX_NONE, NULL, 0);
+    configurableCls = configurableObj->classPtr;
+    MarkAsMetaclass(fPtr, configurableCls);
+    Tcl_ClassSetConstructor(interp, (Tcl_Class) configurableCls, TclNewMethod(
+	    (Tcl_Class) configurableCls, NULL, 0, &configurableConstructor, NULL));
+
+    /* Set the definition namespaces of oo::configurable and
+     * oo::configuresupport::configurable. */
+
+    nsName = TclNewNamespaceObj(cfgClsNs);
+    Tcl_IncrRefCount(nsName);
+    if (cfgSupCls->clsDefinitionNs != NULL) {
+	Tcl_DecrRefCount(cfgSupCls->clsDefinitionNs);
+    }
+    cfgSupCls->clsDefinitionNs = nsName;
+    Tcl_IncrRefCount(nsName);
+    if (configurableCls->clsDefinitionNs != NULL) {
+	Tcl_DecrRefCount(configurableCls->clsDefinitionNs);
+    }
+    configurableCls->clsDefinitionNs = nsName;
+
+    nsName = TclNewNamespaceObj(cfgObjNs);
+    Tcl_IncrRefCount(nsName);
+    if (cfgSupCls->objDefinitionNs != NULL) {
+	Tcl_DecrRefCount(cfgSupCls->objDefinitionNs);
+    }
+    cfgSupCls->objDefinitionNs = nsName;
+}
+
 /*
  * ----------------------------------------------------------------------
  *
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 740e2cb..030d497 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -23,6 +23,8 @@ static Tcl_NRPostProc	PostClassConstructor;
 static Tcl_NRPostProc	FinalizeConstruction;
 static Tcl_NRPostProc	FinalizeEval;
 static Tcl_NRPostProc	NextRestoreFrame;
+static Tcl_NRPostProc	MarkAsSingleton;
+static Tcl_NRPostProc	UpdateClassDelegatesAfterClone;
 
 /*
  * ----------------------------------------------------------------------
@@ -477,6 +479,143 @@ TclOO_Class_New(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOO_Class_Cloned --
+ *
+ *	Handler for cloning classes, which fixes up the delegates. This allows
+ *	the clone's class methods to evolve independently of the origin's
+ *	class methods; this is how TclOO works by default.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOO_Class_Cloned(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,		/* Interpreter in which to create the object;
+				 * also used for error reporting. */
+    Tcl_ObjectContext context,	/* The object/call context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* The actual arguments. */
+{
+    Tcl_Object targetObject = Tcl_ObjectContextObject(context);
+    Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context);
+    if (skip >= objc) {
+	Tcl_WrongNumArgs(interp, skip, objv, "originObject");
+	return TCL_ERROR;
+    }
+    Tcl_Object originObject = Tcl_GetObjectFromObj(interp, objv[skip]);
+    if (!originObject) {
+	return TCL_ERROR;
+    }
+    /* Add references so things won't vanish until after
+     * UpdateClassDelegatesAfterClone is finished with them. */
+    AddRef((Object *) originObject);
+    AddRef((Object *) targetObject);
+    TclNRAddCallback(interp, UpdateClassDelegatesAfterClone,
+	    originObject, targetObject, NULL, NULL);
+    return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip);
+}
+
+/* Rebuilds the class inheritance delegation class. */
+static int
+UpdateClassDelegatesAfterClone(
+    void *data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Object *originPtr = (Object *) data[0];
+    Object *targetPtr = (Object *) data[1];
+    if (result == TCL_OK && originPtr->classPtr && targetPtr->classPtr) {
+	Tcl_Obj *originName, *targetName;
+	Object *originDelegate, *targetDelegate;
+	Tcl_Size i;
+	Class *mixin;
+
+	/* Get the originating delegate to be cloned. */
+
+	originName = Tcl_ObjPrintf("%s:: oo ::delegate",
+		originPtr->namespacePtr->fullName);
+	originDelegate = (Object *) Tcl_GetObjectFromObj(interp, originName);
+	Tcl_BounceRefCount(originName);
+	/* Delegates never have their own delegates, so silently make sure we
+	 * don't try to make a clone of them. */
+	if (!(originDelegate && originDelegate->classPtr)) {
+	    goto noOriginDelegate;
+	}
+
+	/* Create the cloned target delegate. */
+
+	targetName = Tcl_ObjPrintf("%s:: oo ::delegate",
+		targetPtr->namespacePtr->fullName);
+	targetDelegate = (Object *) Tcl_CopyObjectInstance(interp,
+		(Tcl_Object) originDelegate, Tcl_GetString(targetName), NULL);
+	Tcl_BounceRefCount(targetName);
+	if (targetDelegate == NULL) {
+	    result = TCL_ERROR;
+	    goto noOriginDelegate;
+	}
+
+	/* Point the cloned target class at the cloned target delegate.
+	 * This is like TclOOObjectSetMixins() but more efficient in this
+	 * case as there's definitely no relevant call chains to invalidate
+	 * and we're doing a one-for-one replacement. */
+
+	FOREACH(mixin, targetPtr->mixins) {
+	    if (mixin == originDelegate->classPtr) {
+		TclOORemoveFromInstances(targetPtr, originDelegate->classPtr);
+		TclOODecrRefCount(originDelegate);
+		targetPtr->mixins.list[i] = targetDelegate->classPtr;
+		TclOOAddToInstances(targetPtr, targetDelegate->classPtr);
+		AddRef(targetDelegate);
+		break;
+	    }
+	}
+    }
+  noOriginDelegate:
+    TclOODecrRefCount(originPtr);
+    TclOODecrRefCount(targetPtr);
+    return result;
+};
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Configurable_Constructor --
+ *
+ *	Implementation for oo::configurable constructor.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOO_Configurable_Constructor(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context);
+    Tcl_Obj *cfgSupportName;
+    Class *mixin;
+
+    if (objc != skip && objc != skip + 1) {
+	Tcl_WrongNumArgs(interp, skip, objv, "?definitionScript?");
+	return TCL_ERROR;
+    }
+    cfgSupportName = Tcl_NewStringObj(
+	    "::oo::configuresupport::configurable", TCL_AUTO_LENGTH);
+    mixin = TclOOGetClassFromObj(interp, cfgSupportName);
+    Tcl_BounceRefCount(cfgSupportName);
+    if (!mixin) {
+	return TCL_ERROR;
+    }
+    TclOOClassSetMixins(interp, oPtr->classPtr, 1, &mixin);
+    return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOO_Object_Destroy --
  *
  *	Implementation for oo::object->destroy method.
@@ -1777,6 +1916,91 @@ TclOODelegateNameObjCmd(
     return TCL_OK;
 }
 
+int
+TclOO_Singleton_New(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,		/* Interpreter in which to create the object;
+				 * also used for error reporting. */
+    Tcl_ObjectContext context,	/* The object/call context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* The actual arguments. */
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    Class *clsPtr = oPtr->classPtr;
+
+    if (clsPtr->instances.num) {
+	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->instances.list[0]));
+	return TCL_OK;
+    }
+
+    TclNRAddCallback(interp, MarkAsSingleton, clsPtr, NULL, NULL, NULL);
+    return TclNRNewObjectInstance(interp, (Tcl_Class) clsPtr,
+	    NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context),
+	    AddConstructionFinalizer(interp));    
+}
+
+static int
+MarkAsSingleton(
+    void *data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Class *clsPtr = (Class *) data[0];
+    if (result == TCL_OK && clsPtr->instances.num) {
+	/* Prepend oo::SingletonInstance to the list of mixins */
+	Tcl_Obj *singletonInstanceName = Tcl_NewStringObj(
+		"::oo::SingletonInstance", TCL_AUTO_LENGTH);
+	Class *singInst = TclOOGetClassFromObj(interp, singletonInstanceName);
+	Object *oPtr;
+	Tcl_Size mixinc;
+	Class **mixins;
+
+	Tcl_BounceRefCount(singletonInstanceName);
+	if (!singInst) {
+	    return TCL_ERROR;
+	}
+	oPtr = clsPtr->instances.list[0];
+	mixinc = oPtr->mixins.num;
+	mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * (mixinc + 1));
+	if (mixinc > 0) {
+	    memcpy(mixins + 1, oPtr->mixins.list, mixinc * sizeof(Class *));
+	}
+	mixins[0] = singInst; 
+	TclOOObjectSetMixins(oPtr, mixinc + 1, mixins);
+	TclStackFree(interp, mixins);
+    }
+    return result;
+}
+
+int
+TclOO_SingletonInstance_Destroy(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,		/* Interpreter for error reporting. */
+    TCL_UNUSED(Tcl_ObjectContext),
+    TCL_UNUSED(int),
+    TCL_UNUSED(Tcl_Obj *const *))
+{
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "may not destroy a singleton object"));
+    OO_ERROR(interp, SINGLETON);
+    return TCL_ERROR;
+}
+
+int
+TclOO_SingletonInstance_Cloned(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,		/* Interpreter in which to create the object;
+				 * also used for error reporting. */
+    TCL_UNUSED(Tcl_ObjectContext),
+    TCL_UNUSED(int),
+    TCL_UNUSED(Tcl_Obj *const *))
+{
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "may not clone a singleton object"));
+    OO_ERROR(interp, SINGLETON);
+    return TCL_ERROR;
+}
+
 /*
  * Local Variables:
  * mode: c
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 8d99b07..796ae37 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -37,16 +37,17 @@ typedef struct DeclaredSlot {
     const Tcl_MethodType getterType;
     const Tcl_MethodType setterType;
     const Tcl_MethodType resolverType;
+    const char *defaultOp;	/* The default op, if not set by the class */
 } DeclaredSlot;
 
-#define SLOT(name,getter,setter,resolver) \
+#define SLOT(name,getter,setter,resolver,defOp) \
     {"::oo::" name,							\
 	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter",	\
 		    getter, NULL, NULL},				\
 	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter",	\
 		    setter, NULL, NULL},				\
 	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver",	\
-		    resolver, NULL, NULL}}
+		    resolver, NULL, NULL}, (defOp)}
 
 typedef struct DeclaredSlotMethod {
     const char *name;
@@ -190,26 +191,26 @@ static int		ResolveClass(void *clientData,
  */
 
 static const DeclaredSlot slots[] = {
-    SLOT("define::filter",      ClassFilter_Get, ClassFilter_Set, NULL),
-    SLOT("define::mixin",       ClassMixin_Get,  ClassMixin_Set, ResolveClass),
-    SLOT("define::superclass",  ClassSuper_Get,  ClassSuper_Set, ResolveClass),
-    SLOT("define::variable",    ClassVars_Get,   ClassVars_Set, NULL),
-    SLOT("objdefine::filter",   ObjFilter_Get,   ObjFilter_Set, NULL),
-    SLOT("objdefine::mixin",    ObjMixin_Get,    ObjMixin_Set, ResolveClass),
-    SLOT("objdefine::variable", ObjVars_Get,     ObjVars_Set, NULL),
+    SLOT("define::filter",      ClassFilter_Get, ClassFilter_Set, NULL, NULL),
+    SLOT("define::mixin",       ClassMixin_Get,  ClassMixin_Set, ResolveClass, "-set"),
+    SLOT("define::superclass",  ClassSuper_Get,  ClassSuper_Set, ResolveClass, "-set"),
+    SLOT("define::variable",    ClassVars_Get,   ClassVars_Set, NULL, NULL),
+    SLOT("objdefine::filter",   ObjFilter_Get,   ObjFilter_Set, NULL, NULL),
+    SLOT("objdefine::mixin",    ObjMixin_Get,    ObjMixin_Set, ResolveClass, "-set"),
+    SLOT("objdefine::variable", ObjVars_Get,     ObjVars_Set, NULL, NULL),
     SLOT("configuresupport::readableproperties",
 	    Configurable_ClassReadableProps_Get,
-	    Configurable_ClassReadableProps_Set, NULL),
+	    Configurable_ClassReadableProps_Set, NULL, NULL),
     SLOT("configuresupport::writableproperties",
 	    Configurable_ClassWritableProps_Get,
-	    Configurable_ClassWritableProps_Set, NULL),
+	    Configurable_ClassWritableProps_Set, NULL, NULL),
     SLOT("configuresupport::objreadableproperties",
 	    Configurable_ObjectReadableProps_Get,
-	    Configurable_ObjectReadableProps_Set, NULL),
+	    Configurable_ObjectReadableProps_Set, NULL, NULL),
     SLOT("configuresupport::objwritableproperties",
 	    Configurable_ObjectWritableProps_Get,
-	    Configurable_ObjectWritableProps_Set, NULL),
-    {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
+	    Configurable_ObjectWritableProps_Set, NULL, NULL),
+    {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, 0}
 };
 
 static const DeclaredSlotMethod slotMethods[] = {
@@ -1230,6 +1231,166 @@ MagicDefinitionInvoke(
 /*
  * ----------------------------------------------------------------------
  *
+ * ExportMethod, UnexportMethod, ExportInstanceMethod, UnexportInstanceMethod --
+ *
+ *	Exporting and unexporting are done by setting or removing the
+ *	PUBLIC_METHOD flag on the method record. If there is no such method in
+ *	this class or object (i.e. the method comes from something inherited
+ *	from or that we're an instance of) then we put in a blank record just
+ *	to hold that flag (or its absence); such records are skipped over by
+ *	the call chain engine *except* for their flags member.
+ *
+ *	Caller has the responsibility to update any epochs if necessary.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+// Make a blank method record or look up the existing one.
+static inline Method *
+GetOrCreateMethod(
+    Tcl_HashTable *tablePtr,
+    Tcl_Obj *namePtr,
+    int *isNew)
+{
+    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, namePtr,
+		    isNew);
+    if (*isNew) {
+	Method *mPtr = (Method *) Tcl_Alloc(sizeof(Method));
+
+	memset(mPtr, 0, sizeof(Method));
+	mPtr->refCount = 1;
+	mPtr->namePtr = namePtr;
+	Tcl_IncrRefCount(namePtr);
+	Tcl_SetHashValue(hPtr, mPtr);
+	return mPtr;
+    } else {
+	return (Method *) Tcl_GetHashValue(hPtr);
+    }
+}
+
+static int
+ExportMethod(
+    Class *clsPtr,
+    Tcl_Obj *namePtr)
+{
+    int isNew;
+    Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew);
+    if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
+	mPtr->flags |= PUBLIC_METHOD;
+	mPtr->flags &= ~TRUE_PRIVATE_METHOD;
+	isNew = 1;
+    }
+    return isNew;
+}
+
+static int
+UnexportMethod(
+    Class *clsPtr,
+    Tcl_Obj *namePtr)
+{
+    int isNew;
+    Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew);
+    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
+	isNew = 1;
+    }
+    return isNew;
+}
+
+// Make the table of methods in the instance if it doesn't already exist.
+static inline void
+InitMethodTable(
+    Object *oPtr)
+{
+    if (!oPtr->methodsPtr) {
+	oPtr->methodsPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
+	Tcl_InitObjHashTable(oPtr->methodsPtr);
+	oPtr->flags &= ~USE_CLASS_CACHE;
+    }
+}
+
+static int
+ExportInstanceMethod(
+    Object *oPtr,
+    Tcl_Obj *namePtr)
+{
+    InitMethodTable(oPtr);
+
+    int isNew;
+    Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew);
+    if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
+	mPtr->flags |= PUBLIC_METHOD;
+	mPtr->flags &= ~TRUE_PRIVATE_METHOD;
+	isNew = 1;
+    }
+    return isNew;
+}
+
+static int
+UnexportInstanceMethod(
+    Object *oPtr,
+    Tcl_Obj *namePtr)
+{
+    InitMethodTable(oPtr);
+
+    int isNew;
+    Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew);
+    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
+	isNew = 1;
+    }
+    return isNew;
+}
+
+int
+TclOOExportMethods(
+    Class *clsPtr,
+    ...)
+{
+    va_list argList;
+    int changed = 0;
+    va_start(argList, clsPtr);
+    while (1) {
+	const char *name = va_arg(argList, char *);
+	Tcl_Obj *namePtr;
+
+	if (!name) {
+	    break;
+	}
+	namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH);
+	changed |= ExportMethod(clsPtr, namePtr);
+	Tcl_BounceRefCount(namePtr);
+    }
+    va_end(argList);
+    return changed;
+}
+
+int
+TclOOUnexportMethods(
+    Class *clsPtr,
+    ...)
+{
+    va_list argList;
+    int changed = 0;
+    va_start(argList, clsPtr);
+    while (1) {
+	const char *name = va_arg(argList, char *);
+	Tcl_Obj *namePtr;
+
+	if (!name) {
+	    break;
+	}
+	namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH);
+	changed |= UnexportMethod(clsPtr, namePtr);
+	Tcl_BounceRefCount(namePtr);
+    }
+    va_end(argList);
+    return changed;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOODefineObjCmd --
  *
  *	Implementation of the "oo::define" command. Works by effectively doing
@@ -1938,11 +2099,9 @@ TclOODefineExportObjCmd(
     Tcl_Obj *const *objv)
 {
     int isInstanceExport = (clientData != NULL);
+    int i, changed = 0;
     Object *oPtr;
-    Method *mPtr;
-    Tcl_HashEntry *hPtr;
     Class *clsPtr;
-    int i, isNew, changed = 0;
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
@@ -1972,33 +2131,9 @@ TclOODefineExportObjCmd(
 	 */
 
 	if (isInstanceExport) {
-	    if (!oPtr->methodsPtr) {
-		oPtr->methodsPtr = (Tcl_HashTable *)
-			Tcl_Alloc(sizeof(Tcl_HashTable));
-		Tcl_InitObjHashTable(oPtr->methodsPtr);
-		oPtr->flags &= ~USE_CLASS_CACHE;
-	    }
-	    hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i],
-		    &isNew);
+	    changed |= ExportInstanceMethod(oPtr, objv[i]);
 	} else {
-	    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i],
-		    &isNew);
-	}
-
-	if (isNew) {
-	    mPtr = (Method *) Tcl_Alloc(sizeof(Method));
-	    memset(mPtr, 0, sizeof(Method));
-	    mPtr->refCount = 1;
-	    mPtr->namePtr = objv[i];
-	    Tcl_IncrRefCount(objv[i]);
-	    Tcl_SetHashValue(hPtr, mPtr);
-	} else {
-	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
-	}
-	if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
-	    mPtr->flags |= PUBLIC_METHOD;
-	    mPtr->flags &= ~TRUE_PRIVATE_METHOD;
-	    changed = 1;
+	    changed |= ExportMethod(clsPtr, objv[i]);
 	}
     }
 
@@ -2374,10 +2509,8 @@ TclOODefineUnexportObjCmd(
 {
     int isInstanceUnexport = (clientData != NULL);
     Object *oPtr;
-    Method *mPtr;
-    Tcl_HashEntry *hPtr;
     Class *clsPtr;
-    int i, isNew, changed = 0;
+    int i, changed = 0;
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
@@ -2397,42 +2530,10 @@ TclOODefineUnexportObjCmd(
     }
 
     for (i = 1; i < objc; i++) {
-	/*
-	 * Unexporting is done by removing the PUBLIC_METHOD flag from the
-	 * method record. If there is no such method in this object or class
-	 * (i.e. the method comes from something inherited from or that we're
-	 * an instance of) then we put in a blank record without that flag;
-	 * such records are skipped over by the call chain engine *except* for
-	 * their flags member.
-	 */
-
 	if (isInstanceUnexport) {
-	    if (!oPtr->methodsPtr) {
-		oPtr->methodsPtr = (Tcl_HashTable *)
-			Tcl_Alloc(sizeof(Tcl_HashTable));
-		Tcl_InitObjHashTable(oPtr->methodsPtr);
-		oPtr->flags &= ~USE_CLASS_CACHE;
-	    }
-	    hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i],
-		    &isNew);
-	} else {
-	    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i],
-		    &isNew);
-	}
-
-	if (isNew) {
-	    mPtr = (Method *) Tcl_Alloc(sizeof(Method));
-	    memset(mPtr, 0, sizeof(Method));
-	    mPtr->refCount = 1;
-	    mPtr->namePtr = objv[i];
-	    Tcl_IncrRefCount(objv[i]);
-	    Tcl_SetHashValue(hPtr, mPtr);
+	    changed |= UnexportInstanceMethod(oPtr, objv[i]);
 	} else {
-	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
-	}
-	if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
-	    mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
-	    changed = 1;
+	    changed |= UnexportMethod(clsPtr, objv[i]);
 	}
     }
 
@@ -2510,8 +2611,9 @@ Tcl_ClassSetDestructor(
  *
  * TclOODefineSlots --
  *
- *	Create the "::oo::Slot" class and its standard instances. Class
- *	definition is empty at the stage (added by scripting).
+ *	Create the "::oo::Slot" class and its standard instances. These are
+ *	basically lists at the low level of TclOO; this provides a more
+ *	consistent interface to them.
  *
  * ----------------------------------------------------------------------
  */
@@ -2526,6 +2628,7 @@ TclOODefineSlots(
     Tcl_Class slotCls;
     const DeclaredSlotMethod *smPtr;
     const DeclaredSlot *slotPtr;
+    Tcl_Obj *defaults[2];
 
     if (object == NULL) {
 	return TCL_ERROR;
@@ -2542,6 +2645,17 @@ TclOODefineSlots(
 	Tcl_BounceRefCount(name);
     }
 
+    /* If a slot can't figure out what method to call directly, it uses
+     * --default-operation. That defaults to -append; we set that here. */
+    defaults[0] = fPtr->myName;
+    defaults[1] = Tcl_NewStringObj("-append", TCL_AUTO_LENGTH);
+    TclOONewForwardMethod(interp, (Class *) slotCls, 0,
+	    fPtr->slotDefOpName, Tcl_NewListObj(2, defaults));
+
+    // Hide the destroy method. (We're definitely taking a ref to the name.)
+    UnexportMethod((Class *) slotCls,
+	    Tcl_NewStringObj("destroy", TCL_AUTO_LENGTH));
+
     for (slotPtr = slots ; slotPtr->name ; slotPtr++) {
 	Tcl_Object slotObject = Tcl_NewObjectInstance(interp,
 		slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0);
@@ -2557,6 +2671,11 @@ TclOODefineSlots(
 	    TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0,
 		    &slotPtr->resolverType, NULL);
 	}
+	if (slotPtr->defaultOp) {
+	    defaults[1] = Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH);
+	    TclOONewForwardInstanceMethod(interp, (Object *) slotObject, 0,
+		    fPtr->slotDefOpName, Tcl_NewListObj(2, defaults));
+	}
     }
     return TCL_OK;
 }
@@ -3073,6 +3192,41 @@ Slot_Unknown(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOOSetSuperclasses --
+ *
+ *	Core of the "superclass" slot setter. Caller must AddRef() the objects
+ *	holding the classes to set before calling this. The 'superclasses'
+ *	argument must be allocated with Tcl_Alloc(); this function takes
+ *	ownership.
+ *
+ * ----------------------------------------------------------------------
+ */
+void
+TclOOSetSuperclasses(
+    Class *clsPtr,
+    Tcl_Size superc,
+    Class **superclasses)
+{
+    Tcl_Size i;
+    Class *superPtr;
+
+    if (clsPtr->superclasses.num != 0) {
+	FOREACH(superPtr, clsPtr->superclasses) {
+	    TclOORemoveFromSubclasses(clsPtr, superPtr);
+	    TclOODecrRefCount(superPtr->thisPtr);
+	}
+	Tcl_Free(clsPtr->superclasses.list);
+    }
+    clsPtr->superclasses.list = superclasses;
+    clsPtr->superclasses.num = superc;
+    FOREACH(superPtr, clsPtr->superclasses) {
+	TclOOAddToSubclasses(clsPtr, superPtr);
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * ClassFilter_Get, ClassFilter_Set --
  *
  *	Implementation of the "filter" slot accessors of the "oo::define"
@@ -3298,11 +3452,12 @@ ClassSuper_Set(
     int objc,
     Tcl_Obj *const *objv)
 {
+    Foundation *fPtr;
     Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
     Tcl_Size superc, j;
     Tcl_Size i;
     Tcl_Obj **superv;
-    Class **superclasses, *superPtr;
+    Class **superclasses;
 
     if (clsPtr == NULL) {
 	return TCL_ERROR;
@@ -3313,7 +3468,7 @@ ClassSuper_Set(
     }
     objv += Tcl_ObjectContextSkippedArgs(context);
 
-    Foundation *fPtr = clsPtr->thisPtr->fPtr;
+    fPtr = clsPtr->thisPtr->fPtr;
     if (clsPtr == fPtr->objectCls) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"may not modify the superclass of the root object",
@@ -3329,7 +3484,7 @@ ClassSuper_Set(
      * Allocate some working space.
      */
 
-    superclasses = (Class **) Tcl_Alloc(sizeof(Class *) * superc);
+    superclasses = (Class **) Tcl_Alloc(sizeof(Class *) * (superc ? superc : 1));
 
     /*
      * Parse the arguments to get the class to use as superclasses.
@@ -3339,7 +3494,6 @@ ClassSuper_Set(
      */
 
     if (superc == 0) {
-	superclasses = (Class **) Tcl_Realloc(superclasses, sizeof(Class *));
 	if (TclOOIsReachable(fPtr->classCls, clsPtr)) {
 	    superclasses[0] = fPtr->classCls;
 	} else {
@@ -3392,18 +3546,7 @@ ClassSuper_Set(
      * subclass list.
      */
 
-    if (clsPtr->superclasses.num != 0) {
-	FOREACH(superPtr, clsPtr->superclasses) {
-	    TclOORemoveFromSubclasses(clsPtr, superPtr);
-	    TclOODecrRefCount(superPtr->thisPtr);
-	}
-	Tcl_Free(clsPtr->superclasses.list);
-    }
-    clsPtr->superclasses.list = superclasses;
-    clsPtr->superclasses.num = superc;
-    FOREACH(superPtr, clsPtr->superclasses) {
-	TclOOAddToSubclasses(clsPtr, superPtr);
-    }
+    TclOOSetSuperclasses(clsPtr, superc, superclasses);
     BumpGlobalEpoch(interp, clsPtr);
 
     return TCL_OK;
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 70b4a32..66ec7d1 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -533,6 +533,7 @@ MODULE_SCOPE Tcl_ObjCmdProc	TclOOInfoClassPropCmd;
  * Method implementations (in tclOOBasic.c).
  */
 
+MODULE_SCOPE Tcl_MethodCallProc	TclOO_Class_Cloned;
 MODULE_SCOPE Tcl_MethodCallProc	TclOO_Class_Constructor;
 MODULE_SCOPE Tcl_MethodCallProc	TclOO_Class_Create;
 MODULE_SCOPE Tcl_MethodCallProc	TclOO_Class_CreateNs;
@@ -543,6 +544,10 @@ MODULE_SCOPE Tcl_MethodCallProc	TclOO_Object_LinkVar;
 MODULE_SCOPE Tcl_MethodCallProc	TclOO_Object_Unknown;
 MODULE_SCOPE Tcl_MethodCallProc	TclOO_Object_VarName;
 MODULE_SCOPE Tcl_MethodCallProc TclOO_Configurable_Configure;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Configurable_Constructor;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_Singleton_New;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_SingletonInstance_Cloned;
+MODULE_SCOPE Tcl_MethodCallProc TclOO_SingletonInstance_Destroy;
 
 /*
  * Private definitions, some of which perhaps ought to be exposed properly or
@@ -583,6 +588,7 @@ MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
 MODULE_SCOPE void	TclOODeleteDescendants(Tcl_Interp *interp,
 			    Object *oPtr);
 MODULE_SCOPE void	TclOODelMethodRef(Method *method);
+MODULE_SCOPE int	TclOOExportMethods(Class *clsPtr, ...);
 MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
 			    Tcl_Obj *methodNameObj, int flags,
 			    Object *contextObjPtr, Class *contextClsPtr,
@@ -628,11 +634,14 @@ MODULE_SCOPE int	TclOORemoveFromSubclasses(Class *subPtr,
 			    Class *superPtr);
 MODULE_SCOPE Tcl_Obj *	TclOORenderCallChain(Tcl_Interp *interp,
 			    CallChain *callPtr);
+MODULE_SCOPE void	TclOOSetSuperclasses(Class *clsPtr, Tcl_Size superc,
+			    Class **superclasses);
 MODULE_SCOPE void	TclOOStashContext(Tcl_Obj *objPtr,
 			    CallContext *contextPtr);
+MODULE_SCOPE void	TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
+MODULE_SCOPE int	TclOOUnexportMethods(Class *clsPtr, ...);
 MODULE_SCOPE Tcl_Obj *	TclOOGetAllObjectProperties(Object *oPtr,
 			    int writable);
-MODULE_SCOPE void	TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
 MODULE_SCOPE Tcl_Obj *	TclOOGetPropertyList(PropertyList *propList);
 MODULE_SCOPE void	TclOOReleasePropertyStorage(PropertyStorage *propsPtr);
 MODULE_SCOPE void	TclOOInstallReadableProperties(PropertyStorage *props,
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 318a7ac..24a3255 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -26,99 +26,32 @@
 
 static const char *tclOOSetupScript =
 /* !BEGIN!: Do not edit below this line. */
-"::namespace eval ::oo {\n"
-"\tdefine Slot forward --default-operation my -append\n"
-"\tdefine Slot unexport destroy\n"
-"\tobjdefine define::superclass forward --default-operation my -set\n"
-"\tobjdefine define::mixin forward --default-operation my -set\n"
-"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
-"\tdefine object method <cloned> -unexport {originObject} {\n"
-"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
-"\t\t\tset args [info args $p]\n"
-"\t\t\tset idx -1\n"
-"\t\t\tforeach a $args {\n"
-"\t\t\t\tif {[info default $p $a d]} {\n"
-"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
-"\t\t\t\t} else {\n"
-"\t\t\t\t\tlset args [incr idx] [list $a]\n"
-"\t\t\t\t}\n"
+"::oo::define ::oo::object method <cloned> -unexport {originObject} {\n"
+"\tforeach p [info procs [info object namespace $originObject]::*] {\n"
+"\t\tset args [info args $p]\n"
+"\t\tset idx -1\n"
+"\t\tforeach a $args {\n"
+"\t\t\tif {[info default $p $a d]} {\n"
+"\t\t\t\tlset args [incr idx] [list $a $d]\n"
+"\t\t\t} else {\n"
+"\t\t\t\tlset args [incr idx] [list $a]\n"
 "\t\t\t}\n"
-"\t\t\tset b [info body $p]\n"
-"\t\t\tset p [namespace tail $p]\n"
-"\t\t\tproc $p $args $b\n"
-"\t\t}\n"
-"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n"
-"\t\t\tupvar 0 $v vOrigin\n"
-"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
-"\t\t\tif {[info exists vOrigin]} {\n"
-"\t\t\t\tif {[array exists vOrigin]} {\n"
-"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
-"\t\t\t\t} else {\n"
-"\t\t\t\t\tset vNew $vOrigin\n"
-"\t\t\t\t}\n"
-"\t\t\t}\n"
-"\t\t}\n"
-"\t}\n"
-"\tdefine class method <cloned> -unexport {originObject} {\n"
-"\t\tset targetObject [self]\n"
-"\t\tnext $originObject\n"
-"\t\tset originDelegate [::oo::DelegateName $originObject]\n"
-"\t\tset targetDelegate [::oo::DelegateName $targetObject]\n"
-"\t\tif {\n"
-"\t\t\t[info object isa class $originDelegate]\n"
-"\t\t\t&& ![info object isa class $targetDelegate]\n"
-"\t\t} then {\n"
-"\t\t\t::oo::copy $originDelegate $targetDelegate\n"
-"\t\t\t::oo::objdefine $targetObject mixin -set \\\n"
-"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
-"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
-"\t\t\t\t}]\n"
 "\t\t}\n"
+"\t\tset b [info body $p]\n"
+"\t\tset p [namespace tail $p]\n"
+"\t\tproc $p $args $b\n"
 "\t}\n"
-"\tclass create singleton\n"
-"\tdefine singleton superclass -set class\n"
-"\tdefine singleton variable -set object\n"
-"\tdefine singleton unexport create createWithNamespace\n"
-"\tdefine singleton method new args {\n"
-"\t\tif {![info exists object] || ![info object isa object $object]} {\n"
-"\t\t\tset object [next {*}$args]\n"
-"\t\t\t::oo::objdefine $object {\n"
-"\t\t\t\tmethod destroy {} {\n"
-"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
-"\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
-"\t\t\t\t}\n"
-"\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
-"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
-"\t\t\t\t\t\t\"may not clone a singleton object\"\n"
-"\t\t\t\t}\n"
+"\tforeach v [info vars [info object namespace $originObject]::*] {\n"
+"\t\tupvar 0 $v vOrigin\n"
+"\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
+"\t\tif {[info exists vOrigin]} {\n"
+"\t\t\tif {[array exists vOrigin]} {\n"
+"\t\t\t\tarray set vNew [array get vOrigin]\n"
+"\t\t\t} else {\n"
+"\t\t\t\tset vNew $vOrigin\n"
 "\t\t\t}\n"
 "\t\t}\n"
-"\t\treturn $object\n"
-"\t}\n"
-"\tclass create abstract\n"
-"\tdefine abstract superclass -set class\n"
-"\tdefine abstract unexport create createWithNamespace new\n"
-"\tnamespace eval configuresupport::configurableclass {\n"
-"\t\t::proc properties args {::tailcall property {*}$args}\n"
-"\t\t::namespace path ::oo::define\n"
-"\t\t::namespace export property\n"
-"\t}\n"
-"\tnamespace eval configuresupport::configurableobject {\n"
-"\t\t::proc properties args {::tailcall property {*}$args}\n"
-"\t\t::namespace path ::oo::objdefine\n"
-"\t\t::namespace export property\n"
-"\t}\n"
-"\tdefine configuresupport::configurable {\n"
-"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n"
-"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
-"\t}\n"
-"\tclass create configurable\n"
-"\tdefine configurable superclass -set class\n"
-"\tdefine configurable constructor {{definitionScript \"\"}} {\n"
-"\t\too::define [self] {mixin -append ::oo::configuresupport::configurable}\n"
-"\t\tnext $definitionScript\n"
 "\t}\n"
-"\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n"
 "}\n"
 /* !END!: Do not edit above this line. */
 ;
diff --git a/tests/oo.test b/tests/oo.test
index 21c8f9e..165ddae 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -378,10 +378,17 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup {
 } -body {
     lmap x [$fresh eval {
 	set initials {::oo::object ::oo::class ::oo::Slot}
-	foreach cmd {instances subclasses mixins superclass} {
-	    foreach initial $initials {
-		lappend x [info class $cmd $initial]
-	    }
+	foreach initial $initials {
+	    lappend x [info class instances $initial]
+	}
+	foreach initial $initials {
+	    lappend x [info class subclasses $initial]
+	}
+	foreach initial $initials {
+	    lappend x [info class mixins $initial]
+	}
+	foreach initial $initials {
+	    lappend x [info class superclasses $initial]
 	}
 	foreach initial $initials {
 	    lappend x [info object class $initial]
@@ -390,7 +397,21 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup {
     }] {lsort [lsearch -all -not -inline $x *::delegate]}
 } -cleanup {
     interp delete $fresh
-} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
+} -result [list {*}{
+    {}
+    {::oo::SingletonInstance ::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton}
+    {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
+
+    {::oo::SingletonInstance ::oo::Slot ::oo::class ::oo::configuresupport::configurable}
+    {::oo::abstract ::oo::configurable ::oo::singleton}
+    {}
+
+    {} {} {}
+
+    {} ::oo::object ::oo::object
+
+    ::oo::class ::oo::class ::oo::class
+}]
 test oo-1.22 {basic test of OO functionality: nested ownership destruction order} -setup {
     oo::class create parent
 } -body {
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 66e125d..ef2d325 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -11,232 +11,47 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-::namespace eval ::oo {
-    # ----------------------------------------------------------------------
-    #
-    # Slot --
-    #
-    #	The class of slot operations, which are basically lists at the low
-    #	level of TclOO; this provides a more consistent interface to them.
-    #
-    # ----------------------------------------------------------------------
-
-    # ------------------------------------------------------------------
-    #
-    # Slot --default-operation --
-    #
-    #	If a slot can't figure out what method to call directly, it
-    #	uses --default-operation.
-    #
-    # ------------------------------------------------------------------
-    define Slot forward --default-operation my -append
-
-    # Hide destroy
-    define Slot unexport destroy
-
-    # Set the default operation differently for these slots
-    objdefine define::superclass forward --default-operation my -set
-    objdefine define::mixin forward --default-operation my -set
-    objdefine objdefine::mixin forward --default-operation my -set
-
-    # ----------------------------------------------------------------------
-    #
-    # oo::object <cloned> --
-    #
-    #	Handler for cloning objects that clones basic bits (only!) of the
-    #	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
-    #	more complex (and class-specific) handling.
-    #
-    # ----------------------------------------------------------------------
-
-    define object method <cloned> -unexport {originObject} {
-	# Copy over the procedures from the original namespace
-	foreach p [info procs [info object namespace $originObject]::*] {
-	    set args [info args $p]
-	    set idx -1
-	    foreach a $args {
-		if {[info default $p $a d]} {
-		    lset args [incr idx] [list $a $d]
-		} else {
-		    lset args [incr idx] [list $a]
-		}
-	    }
-	    set b [info body $p]
-	    set p [namespace tail $p]
-	    proc $p $args $b
-	}
-	# Copy over the variables from the original namespace
-	foreach v [info vars [info object namespace $originObject]::*] {
-	    upvar 0 $v vOrigin
-	    namespace upvar [namespace current] [namespace tail $v] vNew
-	    if {[info exists vOrigin]} {
-		if {[array exists vOrigin]} {
-		    array set vNew [array get vOrigin]
-		} else {
-		    set vNew $vOrigin
-		}
+# ----------------------------------------------------------------------
+#
+# oo::object <cloned> --
+#
+#	Handler for cloning objects that clones basic bits (only!) of the
+#	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
+#	more complex (and class-specific) handling.
+#
+# ----------------------------------------------------------------------
+
+::oo::define ::oo::object method <cloned> -unexport {originObject} {
+    # Copy over the procedures from the original namespace
+    foreach p [info procs [info object namespace $originObject]::*] {
+	set args [info args $p]
+	set idx -1
+	foreach a $args {
+	    if {[info default $p $a d]} {
+		lset args [incr idx] [list $a $d]
+	    } else {
+		lset args [incr idx] [list $a]
 	    }
 	}
-	# General commands, sub-namespaces and advancd variable config (traces,
-	# etc) are *not* copied over. Classes that want that should do it
-	# themselves.
-    }
-
-    # ----------------------------------------------------------------------
-    #
-    # oo::class <cloned> --
-    #
-    #	Handler for cloning classes, which fixes up the delegates.
-    #
-    # ----------------------------------------------------------------------
-
-    define class method <cloned> -unexport {originObject} {
-	set targetObject [self]
-	next $originObject
-	# Rebuild the class inheritance delegation class
-	set originDelegate [::oo::DelegateName $originObject]
-	set targetDelegate [::oo::DelegateName $targetObject]
-	if {
-	    [info object isa class $originDelegate]
-	    && ![info object isa class $targetDelegate]
-	} then {
-	    ::oo::copy $originDelegate $targetDelegate
-	    ::oo::objdefine $targetObject mixin -set \
-		{*}[lmap c [info object mixin $targetObject] {
-		    if {$c eq $originDelegate} {set targetDelegate} {set c}
-		}]
-	}
+	set b [info body $p]
+	set p [namespace tail $p]
+	proc $p $args $b
     }
-
-    # ----------------------------------------------------------------------
-    #
-    # oo::singleton --
-    #
-    #	A metaclass that is used to make classes that only permit one instance
-    #	of them to exist. See singleton(n).
-    #
-    # ----------------------------------------------------------------------
-
-    class create singleton
-    define singleton superclass -set class
-    define singleton variable -set object
-    define singleton unexport create createWithNamespace
-    define singleton method new args {
-	if {![info exists object] || ![info object isa object $object]} {
-	    set object [next {*}$args]
-	    ::oo::objdefine $object {
-		method destroy {} {
-		    return -code error -errorcode {TCL OO SINGLETON} \
-			"may not destroy a singleton object"
-		}
-		method <cloned> -unexport {originObject} {
-		    return -code error -errorcode {TCL OO SINGLETON} \
-			"may not clone a singleton object"
-		}
+    # Copy over the variables from the original namespace
+    foreach v [info vars [info object namespace $originObject]::*] {
+	upvar 0 $v vOrigin
+	namespace upvar [namespace current] [namespace tail $v] vNew
+	if {[info exists vOrigin]} {
+	    if {[array exists vOrigin]} {
+		array set vNew [array get vOrigin]
+	    } else {
+		set vNew $vOrigin
 	    }
 	}
-	return $object
     }
-
-    # ----------------------------------------------------------------------
-    #
-    # oo::abstract --
-    #
-    #	A metaclass that is used to make classes that can't be directly
-    #	instantiated. See abstract(n).
-    #
-    # ----------------------------------------------------------------------
-
-    class create abstract
-    define abstract superclass -set class
-    define abstract unexport create createWithNamespace new
-
-    # ----------------------------------------------------------------------
-    #
-    # oo::configuresupport --
-    #
-    #	Namespace that holds all the implementation details of TIP #558.
-    #	Also includes the commands:
-    #
-    #	 * readableproperties
-    #	 * writableproperties
-    #	 * objreadableproperties
-    #	 * objwritableproperties
-    #
-    #	These are all slot implementations that provide access to the C layer
-    #	of property support (i.e., very fast cached lookup of property names).
-    #
-    #	 * StdClassProperties
-    #	 * StdObjectPropertes
-    #
-    #	These cause very fast basic implementation methods for a property
-    #	following the standard model of property implementation naming.
-    #	Property schemes that use other models (such as to be more Tk-like)
-    #	should not use these (or the oo::cconfigurable metaclass).
-    #
-    # ----------------------------------------------------------------------
-
-    # ------------------------------------------------------------------
-    #
-    # oo::configuresupport::configurableclass,
-    # oo::configuresupport::configurableobject --
-    #
-    #	Namespaces used as implementation vectors for oo::define and
-    #	oo::objdefine when the class/instance is configurable.
-    #	Note that these also contain commands implemented in C,
-    #	especially the [property] definition command.
-    #
-    # ------------------------------------------------------------------
-
-    namespace eval configuresupport::configurableclass {
-	# Plural alias just in case; deliberately NOT documented!
-	::proc properties args {::tailcall property {*}$args}
-	::namespace path ::oo::define
-	::namespace export property
-    }
-
-    namespace eval configuresupport::configurableobject {
-	# Plural alias just in case; deliberately NOT documented!
-	::proc properties args {::tailcall property {*}$args}
-	::namespace path ::oo::objdefine
-	::namespace export property
-    }
-
-    # ------------------------------------------------------------------
-    #
-    # oo::configuresupport::configurable --
-    #
-    #	The class that contains the implementation of the actual
-    #	'configure' method (mixed into actually configurable classes).
-    #	The 'configure' method is in tclOOBasic.c.
-    #
-    # ------------------------------------------------------------------
-
-    define configuresupport::configurable {
-	definitionnamespace -instance configuresupport::configurableobject
-	definitionnamespace -class configuresupport::configurableclass
-    }
-
-    # ----------------------------------------------------------------------
-    #
-    # oo::configurable --
-    #
-    #	A metaclass that is used to make classes that can be configured in
-    #	their creation phase (and later too). All the metaclass itself does is
-    #	arrange for the class created to have a 'configure' method and for
-    #	oo::define and oo::objdefine (on the class and its instances) to have
-    #	a property definition for setting things up for 'configure'.
-    #
-    # ----------------------------------------------------------------------
-
-    class create configurable
-    define configurable superclass -set class
-    define configurable constructor {{definitionScript ""}} {
-	::oo::define [self] {mixin -append ::oo::configuresupport::configurable}
-	next $definitionScript
-    }
-
-    define configurable definitionnamespace -class configuresupport::configurableclass
+    # General commands, sub-namespaces and advancd variable config (traces,
+    # etc) are *not* copied over. Classes that want that should do it
+    # themselves.
 }
 
 # Local Variables:
diff --git a/win/Makefile.in b/win/Makefile.in
index e039f64..bcb35c1 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -767,7 +767,7 @@ tclWinPanic.${OBJEXT}: tclWinPanic.c
 .rc.$(RES):
 	$(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@
 
-
+tclOO.${OBJEXT}: tclOO.c tclOOScript.h
 
 #--------------------------------------------------------------------------
 # Minizip implementation