summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclOO.c101
-rw-r--r--generic/tclOOBasic.c58
-rw-r--r--generic/tclOODefineCmds.c42
3 files changed, 114 insertions, 87 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 4ebcf77..2e84bf8 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -625,43 +625,62 @@ MakeAdditionalClasses(
Tcl_Namespace *objDefineNs)
{
Tcl_Interp *interp = fPtr->interp;
-
- /*
- * Make the singleton class, the SingletonInstance class, and install their
- * standard defined methods.
- */
-
- // A metaclass that is used to make classes that only permit one instance
- // of them to exist. See singleton(n).
- Object *singletonObj = (Object *) Tcl_NewObjectInstance(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);
- Class *singletonCls = singletonObj->classPtr;
+ singletonCls = singletonObj->classPtr;
TclOODefineBasicMethods(singletonCls, singletonMethods);
- // Set the superclass to oo::class
+ /* Set the superclass to oo::class */
MarkAsMetaclass(fPtr, singletonCls);
- // Unexport methods
+ /* Unexport methods */
TclOOUnexportMethods(singletonCls, "create", "createWithNamespace", NULL);
- // A mixin used to make an object so it won't be destroyed or cloned (or
- // at least not easily).
- Object *singletonInst = (Object *) Tcl_NewObjectInstance(interp,
+ singletonInst = (Object *) Tcl_NewObjectInstance(interp,
(Tcl_Class) fPtr->classCls, "::oo::SingletonInstance",
NULL, TCL_INDEX_NONE, NULL, 0);
TclOODefineBasicMethods(singletonInst->classPtr, singletonInstanceMethods);
/*
- * Make the abstract class.
+ * Make the oo::abstract class.
*/
- // A metaclass that is used to make classes that can't be directly
- // instantiated. See abstract(n).
- Object *abstractCls = (Object *) Tcl_NewObjectInstance(interp,
+ abstractCls = (Object *) Tcl_NewObjectInstance(interp,
(Tcl_Class) fPtr->classCls, "::oo::abstract",
NULL, TCL_INDEX_NONE, NULL, 0);
- // Set the superclass to oo::class
+ /* Set the superclass to oo::class */
MarkAsMetaclass(fPtr, abstractCls->classPtr);
- // Unexport methods
+ /* Unexport methods */
TclOOUnexportMethods(abstractCls->classPtr,
"create", "createWithNamespace", "new", NULL);
@@ -669,21 +688,18 @@ MakeAdditionalClasses(
* Make the configurable class and install its standard defined method.
*/
- // The class that contains the implementation of the actual
- // 'configure' method (mixed into actually configurable classes).
- // The 'configure' method is in tclOOBasic.c.
- Object *cfgSupObj = (Object *) Tcl_NewObjectInstance(interp,
+ cfgSupObj = (Object *) Tcl_NewObjectInstance(interp,
(Tcl_Class) fPtr->classCls, "::oo::configuresupport::configurable",
NULL, TCL_INDEX_NONE, NULL, 0);
- Class *cfgSupCls = cfgSupObj->classPtr;
+ 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.
+ /* 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. */
- Tcl_Namespace *cfgObjNs = Tcl_CreateNamespace(interp,
+ cfgObjNs = Tcl_CreateNamespace(interp,
"::oo::configuresupport::configurableobject", NULL, NULL);
TclCreateObjCommandInNs(interp, "property", cfgObjNs,
TclOODefinePropertyCmd, INT2PTR(1) /*useInstance*/, NULL);
@@ -692,7 +708,7 @@ MakeAdditionalClasses(
Tcl_Export(interp, cfgObjNs, "property", /*reset*/1);
TclSetNsPath((Namespace *) cfgObjNs, 1, &objDefineNs);
- Tcl_Namespace *cfgClsNs = Tcl_CreateNamespace(interp,
+ cfgClsNs = Tcl_CreateNamespace(interp,
"::oo::configuresupport::configurableclass", NULL, NULL);
TclCreateObjCommandInNs(interp, "property", cfgClsNs,
TclOODefinePropertyCmd, INT2PTR(0) /*useInstance*/, NULL);
@@ -701,21 +717,21 @@ MakeAdditionalClasses(
Tcl_Export(interp, cfgClsNs, "property", /*reset*/1);
TclSetNsPath((Namespace *) cfgClsNs, 1, &defineNs);
- // 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'.
- Object *configurableObj = (Object *) Tcl_NewObjectInstance(interp,
+ /* 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);
- Class *configurableCls = configurableObj->classPtr;
+ configurableCls = configurableObj->classPtr;
MarkAsMetaclass(fPtr, configurableCls);
Tcl_ClassSetConstructor(interp, (Tcl_Class) configurableCls, TclNewMethod(
(Tcl_Class) configurableCls, NULL, 0, &configurableConstructor, NULL));
- Tcl_Obj *nsName = Tcl_NewStringObj("::oo::configuresupport::configurableclass",
- TCL_AUTO_LENGTH);
+ /* 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);
@@ -727,8 +743,7 @@ MakeAdditionalClasses(
}
configurableCls->clsDefinitionNs = nsName;
- nsName = Tcl_NewStringObj("::oo::configuresupport::configurableobject",
- TCL_AUTO_LENGTH);
+ nsName = TclNewNamespaceObj(cfgObjNs);
Tcl_IncrRefCount(nsName);
if (cfgSupCls->objDefinitionNs != NULL) {
Tcl_DecrRefCount(cfgSupCls->objDefinitionNs);
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 36f2736..030d497 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -506,8 +506,8 @@ TclOO_Class_Cloned(
if (!originObject) {
return TCL_ERROR;
}
- // Add references so things won't vanish until after
- // UpdateClassDelegatesAfterClone is finished with them.
+ /* Add references so things won't vanish until after
+ * UpdateClassDelegatesAfterClone is finished with them. */
AddRef((Object *) originObject);
AddRef((Object *) targetObject);
TclNRAddCallback(interp, UpdateClassDelegatesAfterClone,
@@ -515,7 +515,7 @@ TclOO_Class_Cloned(
return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip);
}
-// Rebuilds the class inheritance delegation class.
+/* Rebuilds the class inheritance delegation class. */
static int
UpdateClassDelegatesAfterClone(
void *data[],
@@ -525,24 +525,28 @@ UpdateClassDelegatesAfterClone(
Object *originPtr = (Object *) data[0];
Object *targetPtr = (Object *) data[1];
if (result == TCL_OK && originPtr->classPtr && targetPtr->classPtr) {
- // Get the originating delegate to be cloned.
+ Tcl_Obj *originName, *targetName;
+ Object *originDelegate, *targetDelegate;
+ Tcl_Size i;
+ Class *mixin;
- Tcl_Obj *originName = Tcl_ObjPrintf("%s:: oo ::delegate",
+ /* Get the originating delegate to be cloned. */
+
+ originName = Tcl_ObjPrintf("%s:: oo ::delegate",
originPtr->namespacePtr->fullName);
- Object *originDelegate = (Object *) Tcl_GetObjectFromObj(interp,
- originName);
+ 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.
+ /* 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.
+ /* Create the cloned target delegate. */
- Tcl_Obj *targetName = Tcl_ObjPrintf("%s:: oo ::delegate",
+ targetName = Tcl_ObjPrintf("%s:: oo ::delegate",
targetPtr->namespacePtr->fullName);
- Object *targetDelegate = (Object *) Tcl_CopyObjectInstance(interp,
+ targetDelegate = (Object *) Tcl_CopyObjectInstance(interp,
(Tcl_Object) originDelegate, Tcl_GetString(targetName), NULL);
Tcl_BounceRefCount(targetName);
if (targetDelegate == NULL) {
@@ -550,13 +554,11 @@ UpdateClassDelegatesAfterClone(
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.
+ /* 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. */
- Tcl_Size i;
- Class *mixin;
FOREACH(mixin, targetPtr->mixins) {
if (mixin == originDelegate->classPtr) {
TclOORemoveFromInstances(targetPtr, originDelegate->classPtr);
@@ -593,13 +595,16 @@ TclOO_Configurable_Constructor(
{
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;
}
- Tcl_Obj *cfgSupportName = Tcl_NewStringObj(
+ cfgSupportName = Tcl_NewStringObj(
"::oo::configuresupport::configurable", TCL_AUTO_LENGTH);
- Class *mixin = TclOOGetClassFromObj(interp, cfgSupportName);
+ mixin = TclOOGetClassFromObj(interp, cfgSupportName);
Tcl_BounceRefCount(cfgSupportName);
if (!mixin) {
return TCL_ERROR;
@@ -1942,18 +1947,21 @@ MarkAsSingleton(
{
Class *clsPtr = (Class *) data[0];
if (result == TCL_OK && clsPtr->instances.num) {
- // Prepend oo::SingletonInstance to the list of mixins
+ /* 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;
}
- Object *oPtr = clsPtr->instances.list[0];
- Tcl_Size mixinc = oPtr->mixins.num;
- Class **mixins = (Class **)TclStackAlloc(interp,
- sizeof(Class *) * (mixinc + 1));
+ 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 *));
}
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index a2082b3..796ae37 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -37,7 +37,7 @@ 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
+ const char *defaultOp; /* The default op, if not set by the class */
} DeclaredSlot;
#define SLOT(name,getter,setter,resolver,defOp) \
@@ -1256,6 +1256,7 @@ GetOrCreateMethod(
isNew);
if (*isNew) {
Method *mPtr = (Method *) Tcl_Alloc(sizeof(Method));
+
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = namePtr;
@@ -1351,10 +1352,12 @@ TclOOExportMethods(
va_start(argList, clsPtr);
while (1) {
const char *name = va_arg(argList, char *);
+ Tcl_Obj *namePtr;
+
if (!name) {
break;
}
- Tcl_Obj *namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH);
+ namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH);
changed |= ExportMethod(clsPtr, namePtr);
Tcl_BounceRefCount(namePtr);
}
@@ -1372,10 +1375,12 @@ TclOOUnexportMethods(
va_start(argList, clsPtr);
while (1) {
const char *name = va_arg(argList, char *);
+ Tcl_Obj *namePtr;
+
if (!name) {
break;
}
- Tcl_Obj *namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH);
+ namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH);
changed |= UnexportMethod(clsPtr, namePtr);
Tcl_BounceRefCount(namePtr);
}
@@ -2095,17 +2100,19 @@ TclOODefineExportObjCmd(
{
int isInstanceExport = (clientData != NULL);
int i, changed = 0;
+ Object *oPtr;
+ Class *clsPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
return TCL_ERROR;
}
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
- Class *clsPtr = oPtr->classPtr;
+ clsPtr = oPtr->classPtr;
if (!isInstanceExport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", TCL_AUTO_LENGTH));
@@ -2621,6 +2628,7 @@ TclOODefineSlots(
Tcl_Class slotCls;
const DeclaredSlotMethod *smPtr;
const DeclaredSlot *slotPtr;
+ Tcl_Obj *defaults[2];
if (object == NULL) {
return TCL_ERROR;
@@ -2637,12 +2645,10 @@ 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)
- };
+ /* 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));
@@ -2666,12 +2672,9 @@ TclOODefineSlots(
&slotPtr->resolverType, NULL);
}
if (slotPtr->defaultOp) {
- Tcl_Obj *slotDefaults[] = {
- fPtr->myName,
- Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH)
- };
+ defaults[1] = Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH);
TclOONewForwardInstanceMethod(interp, (Object *) slotObject, 0,
- fPtr->slotDefOpName, Tcl_NewListObj(2, slotDefaults));
+ fPtr->slotDefOpName, Tcl_NewListObj(2, defaults));
}
}
return TCL_OK;
@@ -3449,10 +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;
if (clsPtr == NULL) {
return TCL_ERROR;
@@ -3463,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",
@@ -3479,7 +3484,7 @@ ClassSuper_Set(
* Allocate some working space.
*/
- Class **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.
@@ -3489,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 {
generated by cgit v0.12 at 2025-12-25 08:37:22 (GMT)