Index: TODO =================================================================== diff -u -rb70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9 -r404ad6bfcb313983a0cc54d3323751008bca991b --- TODO (.../TODO) (revision b70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9) +++ TODO (.../TODO) (revision 404ad6bfcb313983a0cc54d3323751008bca991b) @@ -1607,6 +1607,14 @@ - fix option "-source application" when applied directly on base-classes - extend regression test +- nsf.c: use name "varTablePtr" instead of "varTable" when referring to the table +- new option "slotcontainer" for "methodproperty" to flag slotcontainer to make + them easier to process in the serializer +. don't report slot container in "info methods -expand" +- new function "::nx::isSlotContainer" to centralize checking for slotcontainers + (used by serilaizer) +- support export of method ensembles in serializer + TODO: - check feasbility of "info lookup methods -expand" - handing of xo::at_cleanup in serializer Index: generic/gentclAPI.decls =================================================================== diff -u -rb70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9 -r404ad6bfcb313983a0cc54d3323751008bca991b --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision b70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 404ad6bfcb313983a0cc54d3323751008bca991b) @@ -111,7 +111,7 @@ {-argName "object" -required 1 -type object} {-argName "-per-object"} {-argName "methodName" -required 1 -type tclobj} - {-argName "methodproperty" -required 1 -type "class-only|protected|redefine-protected|returns|slotobj"} + {-argName "methodproperty" -required 1 -type "class-only|protected|redefine-protected|returns|slotcontainer|slotobj"} {-argName "value" -type tclobj} } nsfCmd my NsfMyCmd { Index: generic/nsf.c =================================================================== diff -u -rb70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9 -r404ad6bfcb313983a0cc54d3323751008bca991b --- generic/nsf.c (.../nsf.c) (revision b70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9) +++ generic/nsf.c (.../nsf.c) (revision 404ad6bfcb313983a0cc54d3323751008bca991b) @@ -200,7 +200,7 @@ static int DoDealloc(Tcl_Interp *interp, NsfObject *object); static int RecreateObject(Tcl_Interp *interp, NsfClass *cl, NsfObject *object, int objc, Tcl_Obj *CONST objv[]); static void FinalObjectDeletion(Tcl_Interp *interp, NsfObject *object); -static void FreeAllNsfObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandNameTable); +static void FreeAllNsfObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandNameTablePtr); static void CallStackDestroyObject(Tcl_Interp *interp, NsfObject *object); static void PrimitiveCDestroy(ClientData clientData); static void PrimitiveODestroy(ClientData clientData); @@ -210,7 +210,7 @@ /* prototypes for object lookup */ static NsfObject *GetObjectFromString(Tcl_Interp *interp, CONST char *name); static NsfClass *GetClassFromString(Tcl_Interp *interp, CONST char *name); -static void GetAllInstances(Tcl_Interp *interp, Tcl_HashTable *destTable, NsfClass *startClass); +static void GetAllInstances(Tcl_Interp *interp, Tcl_HashTable *destTablePtr, NsfClass *startClass); /* prototypes for namespace specific calls*/ static Tcl_Obj *NameInNamespaceObj(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *ns); @@ -357,7 +357,7 @@ #define VarHashGetValue(hPtr) ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) #define VarHashGetKey(varPtr) (((VarInHash *)(varPtr))->entry.key.objPtr) -#define VarHashTable(varTable) &(varTable)->table +#define VarHashTablePtr(varTablePtr) &(varTablePtr)->table #define valueOfVar(type, varPtr, field) (type *)(varPtr)->value.field NSF_INLINE static Tcl_Namespace * @@ -1016,10 +1016,9 @@ NSF_INLINE static Tcl_Command FindMethod(Tcl_Namespace *nsPtr, CONST char *methodName) { register Tcl_HashEntry *entryPtr; - if ((entryPtr = Tcl_CreateHashEntry(Tcl_Namespace_cmdTable(nsPtr), methodName, NULL))) { + if ((entryPtr = Tcl_CreateHashEntry(Tcl_Namespace_cmdTablePtr(nsPtr), methodName, NULL))) { return (Tcl_Command) Tcl_GetHashValue(entryPtr); } - /*fprintf(stderr, "find %s in %p returns %p\n", methodName, cmdTable, cmd);*/ return NULL; } @@ -1033,7 +1032,7 @@ /* Search the precedence list (class hierarchy) */ #if 1 for (; pl; pl = pl->nextPtr) { - register Tcl_HashEntry *entryPtr = Tcl_CreateHashEntry(Tcl_Namespace_cmdTable(pl->cl->nsPtr), methodName, NULL); + register Tcl_HashEntry *entryPtr = Tcl_CreateHashEntry(Tcl_Namespace_cmdTablePtr(pl->cl->nsPtr), methodName, NULL); if (entryPtr) { *cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); return pl->cl; @@ -1660,27 +1659,27 @@ /* * Copy all obj variables to the newly created namespace */ - if (object->varTable) { + if (object->varTablePtr) { Tcl_HashSearch search; Tcl_HashEntry *hPtr; - TclVarHashTable *varTable = Tcl_Namespace_varTable(nsPtr); - Tcl_HashTable *varHashTable = VarHashTable(varTable); - Tcl_HashTable *objHashTable = VarHashTable(object->varTable); + TclVarHashTable *varTablePtr = Tcl_Namespace_varTablePtr(nsPtr); + Tcl_HashTable *varHashTablePtr = VarHashTablePtr(varTablePtr); + Tcl_HashTable *objHashTablePtr = VarHashTablePtr(object->varTablePtr); - *varHashTable = *objHashTable; /* copy the table */ + *varHashTablePtr = *objHashTablePtr; /* copy the table */ - if (objHashTable->buckets == objHashTable->staticBuckets) { - varHashTable->buckets = varHashTable->staticBuckets; + if (objHashTablePtr->buckets == objHashTablePtr->staticBuckets) { + varHashTablePtr->buckets = varHashTablePtr->staticBuckets; } - for (hPtr = Tcl_FirstHashEntry(varHashTable, &search); hPtr; + for (hPtr = Tcl_FirstHashEntry(varHashTablePtr, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - hPtr->tablePtr = varHashTable; + hPtr->tablePtr = varHashTablePtr; } - CallStackReplaceVarTableReferences(interp, object->varTable, - (TclVarHashTable *)varHashTable); + CallStackReplaceVarTableReferences(interp, object->varTablePtr, + (TclVarHashTable *)varHashTablePtr); - ckfree((char *) object->varTable); - object->varTable = NULL; + ckfree((char *) object->varTablePtr); + object->varTablePtr = NULL; } } } @@ -1792,7 +1791,7 @@ /* We have an object and create the variable if not found */ assert(object); - varTablePtr = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; + varTablePtr = object->nsPtr ? Tcl_Namespace_varTablePtr(object->nsPtr) : object->varTablePtr; assert(varTablePtr); /* @@ -1914,7 +1913,7 @@ HashVarFree(var); } - varTablePtr = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; + varTablePtr = object->nsPtr ? Tcl_Namespace_varTablePtr(object->nsPtr) : object->varTablePtr; assert(varTablePtr); resVarInfo->lastObject = object; @@ -2075,11 +2074,16 @@ /* We have an object and create the variable if not found */ assert(object); - - varTablePtr = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; + varTablePtr = object->nsPtr ? Tcl_Namespace_varTablePtr(object->nsPtr) : object->varTablePtr; +#if 0 + if (varTablePtr == NULL) { + /* this seems to be the first access to object->varTablePtr for this object */ + varTablePtr = object->varTablePtr = VarHashTableCreate(); + } +#endif assert(varTablePtr); - /*fprintf(stderr, "Object Var Resolver, name=%s, obj %p, nsPtr %p, varTable %p\n", + /*fprintf(stderr, "Object Var Resolver, name=%s, obj %p, nsPtr %p, varTablePtr %p\n", varName, object, object->nsPtr, varTablePtr);*/ keyObj = Tcl_NewStringObj(varName, -1); @@ -2222,7 +2226,7 @@ static void NSDeleteChildren(Tcl_Interp *interp, Tcl_Namespace *nsPtr) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(nsPtr); + Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(nsPtr); Tcl_HashSearch hSrch; Tcl_HashEntry *hPtr; @@ -2232,7 +2236,7 @@ Tcl_ForgetImport(interp, nsPtr, "*"); /* don't destroy namespace imported objects */ - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; + for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); @@ -2271,7 +2275,7 @@ } /* - * ensure that a variable exists on object varTable or nsPtr->varTable, + * ensure that a variable exists on object varTablePtr or nsPtr->varTablePtr, * if necessary create it. Return Var* if successful, otherwise 0 */ static Var * @@ -2297,26 +2301,26 @@ */ static void NSCleanupNamespace(Tcl_Interp *interp, Tcl_Namespace *ns) { - TclVarHashTable *varTable = Tcl_Namespace_varTable(ns); - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); + TclVarHashTable *varTablePtr = Tcl_Namespace_varTablePtr(ns); + Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(ns); Tcl_HashSearch hSrch; Tcl_HashEntry *hPtr; #ifdef OBJDELETION_TRACE fprintf(stderr, "NSCleanupNamespace %p\n", ns); - fprintf(stderr, "NSCleanupNamespace %p %.6x varTable %p\n", ns, ((Namespace *)ns)->flags, varTable); + fprintf(stderr, "NSCleanupNamespace %p %.6x varTablePtr %p\n", ns, ((Namespace *)ns)->flags, varTablePtr); #endif /* * Delete all variables and initialize var table again * (DeleteVars frees the vartable) */ - TclDeleteVars((Interp *)interp, varTable); - TclInitVarHashTable(varTable, (Namespace *)ns); + TclDeleteVars((Interp *)interp, varTablePtr); + TclInitVarHashTable(varTablePtr, (Namespace *)ns); /* * Delete all user-defined procs in the namespace */ - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; + for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { Tcl_Command cmd = (Tcl_Command) Tcl_GetHashValue(hPtr); Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); @@ -3770,9 +3774,9 @@ *---------------------------------------------------------------------- */ static int -AddToResultSet(Tcl_Interp *interp, Tcl_HashTable *destTable, NsfObject *object, int *new, +AddToResultSet(Tcl_Interp *interp, Tcl_HashTable *destTablePtr, NsfObject *object, int *new, int appendResult, CONST char *pattern, NsfObject *matchObject) { - Tcl_CreateHashEntry(destTable, (char *)object, new); + Tcl_CreateHashEntry(destTablePtr, (char *)object, new); if (*new) { if (matchObject && matchObject == object) { return 1; @@ -3801,10 +3805,10 @@ *---------------------------------------------------------------------- */ static int -AddToResultSetWithGuards(Tcl_Interp *interp, Tcl_HashTable *destTable, NsfClass *cl, +AddToResultSetWithGuards(Tcl_Interp *interp, Tcl_HashTable *destTablePtr, NsfClass *cl, ClientData clientData, int *new, int appendResult, CONST char *pattern, NsfObject *matchObject) { - Tcl_CreateHashEntry(destTable, (char *)cl, new); + Tcl_CreateHashEntry(destTablePtr, (char *)cl, new); if (*new) { if (appendResult) { if (!pattern || Tcl_StringMatch(className(cl), pattern)) { @@ -3843,7 +3847,7 @@ *---------------------------------------------------------------------- */ static int -GetAllObjectMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, NsfClass *startCl, +GetAllObjectMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTablePtr, NsfClass *startCl, int isMixin, int appendResult, CONST char *pattern, NsfObject *matchObject) { int rc = 0, new = 0; @@ -3856,7 +3860,8 @@ * check all subclasses of startCl for mixins */ for (sc = startCl->sub; sc; sc = sc->nextPtr) { - rc = GetAllObjectMixinsOf(interp, destTable, sc->cl, isMixin, appendResult, pattern, matchObject); + rc = GetAllObjectMixinsOf(interp, destTablePtr, sc->cl, isMixin, appendResult, + pattern, matchObject); if (rc) {return rc;} } /*fprintf(stderr, "check subclasses of %s done\n", ObjStr(startCl->object.cmdName));*/ @@ -3873,7 +3878,8 @@ assert(cl); /*fprintf(stderr, "check %s mixinof %s\n", className(cl), ObjStr(startCl->object.cmdName));*/ - rc = GetAllObjectMixinsOf(interp, destTable, cl, isMixin, appendResult, pattern, matchObject); + rc = GetAllObjectMixinsOf(interp, destTablePtr, cl, isMixin, appendResult, + pattern, matchObject); /* fprintf(stderr, "check %s mixinof %s done\n", className(cl), ObjStr(startCl->object.cmdName));*/ if (rc) {return rc;} @@ -3895,7 +3901,8 @@ object = NsfGetObjectFromCmdPtr(m->cmdPtr); assert(object); - rc = AddToResultSet(interp, destTable, object, &new, appendResult, pattern, matchObject); + rc = AddToResultSet(interp, destTablePtr, object, &new, appendResult, + pattern, matchObject); if (rc == 1) {return rc;} } } @@ -3921,8 +3928,8 @@ *---------------------------------------------------------------------- */ static int -GetAllClassMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, /*@notnull@*/ NsfClass *startCl, - int isMixin, +GetAllClassMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTablePtr, + /*@notnull@*/ NsfClass *startCl, int isMixin, int appendResult, CONST char *pattern, NsfObject *matchObject) { int rc = 0, new = 0; NsfClass *cl; @@ -3937,15 +3944,17 @@ * the startCl is a per class mixin, add it to the result set */ if (isMixin) { - rc = AddToResultSet(interp, destTable, &startCl->object, &new, appendResult, pattern, matchObject); + rc = AddToResultSet(interp, destTablePtr, &startCl->object, &new, appendResult, + pattern, matchObject); if (rc == 1) {return rc;} /* * check all subclasses of startCl for mixins */ for (sc = startCl->sub; sc; sc = sc->nextPtr) { if (sc->cl != startCl) { - rc = GetAllClassMixinsOf(interp, destTable, sc->cl, isMixin, appendResult, pattern, matchObject); + rc = GetAllClassMixinsOf(interp, destTablePtr, sc->cl, isMixin, appendResult, + pattern, matchObject); if (rc) {return rc;} } else { /* TODO: sanity check; it seems that we can create via @@ -3971,11 +3980,13 @@ cl = NsfGetClassFromCmdPtr(m->cmdPtr); assert(cl); - rc = AddToResultSet(interp, destTable, &cl->object, &new, appendResult, pattern, matchObject); + rc = AddToResultSet(interp, destTablePtr, &cl->object, &new, appendResult, + pattern, matchObject); if (rc == 1) {return rc;} if (new) { /*fprintf(stderr, "... new\n");*/ - rc = GetAllClassMixinsOf(interp, destTable, cl, 1, appendResult, pattern, matchObject); + rc = GetAllClassMixinsOf(interp, destTablePtr, cl, 1, appendResult, + pattern, matchObject); if (rc) {return rc;} } } @@ -4002,7 +4013,7 @@ */ static int -GetAllClassMixins(Tcl_Interp *interp, Tcl_HashTable *destTable, NsfClass *startCl, +GetAllClassMixins(Tcl_Interp *interp, Tcl_HashTable *destTablePtr, NsfClass *startCl, int withGuards, CONST char *pattern, NsfObject *matchObject) { int rc = 0, new = 0; NsfClass *cl; @@ -4026,16 +4037,20 @@ if ((withGuards) && (m->clientData)) { /* fprintf(stderr, "AddToResultSetWithGuards: %s\n", className(cl)); */ - rc = AddToResultSetWithGuards(interp, destTable, cl, m->clientData, &new, 1, pattern, matchObject); + rc = AddToResultSetWithGuards(interp, destTablePtr, cl, m->clientData, &new, 1, + pattern, matchObject); } else { /* fprintf(stderr, "AddToResultSet: %s\n", className(cl)); */ - rc = AddToResultSet(interp, destTable, &cl->object, &new, 1, pattern, matchObject); + rc = AddToResultSet(interp, destTablePtr, &cl->object, &new, 1, + pattern, matchObject); } if (rc == 1) {return rc;} if (new) { - /* fprintf(stderr, "class mixin GetAllClassMixins for: %s (%s)\n", className(cl), ObjStr(startCl->object.cmdName)); */ - rc = GetAllClassMixins(interp, destTable, cl, withGuards, pattern, matchObject); + /* fprintf(stderr, "class mixin GetAllClassMixins for: %s (%s)\n", + className(cl), ObjStr(startCl->object.cmdName)); */ + rc = GetAllClassMixins(interp, destTablePtr, cl, withGuards, + pattern, matchObject); if (rc) {return rc;} } } @@ -4046,8 +4061,10 @@ * check all superclasses of startCl for classmixins */ for (sc = startCl->super; sc; sc = sc->nextPtr) { - /* fprintf(stderr, "Superclass GetAllClassMixins for %s (%s)\n", ObjStr(sc->cl->object.cmdName), ObjStr(startCl->object.cmdName)); */ - rc = GetAllClassMixins(interp, destTable, sc->cl, withGuards, pattern, matchObject); + /* fprintf(stderr, "Superclass GetAllClassMixins for %s (%s)\n", + ObjStr(sc->cl->object.cmdName), ObjStr(startCl->object.cmdName)); */ + rc = GetAllClassMixins(interp, destTablePtr, sc->cl, withGuards, + pattern, matchObject); if (rc) {return rc;} } return rc; @@ -7945,16 +7962,16 @@ if (tmpObject) { Tcl_HashSearch hSrch; Tcl_HashEntry *hPtr, *slotEntry; - Tcl_HashTable *cmdTable; + Tcl_HashTable *cmdTablePtr; Tcl_Command cmd; int new; if (!tmpObject->nsPtr) continue; - cmdTable = Tcl_Namespace_cmdTable(tmpObject->nsPtr); + cmdTablePtr = Tcl_Namespace_cmdTablePtr(tmpObject->nsPtr); - hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch); for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(cmdTable, hPtr); + char *key = Tcl_GetHashKey(cmdTablePtr, hPtr); slotEntry = Tcl_CreateHashEntry(&slotTable, key, &new); if (!new) continue; cmd = (Tcl_Command) Tcl_GetHashValue(hPtr); @@ -8594,7 +8611,7 @@ if (nsPtr) { Tcl_HashSearch search; - Tcl_HashEntry *entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + Tcl_HashEntry *entryPtr = Tcl_FirstHashEntry(Tcl_Namespace_childTablePtr(nsPtr), &search); Tcl_Var *varPtr; int result; @@ -8718,12 +8735,12 @@ NSDeleteChildren(interp, object->nsPtr); } - if (object->varTable) { - TclDeleteVars(((Interp *)interp), object->varTable); + if (object->varTablePtr) { + TclDeleteVars(((Interp *)interp), object->varTablePtr); - ckfree((char *)object->varTable); - /*FREE(obj->varTable, obj->varTable);*/ - object->varTable = 0; + ckfree((char *)object->varTablePtr); + /*FREE(obj->varTablePtr, obj->varTablePtr);*/ + object->varTablePtr = 0; } if (object->opt) { @@ -8766,10 +8783,10 @@ AddInstance(object, cl); } if (object->flags & NSF_RECREATE) { - object->opt = 0; - object->varTable = 0; - object->mixinOrder = 0; - object->filterOrder = 0; + object->opt = NULL; + object->varTablePtr = NULL; + object->mixinOrder = NULL; + object->filterOrder = NULL; object->flags = 0; } /* @@ -9666,9 +9683,6 @@ newName = varName; } varNameString = ObjStr(newName); - - - varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); /* @@ -11536,20 +11550,25 @@ if (isObject && withExpand) { Tcl_DString ds, *dsPtr = &ds; NsfObject *ensembleObject = NsfGetObjectFromCmdPtr(cmd); - Tcl_HashTable *cmdTable = ensembleObject && ensembleObject->nsPtr ? - Tcl_Namespace_cmdTable(ensembleObject->nsPtr) : NULL; + Tcl_HashTable *cmdTablePtr = ensembleObject && ensembleObject->nsPtr ? + Tcl_Namespace_cmdTablePtr(ensembleObject->nsPtr) : NULL; + if (ensembleObject->flags & NSF_IS_SLOT_CONTAINER) { + /* Don't report slot container */ + continue; + } + if (prefix == NULL) { DSTRING_INIT(dsPtr); Tcl_DStringAppend(dsPtr, key, -1); Tcl_DStringAppend(dsPtr, " ", 1); - ListMethodKeys(interp, cmdTable, dsPtr, pattern, methodType, withCallprotection, + ListMethodKeys(interp, cmdTablePtr, dsPtr, pattern, methodType, withCallprotection, 1, dups, object, withPer_object); DSTRING_FREE(dsPtr); } else { Tcl_DStringAppend(prefix, key, -1); Tcl_DStringAppend(prefix, " ", 1); - ListMethodKeys(interp, cmdTable, prefix, pattern, methodType, withCallprotection, + ListMethodKeys(interp, cmdTablePtr, prefix, pattern, methodType, withCallprotection, 1, dups, object, withPer_object); } /* don't list ensembles by themselves */ @@ -11579,11 +11598,11 @@ static int ListChildren(Tcl_Interp *interp, NsfObject *object, CONST char *pattern, int classesOnly, NsfClass *type) { NsfObject *childObject; - Tcl_HashTable *cmdTable; + Tcl_HashTable *cmdTablePtr; if (!object->nsPtr) return TCL_OK; - cmdTable = Tcl_Namespace_cmdTable(object->nsPtr); + cmdTablePtr = Tcl_Namespace_cmdTablePtr(object->nsPtr); if (pattern && NoMetaChars(pattern)) { if ((childObject = GetObjectFromString(interp, pattern)) && @@ -11599,11 +11618,11 @@ } else { Tcl_Obj *list = Tcl_NewListObj(0, NULL); Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch); char *key; for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - key = Tcl_GetHashKey(cmdTable, hPtr); + key = Tcl_GetHashKey(cmdTablePtr, hPtr); if (!pattern || Tcl_StringMatch(key, pattern)) { Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); @@ -11654,14 +11673,14 @@ ListDefinedMethods(Tcl_Interp *interp, NsfObject *object, CONST char *pattern, int withPer_object, int methodType, int withCallproctection, int withExpand, int noMixins, int inContext) { - Tcl_HashTable *cmdTable; + Tcl_HashTable *cmdTablePtr; if (NsfObjectIsClass(object) && !withPer_object) { - cmdTable = Tcl_Namespace_cmdTable(((NsfClass *)object)->nsPtr); + cmdTablePtr = Tcl_Namespace_cmdTablePtr(((NsfClass *)object)->nsPtr); } else { - cmdTable = object->nsPtr ? Tcl_Namespace_cmdTable(object->nsPtr) : NULL; + cmdTablePtr = object->nsPtr ? Tcl_Namespace_cmdTablePtr(object->nsPtr) : NULL; } - ListMethodKeys(interp, cmdTable, NULL, pattern, methodType, withCallproctection, withExpand, + ListMethodKeys(interp, cmdTablePtr, NULL, pattern, methodType, withCallproctection, withExpand, NULL, object, withPer_object); return TCL_OK; } @@ -12648,7 +12667,7 @@ {-argName "object" -required 1 -type object} {-argName "-per-object"} {-argName "methodName" -required 1 -type tclobj} - {-argName "methodproperty" -required 1 -type "class-only|protected|redefine-protected|returns|slotobj"} + {-argName "methodproperty" -required 1 -type "class-only|protected|redefine-protected|returns|slotcontainer|slotobj"} {-argName "value" -type tclobj} } */ @@ -12660,9 +12679,8 @@ Tcl_DString ds, *dsPtr = &ds; Tcl_Command cmd = NULL; NsfClass *cl = withPer_object == 0 && NsfObjectIsClass(object) ? (NsfClass *)object : NULL; - int fromClassNS = cl != NULL; + int flag, fromClassNS = cl != NULL; - /*fprintf(stderr, "methodProperty for method '%s' prop %d value %s\n", methodName, methodproperty, valueObj ? ObjStr(valueObj) : "NULL");*/ @@ -12683,14 +12701,14 @@ switch (methodproperty) { case MethodpropertyClass_onlyIdx: /* fall through */ - case MethodpropertyProtectedIdx: /* fall through */ - case MethodpropertyRedefine_protectedIdx: + case MethodpropertyProtectedIdx: /* fall through */ + case MethodpropertyRedefine_protectedIdx: /* fall through */ { - int flag = methodproperty == MethodpropertyProtectedIdx ? - NSF_CMD_PROTECTED_METHOD : - methodproperty == MethodpropertyRedefine_protectedIdx ? - NSF_CMD_REDEFINE_PROTECTED_METHOD - :NSF_CMD_CLASS_ONLY_METHOD; + switch (methodproperty) { + case MethodpropertyClass_onlyIdx: flag = NSF_CMD_CLASS_ONLY_METHOD; break; + case MethodpropertyProtectedIdx: flag = NSF_CMD_PROTECTED_METHOD; break; + case MethodpropertyRedefine_protectedIdx: flag = NSF_CMD_REDEFINE_PROTECTED_METHOD; break; + } if (valueObj) { int bool, result; @@ -12707,6 +12725,28 @@ Tcl_SetIntObj(Tcl_GetObjResult(interp), (Tcl_Command_flags(cmd) & flag) != 0); break; } + case MethodpropertySlotcontainerIdx: + { + NsfObject *containerObject = NsfGetObjectFromCmdPtr(cmd); + if (containerObject == NULL) { + return NsfVarErrMsg(interp, "slot container must be an object", (char *) NULL); + } + flag = NSF_IS_SLOT_CONTAINER; + if (valueObj) { + int bool, result; + result = Tcl_GetBooleanFromObj(interp, valueObj, &bool); + if (result != TCL_OK) { + return result; + } + if (bool) { + containerObject->flags |= flag; + } else { + containerObject->flags &= ~flag; + } + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), (containerObject->flags & flag) != 0); + break; + } case MethodpropertySlotobjIdx: case MethodpropertyReturnsIdx: { @@ -12814,7 +12854,7 @@ Tcl_Obj *newFullCmdName, *oldFullCmdName; CONST char *newName, *oldName, *name; Tcl_Namespace *fromNsPtr, *toNsPtr; - Tcl_HashTable *cmdTable; + Tcl_HashTable *cmdTablePtr; Tcl_HashSearch hSrch; Tcl_HashEntry *hPtr; NsfObject *object; @@ -12846,11 +12886,11 @@ /* * copy all procs & commands in the ns */ - cmdTable = Tcl_Namespace_cmdTable(fromNsPtr); - hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + cmdTablePtr = Tcl_Namespace_cmdTablePtr(fromNsPtr); + hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch); while (hPtr) { - /*fprintf(stderr, "copy cmdTable = %p, first=%p\n", cmdTable, hPtr);*/ - name = Tcl_GetHashKey(cmdTable, hPtr); + /*fprintf(stderr, "copy cmdTablePtr = %p, first=%p\n", cmdTablePtr, hPtr);*/ + name = Tcl_GetHashKey(cmdTablePtr, hPtr); /* * construct full cmd names @@ -13016,7 +13056,7 @@ Var *varPtr = NULL; Tcl_HashSearch hSrch; Tcl_HashEntry *hPtr; - TclVarHashTable *varTable; + TclVarHashTable *varTablePtr; NsfObject *object, *destObject; CONST char *destFullName; Tcl_Obj *destFullNameObj; @@ -13036,7 +13076,7 @@ destFullName = toNsPtr->fullName; destFullNameObj = Tcl_NewStringObj(destFullName, -1); INCR_REF_COUNT(destFullNameObj); - varTable = Tcl_Namespace_varTable(fromNsPtr); + varTablePtr = Tcl_Namespace_varTablePtr(fromNsPtr); Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, toNsPtr, 0); } else { NsfObject *newObject; @@ -13048,15 +13088,15 @@ return NsfVarErrMsg(interp, "CopyVars: Destination object/namespace ", ObjStr(toNs), " does not exist", (char *) NULL); } - varTable = object->varTable; + varTablePtr = object->varTablePtr; destFullNameObj = newObject->cmdName; destFullName = ObjStr(destFullNameObj); } destObject = GetObjectFromString(interp, destFullName); /* copy all vars in the ns */ - hPtr = varTable ? Tcl_FirstHashEntry(VarHashTable(varTable), &hSrch) : NULL; + hPtr = varTablePtr ? Tcl_FirstHashEntry(VarHashTablePtr(varTablePtr), &hSrch) : NULL; while (hPtr) { GetVarAndNameFromHash(hPtr, &varPtr, &varNameObj); @@ -13084,7 +13124,7 @@ /* HERE!! PRE85 Why not [array get/set] based? Let the core iterate*/ TclVarHashTable *aTable = valueOfVar(TclVarHashTable, varPtr, tablePtr); Tcl_HashSearch ahSrch; - Tcl_HashEntry *ahPtr = aTable ? Tcl_FirstHashEntry(VarHashTable(aTable), &ahSrch) :0; + Tcl_HashEntry *ahPtr = aTable ? Tcl_FirstHashEntry(VarHashTablePtr(aTable), &ahSrch) :0; for (; ahPtr; ahPtr = Tcl_NextHashEntry(&ahSrch)) { Tcl_Obj *eltNameObj; Var *eltVar; @@ -14411,7 +14451,7 @@ /* * much of this is copied from Tcl, since we must avoid * access with flag TCL_GLOBAL_ONLY ... doesn't work on - * obj->varTable vars + * obj->varTablePtr vars */ if (Tcl_TraceVar(interp, varname, flgs, (Tcl_VarTraceProc *)VwaitVarProc, (ClientData) &done) != TCL_OK) { @@ -14980,7 +15020,7 @@ static int NsfObjInfoForwardMethod(Tcl_Interp *interp, NsfObject *object, int withDefinition, CONST char *pattern) { return object->nsPtr ? - ListForward(interp, Tcl_Namespace_cmdTable(object->nsPtr), pattern, withDefinition) : + ListForward(interp, Tcl_Namespace_cmdTablePtr(object->nsPtr), pattern, withDefinition) : TCL_OK; } @@ -15118,7 +15158,7 @@ CONST char *pattern) { NsfClasses *pl; int withPer_object = 1; - Tcl_HashTable *cmdTable, dupsTable, *dups = &dupsTable; + Tcl_HashTable *cmdTablePtr, dupsTable, *dups = &dupsTable; int methodType = AggregatedMethodType(withMethodtype); /* @@ -15136,9 +15176,9 @@ Tcl_InitHashTable(dups, TCL_STRING_KEYS); if (object->nsPtr) { - cmdTable = Tcl_Namespace_cmdTable(object->nsPtr); + cmdTablePtr = Tcl_Namespace_cmdTablePtr(object->nsPtr); if (MethodSourceMatches(interp, withSource, NULL, object)) { - ListMethodKeys(interp, cmdTable, NULL, pattern, methodType, withCallprotection, 0, + ListMethodKeys(interp, cmdTablePtr, NULL, pattern, methodType, withCallprotection, 0, dups, object, withPer_object); } } @@ -15159,9 +15199,9 @@ } } if (mixin && guardOk == TCL_OK) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(mixin->nsPtr); + Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(mixin->nsPtr); if (!MethodSourceMatches(interp, withSource, mixin, NULL)) continue; - ListMethodKeys(interp, cmdTable, NULL, pattern, methodType, withCallprotection, 0, + ListMethodKeys(interp, cmdTablePtr, NULL, pattern, methodType, withCallprotection, 0, dups, object, withPer_object); } } @@ -15170,9 +15210,9 @@ /* append method keys from inheritance order */ for (pl = ComputeOrder(object->cl, object->cl->order, Super); pl; pl = pl->nextPtr) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(pl->cl->nsPtr); + Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(pl->cl->nsPtr); if (!MethodSourceMatches(interp, withSource, pl->cl, NULL)) continue; - ListMethodKeys(interp, cmdTable, NULL, pattern, methodType, withCallprotection, 0, + ListMethodKeys(interp, cmdTablePtr, NULL, pattern, methodType, withCallprotection, 0, dups, object, withPer_object); } Tcl_DeleteHashTable(dups); @@ -15320,9 +15360,11 @@ NsfObjInfoVarsMethod(Tcl_Interp *interp, NsfObject *object, CONST char *pattern) { Tcl_Obj *varlist, *okList, *element; int i, length; - TclVarHashTable *varTable = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; + TclVarHashTable *varTablePtr = object->nsPtr ? + Tcl_Namespace_varTablePtr(object->nsPtr) : + object->varTablePtr; - ListVarKeys(interp, VarHashTable(varTable), pattern); + ListVarKeys(interp, VarHashTablePtr(varTablePtr), pattern); varlist = Tcl_GetObjResult(interp); Tcl_ListObjLength(interp, varlist, &length); @@ -15378,7 +15420,7 @@ static int NsfClassInfoForwardMethod(Tcl_Interp *interp, NsfClass *class, int withDefinition, CONST char *pattern) { - return ListForward(interp, Tcl_Namespace_cmdTable(class->nsPtr), pattern, withDefinition); + return ListForward(interp, Tcl_Namespace_cmdTablePtr(class->nsPtr), pattern, withDefinition); } /* @@ -15777,27 +15819,27 @@ static void DeleteProcsAndVars(Tcl_Interp *interp) { Tcl_Namespace *nsPtr = Tcl_GetGlobalNamespace(interp); - Tcl_HashTable *varTable = nsPtr ? Tcl_Namespace_varTable(ns) : NULL; - Tcl_HashTable *cmdTable = nsPtr ? Tcl_Namespace_cmdTable(ns) : NULL; + Tcl_HashTable *varTablePtr = nsPtr ? Tcl_Namespace_varTablePtr(ns) : NULL; + Tcl_HashTable *cmdTablePtr = nsPtr ? Tcl_Namespace_cmdTablePtr(ns) : NULL; Tcl_HashSearch search; Var *varPtr; Tcl_Command cmd; register Tcl_HashEntry *entryPtr; char *varName; - for (entryPtr = Tcl_FirstHashEntry(varTable, &search); entryPtr; entryPtr = Tcl_NextHashEntry(&search)) { + for (entryPtr = Tcl_FirstHashEntry(varTablePtr, &search); entryPtr; entryPtr = Tcl_NextHashEntry(&search)) { Tcl_Obj *nameObj; GetVarAndNameFromHash(entryPtr, &varPtr, &nameObj); if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { /* fprintf(stderr, "unsetting var %s\n", ObjStr(nameObj));*/ Tcl_UnsetVar2(interp, ObjStr(nameObj), (char *)NULL, TCL_GLOBAL_ONLY); } } - for (entryPtr = Tcl_FirstHashEntry(cmdTable, &search); entryPtr; entryPtr = Tcl_NextHashEntry(&search)) { + for (entryPtr = Tcl_FirstHashEntry(cmdTablePtr, &search); entryPtr; entryPtr = Tcl_NextHashEntry(&search)) { cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) { - char *key = Tcl_GetHashKey(cmdTable, entryPtr); + char *key = Tcl_GetHashKey(cmdTablePtr, entryPtr); /*fprintf(stderr, "cmdname = %s cmd %p proc %p objProc %p %d\n", key, cmd, Tcl_Command_proc(cmd), Tcl_Command_objProc(cmd), @@ -15830,9 +15872,9 @@ if (ns) { Tcl_HashEntry *hPtr; Tcl_HashSearch hSrch; - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); + Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(ns); - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; + for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { Tcl_Command cmd = Tcl_GetHashValue(hPtr); NsfObject *childObject = NsfGetObjectFromCmdPtr(cmd); @@ -15875,7 +15917,7 @@ } static void -FreeAllNsfObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandNameTable) { +FreeAllNsfObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandNameTablePtr) { Tcl_HashEntry *hPtr, *hPtr2; Tcl_HashSearch hSrch, hSrch2; NsfObject *object; @@ -15891,13 +15933,13 @@ * imported commands and objects and will resolve potential loops in * the dependency graph. The result is a plain object/class tree. */ - for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(commandNameTable, hPtr); + for (hPtr = Tcl_FirstHashEntry(commandNameTablePtr, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandNameTablePtr, hPtr); object = GetObjectFromString(interp, key); /* delete per-object methods */ if (object && object->nsPtr) { - for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTable(object->nsPtr), &hSrch2); hPtr2; + for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTablePtr(object->nsPtr), &hSrch2); hPtr2; hPtr2 = Tcl_NextHashEntry(&hSrch2)) { Tcl_Command cmd = Tcl_GetHashValue(hPtr2); if (cmd) { @@ -15916,7 +15958,8 @@ * objects, which will resolved this way. */ if (object && NsfObjectIsClass(object)) { - for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTable(((NsfClass *)object)->nsPtr), &hSrch2); hPtr2; + for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTablePtr(((NsfClass *)object)->nsPtr), + &hSrch2); hPtr2; hPtr2 = Tcl_NextHashEntry(&hSrch2)) { Tcl_Command cmd = Tcl_GetHashValue(hPtr2); if (cmd) { @@ -15943,8 +15986,9 @@ * Delete all plain objects without dependencies */ deleted = 0; - for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(commandNameTable, hPtr); + for (hPtr = Tcl_FirstHashEntry(commandNameTablePtr, &hSrch); hPtr; + hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandNameTablePtr, hPtr); object = GetObjectFromString(interp, key); if (object && !NsfObjectIsClass(object) && !ObjectHasChildren(interp, object)) { @@ -15965,8 +16009,9 @@ /* * Delete all classes without dependencies */ - for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(commandNameTable, hPtr); + for (hPtr = Tcl_FirstHashEntry(commandNameTablePtr, &hSrch); hPtr; + hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandNameTablePtr, hPtr); NsfClass *cl = GetClassFromString(interp, key); /*fprintf(stderr, "cl key = %s %p\n", key, cl);*/ Index: generic/nsfAccessInt.h =================================================================== diff -u -r39b3afac5fee73db5fadf53f7c25f00a650d11e9 -r404ad6bfcb313983a0cc54d3323751008bca991b --- generic/nsfAccessInt.h (.../nsfAccessInt.h) (revision 39b3afac5fee73db5fadf53f7c25f00a650d11e9) +++ generic/nsfAccessInt.h (.../nsfAccessInt.h) (revision 404ad6bfcb313983a0cc54d3323751008bca991b) @@ -19,9 +19,9 @@ #define Tcl_CallFrame_clientData(cf) ((CallFrame *)cf)->clientData #define Tcl_CallFrame_nsPtr(cf) ((Tcl_Namespace *)((CallFrame *)cf)->nsPtr) -#define Tcl_Namespace_cmdTable(nsPtr) &((Namespace *)nsPtr)->cmdTable -#define Tcl_Namespace_varTable(nsPtr) &((Namespace *)nsPtr)->varTable -#define Tcl_Namespace_childTable(nsPtr) &((Namespace *)nsPtr)->childTable +#define Tcl_Namespace_cmdTablePtr(nsPtr) &((Namespace *)nsPtr)->cmdTable +#define Tcl_Namespace_varTablePtr(nsPtr) &((Namespace *)nsPtr)->varTable +#define Tcl_Namespace_childTablePtr(nsPtr) &((Namespace *)nsPtr)->childTable #define Tcl_Namespace_activationCount(nsPtr) ((Namespace *)nsPtr)->activationCount #define Tcl_Namespace_deleteProc(nsPtr) ((Namespace *)nsPtr)->deleteProc Index: generic/nsfInt.h =================================================================== diff -u -rb70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9 -r404ad6bfcb313983a0cc54d3323751008bca991b --- generic/nsfInt.h (.../nsfInt.h) (revision b70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9) +++ generic/nsfInt.h (.../nsfInt.h) (revision 404ad6bfcb313983a0cc54d3323751008bca991b) @@ -339,18 +339,20 @@ /* FILTER_ORDER_DEFINED set, when filters are defined for obj */ #define NSF_FILTER_ORDER_DEFINED 0x0020 #define NSF_FILTER_ORDER_DEFINED_AND_VALID 0x0030 -/* CLASS properties for objects */ +/* class and object properties for objects */ #define NSF_IS_CLASS 0x0040 #define NSF_IS_ROOT_META_CLASS 0x0080 #define NSF_IS_ROOT_CLASS 0x0100 - -#define NSF_TCL_DELETE 0x0200 -#define NSF_DESTROY_CALLED_SUCCESS 0x0400 +#define NSF_IS_SLOT_CONTAINER 0x0200 +/* deletion state */ +#define NSF_TCL_DELETE 0x0400 +#define NSF_DESTROY_CALLED_SUCCESS 0x0800 /*#define NSF_CMD_NOT_FOUND 0x1000*/ #define NSF_DURING_DELETE 0x2000 #define NSF_DELETED 0x4000 #define NSF_RECREATE 0x8000 + /* flags for NsfParams */ #define NSF_ARG_REQUIRED 0x0001 @@ -446,7 +448,7 @@ Tcl_Command id; Tcl_Interp *teardown; struct NsfClass *cl; - TclVarHashTable *varTable; + TclVarHashTable *varTablePtr; Tcl_Namespace *nsPtr; NsfObjectOpt *opt; struct NsfCmdList *filterOrder; Index: generic/nsfStack.c =================================================================== diff -u -r16ecd9a1e7a06eb966b2d51d4a1c59457ab25d11 -r404ad6bfcb313983a0cc54d3323751008bca991b --- generic/nsfStack.c (.../nsfStack.c) (revision 16ecd9a1e7a06eb966b2d51d4a1c59457ab25d11) +++ generic/nsfStack.c (.../nsfStack.c) (revision 404ad6bfcb313983a0cc54d3323751008bca991b) @@ -64,13 +64,13 @@ 1|FRAME_IS_NSF_OBJECT); Tcl_CallFrame_procPtr(framePtr) = &RUNTIME_STATE(interp)->fakeProc; - if (object->varTable == NULL) { - object->varTable = VarHashTableCreate(); - /*fprintf(stderr, "+++ create varTable %p in PushFrameObj obj %p framePtr %p\n", - object->varTable, object, framePtr);*/ + if (object->varTablePtr == NULL) { + object->varTablePtr = VarHashTableCreate(); + /*fprintf(stderr, "+++ create varTablePtr %p in PushFrameObj obj %p framePtr %p\n", + object->varTablePtr, object, framePtr);*/ } - Tcl_CallFrame_varTablePtr(framePtr) = object->varTable; - /*fprintf(stderr,"+++ setting varTable %p in varFrame %p\n",object->varTable,framePtr);*/ + Tcl_CallFrame_varTablePtr(framePtr) = object->varTablePtr; + /*fprintf(stderr,"+++ setting varTablePtr %p in varFrame %p\n",object->varTablePtr,framePtr);*/ } Tcl_CallFrame_clientData(framePtr) = (ClientData)object; } @@ -94,7 +94,7 @@ } static void Nsf_PopFrameCsc(Tcl_Interp *interp, Tcl_CallFrame *framePtr) { - /*fprintf(stderr,"POP CMETHOD_FRAME (Nsf_PopFrameCsc) frame %p, varTable = %p\n", + /*fprintf(stderr,"POP CMETHOD_FRAME (Nsf_PopFrameCsc) frame %p, varTablePtr = %p\n", framePtr, Tcl_CallFrame_varTablePtr(framePtr));*/ Tcl_PopCallFrame(interp); } Index: generic/tclAPI.h =================================================================== diff -u -rb70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9 -r404ad6bfcb313983a0cc54d3323751008bca991b --- generic/tclAPI.h (.../tclAPI.h) (revision b70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9) +++ generic/tclAPI.h (.../tclAPI.h) (revision 404ad6bfcb313983a0cc54d3323751008bca991b) @@ -79,13 +79,13 @@ static int ConvertToMethodproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, NsfParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { int index, result; - static CONST char *opts[] = {"class-only", "protected", "redefine-protected", "returns", "slotobj", NULL}; + static CONST char *opts[] = {"class-only", "protected", "redefine-protected", "returns", "slotcontainer", "slotobj", NULL}; result = Tcl_GetIndexFromObj(interp, objPtr, opts, "methodproperty", 0, &index); *clientData = (ClientData) INT2PTR(index + 1); *outObjPtr = objPtr; return result; } -enum MethodpropertyIdx {MethodpropertyNULL, MethodpropertyClass_onlyIdx, MethodpropertyProtectedIdx, MethodpropertyRedefine_protectedIdx, MethodpropertyReturnsIdx, MethodpropertySlotobjIdx}; +enum MethodpropertyIdx {MethodpropertyNULL, MethodpropertyClass_onlyIdx, MethodpropertyProtectedIdx, MethodpropertyRedefine_protectedIdx, MethodpropertyReturnsIdx, MethodpropertySlotcontainerIdx, MethodpropertySlotobjIdx}; static int ConvertToRelationtype(Tcl_Interp *interp, Tcl_Obj *objPtr, NsfParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { Index: library/nx/nx.tcl =================================================================== diff -u -rb70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9 -r404ad6bfcb313983a0cc54d3323751008bca991b --- library/nx/nx.tcl (.../nx.tcl) (revision b70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9) +++ library/nx/nx.tcl (.../nx.tcl) (revision 404ad6bfcb313983a0cc54d3323751008bca991b) @@ -93,11 +93,7 @@ # Create dispatch/ensemble object and accessor method (if wanted) # if {$scope eq "class"} { - if {![::nsf::isobject ${object}::slot]} { - ::nsf::methodproperty $object [Object create ${object}::slot] protected true - if {$verbose} {puts stderr "... create object ${object}::slot"} - } - set o [nx::EnsembleObject create ${object}::slot::__$w] + set o [nx::EnsembleObject create [::nx::slotObj ${object} __$w]] if {$verbose} {puts stderr "... create object $o"} # We are on a class, and have to create an alias to be # accessible for objects @@ -183,7 +179,8 @@ return [::nsf::dispatch [::nsf::current object] ::nsf::classes::nx::Object::$what {*}$args] } if {$what in [list "info"]} { - return [::nsf::dispatch [::nsf::current object] ::nx::Object::slot::__info [lindex $args 0] {*}[lrange $args 1 end]] + return [::nsf::dispatch [::nsf::current object] ::nx::Object::slot::__info \ + [lindex $args 0] {*}[lrange $args 1 end]] } if {$what in [list "filter" "mixin"]} { # @@ -329,17 +326,34 @@ } } + # + # isSlotContainer tests, whether the provided object is a slot + # container based on the methodproperty slotcontainer, used + # internally by nsf. + # + proc ::nx::isSlotContainer {object} { + if {[::nsf::isobject $object] && [namespace tail $object] eq "slot"} { + set parent [$object ::nsf::methods::object::info::parent] + return [expr {[::nsf::isobject $parent] + && [::nsf::methodproperty $parent -per-object slot slotcontainer]}] + } + return 0 + } + proc ::nx::slotObj {baseObject {name ""}} { - # Create slot parent object if needed - set slotParent ${baseObject}::slot - if {![::nsf::isobject $slotParent]} { - ::nx::Object alloc $slotParent + # Create slot container object if needed + set slotContainer ${baseObject}::slot + if {![::nsf::isobject $slotContainer]} { + ::nx::Object alloc $slotContainer ::nsf::methodproperty ${baseObject} -per-object slot protected true + ::nsf::methodproperty ${baseObject} -per-object slot redefine-protected true + ::nsf::methodproperty ${baseObject} -per-object slot slotcontainer true + $slotContainer ::nsf::methods::object::requirenamespace } if {$name eq ""} { - return ${slotParent} + return ${slotContainer} } - return ${slotParent}::$name + return ${slotContainer}::$name } # allocate system slot parents Index: library/serialize/serializer.tcl =================================================================== diff -u -ra74bd5cdede9d48d0a225a27e1d710a7189b65d1 -r404ad6bfcb313983a0cc54d3323751008bca991b --- library/serialize/serializer.tcl (.../serializer.tcl) (revision a74bd5cdede9d48d0a225a27e1d710a7189b65d1) +++ library/serialize/serializer.tcl (.../serializer.tcl) (revision 404ad6bfcb313983a0cc54d3323751008bca991b) @@ -610,43 +610,13 @@ return [:[:classify $x]-needsNothing $x $s] } - :method submethods {x where name} { - set methods [list] - set submethods [$x ::nsf::methods::${where}::info::method submethods $name] - #puts stderr "subm of $x $where $name => $submethods" - if {[llength $submethods] == 0} { - # no submethods, therefore we have a leaf method - lappend methods $name - } else { - foreach m $submethods { - lappend methods {*}[:submethods $x $where "$name $m"] - } - } - return $methods - } - - :method ensembleMethods {x where} { - # todo: don't check for name "slot" - if {[$x ::nsf::methods::object::info::hastype ::nx::EnsembleObject] || [namespace tail $x] eq "slot"} { - # don't return the ensemble objects as ensembleMethods - return [list] - } - set methods [list] - foreach m [$x ::nsf::methods::${where}::info::methods -methodtype object -callprotection all] { - if {$m eq "slot"} continue - lappend methods {*}[:submethods $x $where $m] - } - #puts stderr "ensembleMethods for $x $where $methods" - return $methods - } - :method alias-dependency {x where} { set handle :alias_dependency($x,$where) if {[info exists $handle]} { return [set $handle] } set needed [list] - foreach alias [$x ::nsf::methods::${where}::info::methods -methodtype alias -callprotection all] { + foreach alias [$x ::nsf::methods::${where}::info::methods -methodtype alias -callprotection all -expand] { set definition [$x ::nsf::methods::${where}::info::method definition $alias] set source [$x ::nsf::methods::class::info::method definition [lindex $definition end]] if {$source ne ""} { @@ -737,17 +707,18 @@ } :collect-var-traces $o $s - append cmd [list [$o info class] create \ - [::nsf::dispatch $o -objscope ::nsf::current object]] - - append cmd " -noinit\n" - foreach i [lsort [$o ::nsf::methods::object::info::methods -callprotection all]] { - append cmd [:method-serialize $o $i "class-object"] "\n" - } - foreach i [:ensembleMethods $o object] { - append cmd [:method-serialize $o $i "class-object"] "\n" + set objectName [::nsf::dispatch $o -objscope ::nsf::current object] + puts stderr "isSlotContainer $objectName // $o" + set isSlotContainer [::nx::isSlotContainer $objectName] + if {$isSlotContainer} { + append cmd [list ::nx::slotObj [$o ::nsf::methods::object::info::parent]]\n + } else { + append cmd [list [$o info class] create $objectName -noinit]\n + foreach i [lsort [$o ::nsf::methods::object::info::methods -callprotection all -expand]] { + append cmd [:method-serialize $o $i "class-object"] "\n" } - + } + set vars [:collectVars $o] if {[llength $vars]>0} {append cmd [list $o eval [join $vars "\n "]]\n} @@ -772,13 +743,9 @@ :method Class-serialize {o s} { set cmd [:Object-serialize $o $s] - foreach i [lsort [$o ::nsf::methods::class::info::methods -callprotection all]] { + foreach i [lsort [$o ::nsf::methods::class::info::methods -callprotection all -expand]] { append cmd [:method-serialize $o $i ""] "\n" } - foreach i [:ensembleMethods $o class] { - append cmd [:method-serialize $o $i ""] "\n" - } - append cmd \ [:frameWorkCmd ::nsf::relation $o superclass -unless ${:rootClass}] \ [:frameWorkCmd ::nsf::relation $o class-mixin] \ Index: tests/info-method.tcl =================================================================== diff -u -rb70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9 -r404ad6bfcb313983a0cc54d3323751008bca991b --- tests/info-method.tcl (.../info-method.tcl) (revision b70d9bb2e0b19e3cb5f397a4b168d79d3047ceb9) +++ tests/info-method.tcl (.../info-method.tcl) (revision 404ad6bfcb313983a0cc54d3323751008bca991b) @@ -345,7 +345,9 @@ # test "info methods -expand" # Test case info-methods-expand { - ::nx::Object create o1 + # + # test case on base class + # ? {::nx::Object info methods "info"} "info" ? {::nx::Object info methods -expand "info"} "" ? {lsort [::nx::Object info methods -expand "info lookup *"]} \ @@ -358,4 +360,20 @@ "{info lookup slots} {info slots}" ? {lsort [::nx::Object info methods -expand "*filter*"]} \ "filter {info filter guard} {info filter methods} {info lookup filter}" + + ::nx::Object create o1 + ::nx::Class create C { + :public method "string length" {s} {puts length} + :public method "string reverse" {s} {puts reverse} + :public method foo {} {puts foo} + :protected method "a b c" {} {puts "a b c"} + :protected method "a b d" {} {puts "a b d"} + :public method "a c" {d c} {puts "a c"} + } + + ? {lsort [C info methods -expand -callprotection all]} \ + "{a b c} {a b d} {a c} foo {string length} {string reverse}" + ? {lsort [C info methods -expand]} \ + "{a c} foo {string length} {string reverse}" + } \ No newline at end of file