Attachment "slots.patch" to
ticket [3084339fff]
added by
dkf
2010-10-22 22:29:54.
Index: generic/tclOO.c
===================================================================
RCS file: /cvsroot/tcl/oocore/generic/tclOO.c,v
retrieving revision 1.71
diff -u -r1.71 tclOO.c
--- generic/tclOO.c 5 Mar 2010 15:39:33 -0000 1.71
+++ generic/tclOO.c 22 Oct 2010 15:25:32 -0000
@@ -30,27 +30,20 @@
{"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
{"destructor", TclOODefineDestructorObjCmd, 0},
{"export", TclOODefineExportObjCmd, 0},
- {"filter", TclOODefineFilterObjCmd, 0},
{"forward", TclOODefineForwardObjCmd, 0},
{"method", TclOODefineMethodObjCmd, 0},
- {"mixin", TclOODefineMixinObjCmd, 0},
{"renamemethod", TclOODefineRenameMethodObjCmd, 0},
{"self", TclOODefineSelfObjCmd, 0},
- {"superclass", TclOODefineSuperclassObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 0},
- {"variable", TclOODefineVariablesObjCmd, 0},
{NULL, NULL, 0}
}, objdefCmds[] = {
{"class", TclOODefineClassObjCmd, 1},
{"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
{"export", TclOODefineExportObjCmd, 1},
- {"filter", TclOODefineFilterObjCmd, 1},
{"forward", TclOODefineForwardObjCmd, 1},
{"method", TclOODefineMethodObjCmd, 1},
- {"mixin", TclOODefineMixinObjCmd, 1},
{"renamemethod", TclOODefineRenameMethodObjCmd, 1},
{"unexport", TclOODefineUnexportObjCmd, 1},
- {"variable", TclOODefineVariablesObjCmd, 1},
{NULL, NULL, 0}
};
@@ -76,7 +69,7 @@
static void DeletedDefineNamespace(ClientData clientData);
static void DeletedObjdefNamespace(ClientData clientData);
static void DeletedHelpersNamespace(ClientData clientData);
-static void InitFoundation(Tcl_Interp *interp);
+static int InitFoundation(Tcl_Interp *interp);
static void KillFoundation(ClientData clientData,
Tcl_Interp *interp);
static void MyDeleted(ClientData clientData);
@@ -162,7 +155,9 @@
* Build the core of the OO system.
*/
- InitFoundation(interp);
+ if (InitFoundation(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
/*
* Run our initialization script and, if that works, declare the package
@@ -213,7 +208,7 @@
* ----------------------------------------------------------------------
*/
-static void
+static int
InitFoundation(
Tcl_Interp *interp)
{
@@ -355,6 +350,43 @@
NULL);
Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
TclOOInitInfo(interp);
+
+ /*
+ * Now make the class of slots.
+ */
+
+ if (TclOODefineSlots(fPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return Tcl_Eval(interp,
+"::oo::define ::oo::Slot {\n"
+" method Get {} {error unimplemented}\n"
+" method Set list {error unimplemented}\n"
+" method -set args {\n"
+" uplevel 1 [list [namespace which my] Set $args]\n"
+" }\n"
+" method -append args {\n"
+" uplevel 1 [list [namespace which my] Set [list"
+" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
+" }\n"
+" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
+" forward --default-operation my -append\n"
+" method unknown {args} {\n"
+" set def --default-operation\n"
+" if {[llength $args] == 0} {\n"
+" return [uplevel 1 [list [namespace which my] $def]]\n"
+" } elseif {![string match -* [lindex $args 0]]} {\n"
+" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
+" }\n"
+" next {*}$args\n"
+" }\n"
+" export -set -append -clear\n"
+" unexport unknown destroy\n"
+"}\n"
+"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
+"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
+"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"
+);
}
/*
@@ -744,7 +776,23 @@
Object *oPtr) /* The object representing the class. */
{
int i;
- Class *clsPtr = oPtr->classPtr;
+ Class *clsPtr = oPtr->classPtr, *subclassPtr;
+ Object *instancePtr;
+
+ FOREACH(subclassPtr, clsPtr->mixinSubs) {
+ AddRef(subclassPtr);
+ AddRef(subclassPtr->thisPtr);
+ }
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ if (!(oPtr->flags & ROOT_OBJECT)
+ || (subclassPtr->thisPtr->flags & ROOT_CLASS)) {
+ AddRef(subclassPtr);
+ AddRef(subclassPtr->thisPtr);
+ }
+ }
+ FOREACH(instancePtr, clsPtr->instances) {
+ AddRef(instancePtr);
+ }
/*
* Must empty list before processing the members of the list so that
@@ -753,15 +801,10 @@
*/
if (clsPtr->mixinSubs.size > 0) {
- LIST_DYNAMIC(struct Class *) subclasses;
- Class *subclassPtr;
+ LIST_DYNAMIC(struct Class *) mixinSubs;
- TEMP_AND_CLEAR(subclasses, clsPtr->mixinSubs);
- FOREACH(subclassPtr, subclasses) {
- AddRef(subclassPtr);
- AddRef(subclassPtr->thisPtr);
- }
- FOREACH(subclassPtr, subclasses) {
+ TEMP_AND_CLEAR(mixinSubs, clsPtr->mixinSubs);
+ FOREACH(subclassPtr, mixinSubs) {
register Object *subObj = subclassPtr->thisPtr;
if (!(subObj->flags & OBJECT_DELETED)) {
@@ -771,40 +814,36 @@
DelRef(subObj);
DelRef(subclassPtr);
}
- ckfree((char *) subclasses.list);
+ ckfree((char *) mixinSubs.list);
}
if (clsPtr->subclasses.size > 0) {
LIST_DYNAMIC(Class *) subclasses;
- Class *subclassPtr;
TEMP_AND_CLEAR(subclasses, clsPtr->subclasses);
FOREACH(subclassPtr, subclasses) {
- AddRef(subclassPtr);
- AddRef(subclassPtr->thisPtr);
- }
- FOREACH(subclassPtr, subclasses) {
register Object *subObj = subclassPtr->thisPtr;
if (!(subObj->flags & OBJECT_DELETED)) {
subObj->flags |= OBJECT_DELETED;
Tcl_DeleteCommandFromToken(interp, subObj->command);
}
- DelRef(subObj);
- DelRef(subclassPtr);
+ if (!(oPtr->flags & ROOT_OBJECT) || (subObj->flags & ROOT_CLASS)) {
+ DelRef(subObj);
+ DelRef(subclassPtr);
+ }
}
ckfree((char *) subclasses.list);
}
+ if (oPtr->flags & ROOT_CLASS) {
+ oPtr->fPtr->classCls = NULL;
+ }
if (clsPtr->instances.size > 0) {
LIST_DYNAMIC(Object *) instances;
- Object *instancePtr;
TEMP_AND_CLEAR(instances, clsPtr->instances);
FOREACH(instancePtr, instances) {
- AddRef(instancePtr);
- }
- FOREACH(instancePtr, instances) {
if (!(instancePtr->flags & OBJECT_DELETED)) {
instancePtr->flags |= OBJECT_DELETED;
Tcl_DeleteCommandFromToken(interp, instancePtr->command);
@@ -844,7 +883,6 @@
clsPtr->filters.num = 0;
}
-
if (clsPtr->metadataPtr != NULL) {
FOREACH_HASH_DECLS;
Tcl_ObjectMetadataType *metadataTypePtr;
@@ -1548,7 +1586,7 @@
*/
o2Ptr->flags = oPtr->flags & ~(
- OBJECT_DELETED | ROOT_OBJECT | FILTER_HANDLING);
+ OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
/*
* Copy the object's metadata.
@@ -2035,8 +2073,13 @@
int result;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
- return TCL_ERROR;
+ contextPtr = TclOOGetCallContext(oPtr, NULL,
+ flags | (oPtr->flags & FILTER_HANDLING) | FORCE_UNKNOWN);
+ AddRef(oPtr);
+ result = TclOOInvokeContext(interp, contextPtr, objc, objv);
+ TclOODeleteContext(contextPtr);
+ DelRef(oPtr);
+ return result;
}
/*
Index: generic/tclOOBasic.c
===================================================================
RCS file: /cvsroot/tcl/oocore/generic/tclOOBasic.c,v
retrieving revision 1.8
diff -u -r1.8 tclOOBasic.c
--- generic/tclOOBasic.c 2 Feb 2010 09:11:30 -0000 1.8
+++ generic/tclOOBasic.c 22 Oct 2010 15:25:32 -0000
@@ -364,7 +364,7 @@
int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
if (objc < skip+1) {
- Tcl_WrongNumArgs(interp, skip, objv, "methodName ?arg ...?");
+ Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
return TCL_ERROR;
}
Index: generic/tclOOCall.c
===================================================================
RCS file: /cvsroot/tcl/oocore/generic/tclOOCall.c,v
retrieving revision 1.27
diff -u -r1.27 tclOOCall.c
--- generic/tclOOCall.c 14 Oct 2008 08:10:59 -0000 1.27
+++ generic/tclOOCall.c 22 Oct 2010 15:25:32 -0000
@@ -39,7 +39,7 @@
#define DEFINITE_PROTECTED 0x100000
#define DEFINITE_PUBLIC 0x200000
#define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
-#define SPECIAL (CONSTRUCTOR | DESTRUCTOR)
+#define SPECIAL (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)
/*
* Function declarations for things defined in this file.
@@ -954,6 +954,22 @@
cb.oPtr = oPtr;
/*
+ * If we're working with a forced use of unknown, do that now.
+ */
+
+ if (flags & FORCE_UNKNOWN) {
+ AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
+ &cb, NULL, 0, NULL);
+ callPtr->flags |= OO_UNKNOWN_METHOD;
+ callPtr->epoch = -1;
+ if (count == callPtr->numChain) {
+ TclOODeleteChain(callPtr);
+ return NULL;
+ }
+ goto returnContext;
+ }
+
+ /*
* Add all defined filters (if any, and if we're going to be processing
* them; they're not processed for constructors, destructors or when we're
* in the middle of processing a filter).
Index: generic/tclOODefineCmds.c
===================================================================
RCS file: /cvsroot/tcl/oocore/generic/tclOODefineCmds.c,v
retrieving revision 1.27
diff -u -r1.27 tclOODefineCmds.c
--- generic/tclOODefineCmds.c 4 Mar 2010 23:51:16 -0000 1.27
+++ generic/tclOODefineCmds.c 22 Oct 2010 15:25:32 -0000
@@ -19,6 +19,23 @@
#include "tclOOInt.h"
/*
+ * Some things that make it easier to declare a slot.
+ */
+
+struct DeclaredSlot {
+ const char *name;
+ const Tcl_MethodType getterType;
+ const Tcl_MethodType setterType;
+};
+
+#define SLOT(name,getter,setter) \
+ {"::oo::" name, \
+ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
+ getter, NULL, NULL}, \
+ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
+ setter, NULL, NULL}}
+
+/*
* Forward declarations.
*/
@@ -34,6 +51,63 @@
static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
int useClass, Tcl_Obj *const fromPtr,
Tcl_Obj *const toPtr);
+static int ClassFilterGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassFilterSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassMixinGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassMixinSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassSuperGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassSuperSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassVarsGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassVarsSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjFilterGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjFilterSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjMixinGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjMixinSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjVarsGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjVarsSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+
+/*
+ * Now define the slots used in declarations.
+ */
+
+static const struct DeclaredSlot slots[] = {
+ SLOT("define::filter", ClassFilterGet, ClassFilterSet),
+ SLOT("define::mixin", ClassMixinGet, ClassMixinSet),
+ SLOT("define::superclass", ClassSuperGet, ClassSuperSet),
+ SLOT("define::variable", ClassVarsGet, ClassVarsSet),
+ SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet),
+ SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet),
+ SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet),
+ {NULL}
+};
/*
* ----------------------------------------------------------------------
@@ -1380,42 +1454,6 @@
/*
* ----------------------------------------------------------------------
*
- * TclOODefineFilterObjCmd --
- * Implementation of the "filter" subcommand of the "oo::define" and
- * "oo::objdefine" commands.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOODefineFilterObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isInstanceFilter = PTR2INT(clientData);
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
-
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (!isInstanceFilter && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
- return TCL_ERROR;
- }
-
- if (!isInstanceFilter) {
- TclOOClassSetFilters(interp, oPtr->classPtr, objc-1, objv+1);
- } else {
- TclOOObjectSetFilters(oPtr, objc-1, objv+1);
- }
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
* TclOODefineForwardObjCmd --
* Implementation of the "forward" subcommand of the "oo::define" and
* "oo::objdefine" commands.
@@ -1529,65 +1567,6 @@
/*
* ----------------------------------------------------------------------
*
- * TclOODefineMixinObjCmd --
- * Implementation of the "mixin" subcommand of the "oo::define" and
- * "oo::objdefine" commands.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOODefineMixinObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- const int objc,
- Tcl_Obj *const *objv)
-{
- int isInstanceMixin = PTR2INT(clientData);
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Class **mixins;
- int i;
-
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (!isInstanceMixin && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
- return TCL_ERROR;
- }
- mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
-
- for (i=1 ; i<objc ; i++) {
- Class *clsPtr = GetClassInOuterContext(interp, objv[i],
- "may only mix in classes");
-
- if (clsPtr == NULL) {
- goto freeAndError;
- }
- if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
- Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
- goto freeAndError;
- }
- mixins[i-1] = clsPtr;
- }
-
- if (isInstanceMixin) {
- TclOOObjectSetMixins(oPtr, objc-1, mixins);
- } else {
- TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
- }
-
- TclStackFree(interp, mixins);
- return TCL_OK;
-
- freeAndError:
- TclStackFree(interp, mixins);
- return TCL_ERROR;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
* TclOODefineRenameMethodObjCmd --
* Implementation of the "renamemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
@@ -1642,109 +1621,6 @@
/*
* ----------------------------------------------------------------------
*
- * TclOODefineSuperclassObjCmd --
- * Implementation of the "superclass" subcommand of the "oo::define"
- * command.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOODefineSuperclassObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr;
- Foundation *fPtr = TclOOGetFoundation(interp);
- Class **superclasses, *superPtr;
- int i, j;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?");
- return TCL_ERROR;
- }
-
- /*
- * Get the class to operate on.
- */
-
- oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "only classes may have superclasses defined",
- NULL);
- return TCL_ERROR;
- }
- if (oPtr == fPtr->objectCls->thisPtr) {
- Tcl_AppendResult(interp,
- "may not modify the superclass of the root object", NULL);
- return TCL_ERROR;
- }
-
- /*
- * Allocate some working space.
- */
-
- superclasses = (Class **) ckalloc(sizeof(Class *) * (objc-1));
-
- /*
- * Parse the arguments to get the class to use as superclasses.
- */
-
- for (i=0 ; i<objc-1 ; i++) {
- Class *clsPtr = GetClassInOuterContext(interp, objv[i+1],
- "only a class can be a superclass");
-
- if (clsPtr == NULL) {
- goto failedAfterAlloc;
- }
- for (j=0 ; j<i ; j++) {
- if (superclasses[j] == clsPtr) {
- Tcl_AppendResult(interp,
- "class should only be a direct superclass once",NULL);
- goto failedAfterAlloc;
- }
- }
- if (TclOOIsReachable(oPtr->classPtr, clsPtr)) {
- Tcl_AppendResult(interp,
- "attempt to form circular dependency graph", NULL);
- failedAfterAlloc:
- ckfree((char *) superclasses);
- return TCL_ERROR;
- }
- superclasses[i] = clsPtr;
- }
-
- /*
- * Install the list of superclasses into the class. Note that this also
- * involves splicing the class out of the superclasses' subclass list that
- * it used to be a member of and splicing it into the new superclasses'
- * subclass list.
- */
-
- if (oPtr->classPtr->superclasses.num != 0) {
- FOREACH(superPtr, oPtr->classPtr->superclasses) {
- TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
- }
- ckfree((char *) oPtr->classPtr->superclasses.list);
- }
- oPtr->classPtr->superclasses.list = superclasses;
- oPtr->classPtr->superclasses.num = objc-1;
- FOREACH(superPtr, oPtr->classPtr->superclasses) {
- TclOOAddToSubclasses(oPtr->classPtr, superPtr);
- }
- BumpGlobalEpoch(interp, oPtr->classPtr);
-
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
* TclOODefineUnexportObjCmd --
* Implementation of the "unexport" subcommand of the "oo::define" and
* "oo::objdefine" commands.
@@ -1835,100 +1711,6 @@
return TCL_OK;
}
-/*
- * ----------------------------------------------------------------------
- *
- * TclOODefineVariablesObjCmd --
- * Implementation of the "variable" subcommand of the "oo::define" and
- * "oo::objdefine" commands.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOODefineVariablesObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isInstanceVars = PTR2INT(clientData);
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *variableObj;
- int i;
-
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (!isInstanceVars && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
- return TCL_ERROR;
- }
-
- for (i=1 ; i<objc ; i++) {
- const char *varName = Tcl_GetString(objv[i]);
-
- if (strstr(varName, "::") != NULL) {
- Tcl_AppendResult(interp, "invalid declared variable name \"",
- varName, "\": must not contain namespace separators",
- NULL);
- return TCL_ERROR;
- }
- if (Tcl_StringMatch(varName, "*(*)")) {
- Tcl_AppendResult(interp, "invalid declared variable name \"",
- varName, "\": must not refer to an array element", NULL);
- return TCL_ERROR;
- }
- }
- for (i=1 ; i<objc ; i++) {
- Tcl_IncrRefCount(objv[i]);
- }
-
- if (!isInstanceVars) {
- FOREACH(variableObj, oPtr->classPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != objc-1) {
- if (objc == 1) {
- ckfree((char *) oPtr->classPtr->variables.list);
- } else if (i) {
- oPtr->classPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->classPtr->variables.list,
- sizeof(Tcl_Obj *) * (objc-1));
- } else {
- oPtr->classPtr->variables.list = (Tcl_Obj **)
- ckalloc(sizeof(Tcl_Obj *) * (objc-1));
- }
- }
- if (objc > 1) {
- memcpy(oPtr->classPtr->variables.list, objv+1,
- sizeof(Tcl_Obj *) * (objc-1));
- }
- oPtr->classPtr->variables.num = objc-1;
- } else {
- FOREACH(variableObj, oPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != objc-1) {
- if (objc == 1) {
- ckfree((char *) oPtr->variables.list);
- } else if (i) {
- oPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->variables.list,
- sizeof(Tcl_Obj *) * (objc-1));
- } else {
- oPtr->variables.list = (Tcl_Obj **)
- ckalloc(sizeof(Tcl_Obj *) * (objc-1));
- }
- }
- if (objc > 1) {
- memcpy(oPtr->variables.list, objv+1, sizeof(Tcl_Obj *)*(objc-1));
- }
- oPtr->variables.num = objc-1;
- }
- return TCL_OK;
-}
-
void
Tcl_ClassSetConstructor(
Tcl_Interp *interp,
@@ -1973,6 +1755,643 @@
}
}
+int
+TclOODefineSlots(
+ Foundation *fPtr)
+{
+ const struct DeclaredSlot *slotInfoPtr;
+ Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
+ Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
+ Class *slotCls;
+
+ slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
+ fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr;
+ if (slotCls == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(getName);
+ Tcl_IncrRefCount(setName);
+ for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
+ Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
+ (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0);
+
+ if (slotObject == NULL) {
+ continue;
+ }
+ Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0,
+ &slotInfoPtr->getterType, NULL);
+ Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
+ &slotInfoPtr->setterType, NULL);
+ }
+ Tcl_DecrRefCount(getName);
+ Tcl_DecrRefCount(setName);
+ return TCL_OK;
+}
+
+static int
+ClassFilterGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *filterObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(filterObj, oPtr->classPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassFilterSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int filterc;
+ Tcl_Obj **filterv;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
+ &filterv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv);
+ return TCL_OK;
+}
+
+static int
+ClassMixinGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj;
+ Class *mixinPtr;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(mixinPtr, oPtr->classPtr->mixins) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, mixinPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+
+}
+
+static int
+ClassMixinSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int mixinc, i;
+ Tcl_Obj **mixinv;
+ Class **mixins;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "mixinList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
+ &mixinv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+
+ for (i=0 ; i<mixinc ; i++) {
+ mixins[i] = GetClassInOuterContext(interp, mixinv[i],
+ "may only mix in classes");
+ if (mixins[i] == NULL) {
+ goto freeAndError;
+ }
+ if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
+ Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+ goto freeAndError;
+ }
+ }
+
+ TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
+ TclStackFree(interp, mixins);
+ return TCL_OK;
+
+ freeAndError:
+ TclStackFree(interp, mixins);
+ return TCL_ERROR;
+}
+
+static int
+ClassSuperGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj;
+ Class *superPtr;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, superPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassSuperSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int superc, i, j;
+ Tcl_Obj **superv;
+ Class **superclasses, *superPtr;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "superclassList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
+ Tcl_AppendResult(interp,
+ "may not modify the superclass of the root object", NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &superc,
+ &superv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Allocate some working space.
+ */
+
+ superclasses = (Class **) ckalloc(sizeof(Class *) * superc);
+
+ /*
+ * Parse the arguments to get the class to use as superclasses.
+ */
+
+ for (i=0 ; i<superc ; i++) {
+ superclasses[i] = GetClassInOuterContext(interp, superv[i],
+ "only a class can be a superclass");
+ if (superclasses[i] == NULL) {
+ goto failedAfterAlloc;
+ }
+ for (j=0 ; j<i ; j++) {
+ if (superclasses[j] == superclasses[i]) {
+ Tcl_AppendResult(interp,
+ "class should only be a direct superclass once",NULL);
+ goto failedAfterAlloc;
+ }
+ }
+ if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
+ Tcl_AppendResult(interp,
+ "attempt to form circular dependency graph", NULL);
+ failedAfterAlloc:
+ ckfree((char *) superclasses);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Install the list of superclasses into the class. Note that this also
+ * involves splicing the class out of the superclasses' subclass list that
+ * it used to be a member of and splicing it into the new superclasses'
+ * subclass list.
+ */
+
+ if (oPtr->classPtr->superclasses.num != 0) {
+ FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+ }
+ ckfree((char *) oPtr->classPtr->superclasses.list);
+ }
+ oPtr->classPtr->superclasses.list = superclasses;
+ oPtr->classPtr->superclasses.num = superc;
+ FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ TclOOAddToSubclasses(oPtr->classPtr, superPtr);
+ }
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+
+ return TCL_OK;
+}
+
+static int
+ClassVarsGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *variableObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassVarsSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int varc;
+ Tcl_Obj **varv, *variableObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ for (i=0 ; i<varc ; i++) {
+ const char *varName = Tcl_GetString(varv[i]);
+
+ if (strstr(varName, "::") != NULL) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not contain namespace separators",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_StringMatch(varName, "*(*)")) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not refer to an array element", NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
+ }
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree((char *) oPtr->classPtr->variables.list);
+ } else if (i) {
+ oPtr->classPtr->variables.list = (Tcl_Obj **)
+ ckrealloc((char *) oPtr->classPtr->variables.list,
+ sizeof(Tcl_Obj *) * varc);
+ } else {
+ oPtr->classPtr->variables.list = (Tcl_Obj **)
+ ckalloc(sizeof(Tcl_Obj *) * varc);
+ }
+ }
+ if (varc > 0) {
+ memcpy(oPtr->classPtr->variables.list, varv,
+ sizeof(Tcl_Obj *) * varc);
+ }
+ oPtr->classPtr->variables.num = varc;
+ return TCL_OK;
+}
+
+static int
+ObjFilterGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *filterObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(filterObj, oPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjFilterSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int filterc;
+ Tcl_Obj **filterv;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+ if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
+ &filterv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ TclOOObjectSetFilters(oPtr, filterc, filterv);
+ return TCL_OK;
+}
+
+static int
+ObjMixinGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj;
+ Class *mixinPtr;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(mixinPtr, oPtr->mixins) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, mixinPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjMixinSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int mixinc;
+ Tcl_Obj **mixinv;
+ Class **mixins;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "mixinList");
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+ if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
+ &mixinv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+
+ for (i=0 ; i<mixinc ; i++) {
+ mixins[i] = GetClassInOuterContext(interp, mixinv[i],
+ "may only mix in classes");
+ if (mixins[i] == NULL) {
+ TclStackFree(interp, mixins);
+ return TCL_ERROR;
+ }
+ }
+
+ TclOOObjectSetMixins(oPtr, mixinc, mixins);
+ TclStackFree(interp, mixins);
+ return TCL_OK;
+}
+
+static int
+ObjVarsGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *variableObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjVarsSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int varc, i;
+ Tcl_Obj **varv, *variableObj;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "variableList");
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+ if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ for (i=0 ; i<varc ; i++) {
+ const char *varName = Tcl_GetString(varv[i]);
+
+ if (strstr(varName, "::") != NULL) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not contain namespace separators",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_StringMatch(varName, "*(*)")) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not refer to an array element", NULL);
+ return TCL_ERROR;
+ }
+ }
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
+ }
+
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree((char *) oPtr->variables.list);
+ } else if (i) {
+ oPtr->variables.list = (Tcl_Obj **)
+ ckrealloc((char *) oPtr->variables.list,
+ sizeof(Tcl_Obj *) * varc);
+ } else {
+ oPtr->variables.list = (Tcl_Obj **)
+ ckalloc(sizeof(Tcl_Obj *) * varc);
+ }
+ }
+ if (varc > 0) {
+ memcpy(oPtr->variables.list, varv, sizeof(Tcl_Obj *)*varc);
+ }
+ oPtr->variables.num = varc;
+ return TCL_OK;
+}
+
/*
* Local Variables:
* mode: c
Index: generic/tclOOInt.h
===================================================================
RCS file: /cvsroot/tcl/oocore/generic/tclOOInt.h,v
retrieving revision 1.42
diff -u -r1.42 tclOOInt.h
--- generic/tclOOInt.h 5 Mar 2010 15:39:33 -0000 1.42
+++ generic/tclOOInt.h 22 Oct 2010 15:25:32 -0000
@@ -216,6 +216,8 @@
* class of classes, and should be treated
* specially during teardown (and in a few
* other spots). */
+#define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the
+ * unknown method handler at that point. */
/*
* And the definition of a class. Note that every class also has an associated
@@ -426,30 +428,18 @@
MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineFilterObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineMixinObjCmd(ClientData clientData,
- Tcl_Interp *interp, const int objc,
- Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineSuperclassObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineVariablesObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
@@ -506,6 +496,7 @@
MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
+MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
Index: tests/oo.test
===================================================================
RCS file: /cvsroot/tcl/oocore/tests/oo.test,v
retrieving revision 1.57
diff -u -r1.57 oo.test
--- tests/oo.test 8 Oct 2010 14:02:05 -0000 1.57
+++ tests/oo.test 22 Oct 2010 15:25:32 -0000
@@ -125,6 +125,13 @@
test oo-1.5 {basic test of OO functionality} -body {
oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
+test oo-1.5.1 {basic test of OO functionality} -setup {
+ oo::object create aninstance
+} -returnCodes error -body {
+ aninstance
+} -cleanup {
+ rename aninstance {}
+} -result {wrong # args: should be "aninstance method ?arg ...?"}
test oo-1.6 {basic test of OO functionality} -setup {
oo::object create aninstance
} -body {
@@ -2420,6 +2427,87 @@
inst1 step
list [inst1 value] [inst2 value]
} -result {3 2}
+test oo-27.12 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 2,2}
+test oo-27.13 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable
+ variable x y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 2,2}
+test oo-27.14 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable -clear
+ variable y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 1,2}
+test oo-27.15 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable -set y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 1,2}
+test oo-27.16 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable -? y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -returnCodes error -match glob -result {unknown method "-?": must be *}
# A feature that's not supported because the mechanism may change without
# warning, but is supposed to work...
