Complete the moving of the definition of slots entirely into C

4 files changed, 144 insertions, 123 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 0da8b7f..0e6ff6f 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,17 @@ 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 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
@@ -172,8 +166,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;"; */
 
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 8d99b07..be33f40 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[] = {
@@ -2355,6 +2356,75 @@ TclOODefineRenameMethodObjCmd(
 }
 
 /*
+ * 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.
+ *
+ * Caller has the responsibility to update any epochs if necessary.
+ */
+
+static int
+UnexportMethod(
+    Class *clsPtr,
+    Tcl_Obj *namePtr)
+{
+    int isNew;
+    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, namePtr,
+		    &isNew);
+    Method *mPtr;
+    if (isNew) {
+	mPtr = (Method *) Tcl_Alloc(sizeof(Method));
+	memset(mPtr, 0, sizeof(Method));
+	mPtr->refCount = 1;
+	mPtr->namePtr = namePtr;
+	Tcl_IncrRefCount(namePtr);
+	Tcl_SetHashValue(hPtr, mPtr);
+    } else {
+	mPtr = (Method *) Tcl_GetHashValue(hPtr);
+    }
+    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
+	isNew = 1;
+    }
+    return isNew;
+}
+
+static int
+UnexportInstanceMethod(
+    Object *oPtr,
+    Tcl_Obj *namePtr)
+{
+    if (!oPtr->methodsPtr) {
+	oPtr->methodsPtr = (Tcl_HashTable *)
+		Tcl_Alloc(sizeof(Tcl_HashTable));
+	Tcl_InitObjHashTable(oPtr->methodsPtr);
+	oPtr->flags &= ~USE_CLASS_CACHE;
+    }
+
+    int isNew;
+    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, namePtr,
+	    &isNew);
+    Method *mPtr;
+    if (isNew) {
+	mPtr = (Method *) Tcl_Alloc(sizeof(Method));
+	memset(mPtr, 0, sizeof(Method));
+	mPtr->refCount = 1;
+	mPtr->namePtr = namePtr;
+	Tcl_IncrRefCount(namePtr);
+	Tcl_SetHashValue(hPtr, mPtr);
+    } else {
+	mPtr = (Method *) Tcl_GetHashValue(hPtr);
+    }
+    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
+	isNew = 1;
+    }
+    return isNew;
+}
+
+/*
  * ----------------------------------------------------------------------
  *
  * TclOODefineUnexportObjCmd --
@@ -2374,10 +2444,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 +2465,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 +2546,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.
  *
  * ----------------------------------------------------------------------
  */
@@ -2542,6 +2579,19 @@ 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.
+    Tcl_Obj *defaults[] = {
+	fPtr->myName,
+	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 +2607,14 @@ TclOODefineSlots(
 	    TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0,
 		    &slotPtr->resolverType, NULL);
 	}
+	if (slotPtr->defaultOp) {
+	    Tcl_Obj *slotDefaults[] = {
+		fPtr->myName,
+		Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH)
+	    };
+	    TclOONewForwardInstanceMethod(interp, (Object *) slotObject, 0,
+		    fPtr->slotDefOpName, Tcl_NewListObj(2, slotDefaults));
+	}
     }
     return TCL_OK;
 }
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 318a7ac..4c5f1a2 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -27,11 +27,6 @@
 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"
@@ -115,7 +110,7 @@ static const char *tclOOSetupScript =
 "\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\t::oo::define [self] {mixin -append ::oo::configuresupport::configurable}\n"
 "\t\tnext $definitionScript\n"
 "\t}\n"
 "\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 66e125d..6b17483 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -14,33 +14,6 @@
 ::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