Index: generic/xotcl.c =================================================================== diff -u -r4e57b61f8ab37804f75c05094552dc306e367135 -rf3cbadd6d76459cc00032877fa905bb618e9f780 --- generic/xotcl.c (.../xotcl.c) (revision 4e57b61f8ab37804f75c05094552dc306e367135) +++ generic/xotcl.c (.../xotcl.c) (revision f3cbadd6d76459cc00032877fa905bb618e9f780) @@ -912,39 +912,44 @@ } static int -IsXOTclTclObj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **obj) { +IsXOTclTclObj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **objectPtr) { Tcl_ObjType CONST86 *cmdType = objPtr->typePtr; if (cmdType == GetCmdNameType(cmdType)) { Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr); if (cmd) { XOTclObject *o = XOTclGetObjectFromCmdPtr(cmd); if (o) { - *obj = o; + *objectPtr = o; return 1; } } } return 0; } -/* Lookup an xotcl object from the given objPtr, preferably from an +/* Lookup an XOTcl object from the given objPtr, preferably from an * object of type "cmdName". objPtr might be converted in this process. */ static int -GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **obj) { +GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **objectPtr) { int result; - XOTclObject *nobj; + XOTclObject *nobject; char *string; - Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr); + Tcl_Command cmd; - /*fprintf(stderr, "GetObjectFromObj obj %s is of type tclCmd, cmd=%p\n", ObjStr(objPtr), cmd);*/ + /*fprintf(stderr, "GetObjectFromObj obj %p %s is of type %s\n", + objPtr, ObjStr(objPtr), objPtr->typePtr ? objPtr->typePtr->name : "(null)");*/ + + /* in case, objPtr was not of type cmdName, try to convert */ + cmd = Tcl_GetCommandFromObj(interp, objPtr); + /*fprintf(stderr, "GetObjectFromObj obj %s => cmd=%p\n", ObjStr(objPtr), cmd);*/ if (cmd) { XOTclObject *o = XOTclGetObjectFromCmdPtr(cmd); /*fprintf(stderr, "GetObjectFromObj obj %s, o is %p objProc %p XOTclObjDispatch %p\n", ObjStr(objPtr), o, Tcl_Command_objProc(cmd), XOTclObjDispatch);*/ if (o) { - if (obj) *obj = o; + if (objectPtr) *objectPtr = o; return TCL_OK; } } @@ -961,15 +966,15 @@ char *nsString = ObjStr(tmpName); INCR_REF_COUNT(tmpName); - nobj = XOTclpGetObject(interp, nsString); + nobject = XOTclpGetObject(interp, nsString); /*fprintf(stderr, " RETRY, string '%s' returned %p\n", nsString, nobj);*/ DECR_REF_COUNT(tmpName); } else { - nobj = NULL; + nobject = NULL; } - if (nobj) { - if (obj) *obj = nobj; + if (nobject) { + if (objectPtr) *objectPtr = nobject; result = TCL_OK; } else { result = TCL_ERROR; @@ -1917,6 +1922,7 @@ static int XOTcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command cmd) { + /*fprintf(stderr, "XOTcl_DeleteCommandFromToken %p\n",cmd);*/ CallStackClearCmdReferences(interp, cmd); return Tcl_DeleteCommandFromToken(interp, cmd); } @@ -1932,7 +1938,7 @@ Tcl_HashEntry *hPtr; #ifdef OBJDELETION_TRACE - fprintf(stderr, "NSCleanupNamespace %p varTable %p\n", ns, varTable); + fprintf(stderr, "NSCleanupNamespace %p %.6x varTable %p\n", ns, ((Namespace *)ns)->flags, varTable); #endif /* * Delete all variables and initialize var table again @@ -1950,7 +1956,7 @@ Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); XOTclObject *invokeObj = proc == XOTclObjDispatch ? (XOTclObject *)Tcl_Command_objClientData(cmd) : NULL; - /* objects should not be deleted here to preseve children deletion order*/ + /* objects should not be deleted here to preseve children deletion order */ if (invokeObj && cmd != invokeObj->id) { /* * cmd is an aliased object, reduce the refcount @@ -1959,8 +1965,11 @@ XOTclCleanupObject(invokeObj); } - /*fprintf(stderr, "NSCleanupNamespace deleting %s %p (%s)\n", - Tcl_Command_nsPtr(cmd)->fullName, cmd, Tcl_GetCommandName(interp, cmd) );*/ + /*fprintf(stderr, "NSCleanupNamespace calls DeleteCommandFromToken for %p flags %.6x\n", + cmd,((Command *)cmd)->flags); + fprintf(stderr, " nsPtr = %p\n",((Command *)cmd)->nsPtr); + fprintf(stderr, " flags %.6x\n",((Namespace *)((Command *)cmd)->nsPtr)->flags);*/ + XOTcl_DeleteCommandFromToken(interp, cmd); } } @@ -1970,7 +1979,7 @@ NSNamespaceDeleteProc(ClientData clientData) { /* dummy for ns identification by pointer comparison */ XOTclObject *obj = (XOTclObject*) clientData; - /*fprintf(stderr, "namespacedeleteproc obj=%p\n", clientData);*/ + /*fprintf(stderr, "namespacedeleteproc obj=%p ns=%p\n", clientData,obj? obj->nsPtr:NULL);*/ if (obj) { obj->nsPtr = NULL; } @@ -1988,21 +1997,23 @@ int activationCount = 0; Tcl_CallFrame *f = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); - /* - fprintf(stderr, " ... correcting ActivationCount for %s was %d ", - nsPtr->fullName, nsp->activationCount); - */ + /*fprintf(stderr, " ... correcting ActivationCount for %s was %d ", + nsPtr->fullName, ((Namespace *)nsPtr)->activationCount);*/ + while (f) { if (f->nsPtr == nsPtr) activationCount++; f = Tcl_CallFrame_callerPtr(f); } + + if (((Namespace *)nsPtr)->activationCount != activationCount) { + fprintf(stderr, "WE HAVE TO FIX ACTIVATIONCOUNT\n"); + } Tcl_Namespace_activationCount(nsPtr) = activationCount; - /* - fprintf(stderr, "to %d. \n", nsp->activationCount); - */ + /*fprintf(stderr, "to %d. \n", ((Namespace *)nsPtr)->activationCount);*/ + MEM_COUNT_FREE("TclNamespace", nsPtr); if (Tcl_Namespace_deleteProc(nsPtr)) { /*fprintf(stderr, "calling deteteNamespace %s\n", nsPtr->fullName);*/ @@ -2016,8 +2027,8 @@ if (nsPtr) { if (nsPtr->deleteProc || nsPtr->clientData) { - Tcl_Panic("Namespace '%s' exists already with delProc %p and clientData %p; Can only convert a plain Tcl namespace into an XOTcl namespace", - name, nsPtr->deleteProc, nsPtr->clientData); + Tcl_Panic("Namespace '%s' exists already with delProc %p and clientData %p; Can only convert a plain Tcl namespace into an XOTcl namespace, my delete Proc %p", + name, nsPtr->deleteProc, nsPtr->clientData, NSNamespaceDeleteProc); } nsPtr->clientData = clientData; nsPtr->deleteProc = (Tcl_NamespaceDeleteProc *)NSNamespaceDeleteProc; @@ -2400,56 +2411,76 @@ /* Don't do anything, if a recursive DURING_DELETE is for some * reason active. */ + /*fprintf(stderr, "CallStackDoDestroy %p flags %.6x cmd %p\n", obj, obj->flags, obj->id);*/ if (obj->flags & XOTCL_DURING_DELETE) { return; } - /*fprintf(stderr, "CallStackDoDestroy %p flags %.6x activation %d\n", - obj, obj->flags, obj->activationCount);*/ + /*fprintf(stderr, "CallStackDoDestroy %p flags %.6x activation %d cmd %p\n", + obj, obj->flags, obj->activationCount, obj->id);*/ obj->flags |= XOTCL_DURING_DELETE; oid = obj->id; if (obj->teardown && oid) { Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); + /*int flags = obj->flags;*/ + INCR_REF_COUNT(savedObjResult); - PrimitiveDestroy((ClientData) obj); + if (!(obj->flags & XOTCL_CMD_NOT_FOUND)) { + /*fprintf(stderr, " before DeleteCommandFromToken %p %.6x\n", oid, ((Command*)oid)->flags);*/ + Tcl_DeleteCommandFromToken(interp, oid); /* this can change the result */ + /*fprintf(stderr, " after DeleteCommandFromToken %p %.6x\n", oid, ((Command*)oid)->flags);*/ + Tcl_SetObjResult(interp, savedObjResult); + } - /*fprintf(stderr, " before DeleteCommandFromToken %p %.6x\n", oid, ((Command*)oid)->flags);*/ - Tcl_DeleteCommandFromToken(interp, oid); /* this can change the result */ - /*fprintf(stderr, " after DeleteCommandFromToken %p %.6x\n", oid, ((Command*)oid)->flags);*/ - - Tcl_SetObjResult(interp, savedObjResult); + PrimitiveDestroy((ClientData) obj); + /*fprintf(stderr, "CallStackDoDestroy after primitiveDestroy of obj %p flags %.6x\n", + obj, flags);*/ DECR_REF_COUNT(savedObjResult); } } static void CallStackDestroyObject(Tcl_Interp *interp, XOTclObject *obj) { - /*fprintf(stderr, " CallStackDestroyObject %p %s activationcount %d\n", - obj, objectName(obj), obj->activationCount == 0); */ + /*fprintf(stderr, " CallStackDestroyObject %p %s activationcount %d flags %.6x\n", + obj, objectName(obj), obj->activationCount, obj->flags); */ + if ((obj->flags & XOTCL_DESTROY_CALLED) == 0) { + int activationCount = obj->activationCount; /* if the destroy method was not called yet, do it now */ #ifdef OBJDELETION_TRACE - fprintf(stderr, " CallStackDestroyObject has to call destroy method for %p\n", obj); + fprintf(stderr, " CallStackDestroyObject has to callDestroyMethod %p activationCount %d\n", obj, activationCount); #endif callDestroyMethod(interp, obj, 0); - /*fprintf(stderr, " CallStackDestroyObject after callDestroyMethod %p\n", obj);*/ + /*fprintf(stderr, " CallStackDestroyObject after callDestroyMethod %p activationCount %d\n", + obj, activationCount);*/ + if (activationCount == 0) { + /* We assume, the object is now freed. if the obj is already + freed, we cannot access activation count, and we cannot call + CallStackDoDestroy */ + /* todo: check if this is leak; */ + /*fprintf(stderr, " CallStackDestroyObject %p done\n", obj);*/ + return; + } } /* if the object is not referenced on the callstack anymore we have to destroy it directly, because CallStackPop won't find the object destroy */ + /* fprintf(stderr, " CallStackDestroyObject check activation count of %p => %d\n", obj, obj->activationCount);*/ if (obj->activationCount == 0) { CallStackDoDestroy(interp, obj); } else { /* to prevail the deletion order call delete children now -> children destructors are called before parent's destructor */ if (obj->teardown && obj->nsPtr) { + /*fprintf(stderr, " CallStackDestroyObject calls NSDeleteChildren\n");*/ NSDeleteChildren(interp, obj->nsPtr); } } + /*fprintf(stderr, " CallStackDestroyObject %p final done\n", obj);*/ } /* @@ -5464,6 +5495,7 @@ XOTclCallStackContent *cscPtr) { CheckOptions co; int result; + XOTclRuntimeState *rst = RUNTIME_STATE(interp); #if defined(TCL85STACK) XOTcl_FrameDecls; #endif @@ -5503,6 +5535,7 @@ printCall(interp, "CmdMethodDispatch cmd", objc, objv); fprintf(stderr, "\tcmd=%s\n", Tcl_GetCommandName(interp, cmdPtr)); #endif + rst->deallocCalled = 0; #if !defined(NRE) result = (*Tcl_Command_objProc(cmdPtr))(cp, interp, objc, objv); #else @@ -5518,9 +5551,12 @@ } #endif + /*fprintf(stderr, "CmdDispatch obj %p %s deallocCalled %d\n", + obj, methodName, rst->deallocCalled);*/ + /* The order of the if-condition below is important, since obj might be already freed in case the call was a "dealloc" */ - if (obj->opt) { + if (!rst->deallocCalled && obj->opt) { co = obj->opt->checkoptions; if ((co & CHECK_INVAR) && ((result = AssertionCheckInvars(interp, obj, methodName, co)) == TCL_ERROR)) { @@ -5797,9 +5833,13 @@ objectName(obj), frameType, methodName);*/ if ((result = MethodDispatch(clientData, interp, objc-shift, objv+shift, cmd, obj, cl, methodName, frameType)) == TCL_ERROR) { +#if 0 + fprintf(stderr, "Call ErrInProc cl = %p, cmd %p, flags %.6x\n", + cl, cl ? cl->object.id : 0, cl ? cl->object.flags : 0); result = XOTclErrInProc(interp, cmdName, cl && cl->object.teardown ? cl->object.cmdName : NULL, methodName); +#endif } unknown = rst->unknown; } @@ -7284,7 +7324,7 @@ Tcl_Interp *interp; #ifdef OBJDELETION_TRACE - fprintf(stderr, "tclDeletesObject %p obj->id %p\n", obj, obj->id); + fprintf(stderr, "tclDeletesObject %p obj->id %p flags %.6x\n", obj, obj->id, obj->flags); #endif if ((obj->flags & XOTCL_DURING_DELETE) || !obj->teardown) return; interp = obj->teardown; @@ -7336,7 +7376,7 @@ obj->teardown = NULL; if (obj->nsPtr) { - /*fprintf(stderr, "primitive odestroy calls deletenamespace for obj %p\n", obj);*/ + /*fprintf(stderr, "primitive odestroy calls deletenamespace for obj %p nsPtr %p\n", obj, obj->nsPtr);*/ XOTcl_DeleteNamespace(interp, obj->nsPtr); obj->nsPtr = NULL; } @@ -7721,13 +7761,14 @@ /* * class object destroy + physical destroy */ - /* fprintf(stderr, "primitive cdestroy calls primitive odestroy\n");*/ + /*fprintf(stderr, "primitive cdestroy %p %.6x calls primitive odestroy\n", cl, flags);*/ PrimitiveODestroy(clientData); - /*fprintf(stderr, "primitive cdestroy calls deletenamespace for obj %p\n", cl);*/ + /*fprintf(stderr, "primitive cdestroy calls deletenamespace for obj %p, nsPtr %p flags %.6x\n", + cl, saved, ((Namespace *)saved)->flags);*/ saved->clientData = NULL; XOTcl_DeleteNamespace(interp, saved); - + /*fprintf(stderr, "primitive cdestroy %p DONE\n",cl);*/ return; } @@ -11746,6 +11787,7 @@ } return result; } +static int DoDealloc(Tcl_Interp *interp, XOTclObject *delobj); static int XOTclODestroyMethod(Tcl_Interp *interp, XOTclObject *obj) { PRINTOBJ("XOTclODestroyMethod", obj); @@ -11755,23 +11797,32 @@ * the explicit destroy calls in the script, which reach the * Object->destroy. */ - /*fprintf(stderr,"XOTclODestroyMethod %p flags %.6x activation %d\n", - obj, obj->flags, obj->activationCount); */ + /*fprintf(stderr,"XOTclODestroyMethod %p flags %.6x activation %d cmd %p cmd->flags %.6x\n", + obj, obj->flags, obj->activationCount, obj->id, ((Command*)obj->id)->flags); */ if ((obj->flags & XOTCL_DESTROY_CALLED) == 0) { obj->flags |= XOTCL_DESTROY_CALLED; } if ((obj->flags & XOTCL_DURING_DELETE) == 0) { - return XOTclCallMethodWithArgs((ClientData)obj->cl, interp, - XOTclGlobalObjects[XOTE_DEALLOC], obj->cmdName, - 1, NULL, 0); + int result; + /*fprintf(stderr, " call dealloc on %p %s\n", obj, objectName(obj));*/ + + result = XOTclCallMethodWithArgs((ClientData)obj->cl, interp, + XOTclGlobalObjects[XOTE_DEALLOC], obj->cmdName, + 1, NULL, 0); + if (result != TCL_OK) { + obj->flags |= XOTCL_CMD_NOT_FOUND; + fprintf(stderr, "*** dealloc failed for %p %s flags %.6x, retry\n", obj, objectName(obj), obj->flags); + result = DoDealloc(interp, obj); + } + return result; } else { #if defined(OBJDELETION_TRACE) fprintf(stderr, " Object->destroy already during delete, don't call dealloc %p\n", obj); #endif - return TCL_OK; } + return TCL_OK; } static int XOTclOExistsMethod(Tcl_Interp *interp, XOTclObject *obj, char *var) { @@ -12305,16 +12356,15 @@ return createMethod(interp, cl, name, objc, objv); } -static int XOTclCDeallocMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *object) { - XOTclObject *delobj; + +static int DoDealloc(Tcl_Interp *interp, XOTclObject *delobj) { int result; - if (GetObjectFromObj(interp, object, &delobj) != TCL_OK) - return XOTclVarErrMsg(interp, "Can't destroy object ", - ObjStr(object), " that does not exist.", (char *) NULL); + /*delobj->flags |= XOTCL_DURING_DELETE;*/ - /*fprintf(stderr, "dealloc obj=%s flags %.6x activation %d opt=%p\n", - objectName(delobj), delobj->flags, delobj->activationCount, delobj->opt);*/ + /*fprintf(stderr, "DoDealloc obj= %s %p flags %.6x activation %d cmd %p opt=%p\n", + objectName(delobj), delobj, delobj->flags, delobj->activationCount, + delobj->id, delobj->opt);*/ result = freeUnsetTraceVariable(interp, delobj); if (result != TCL_OK) { @@ -12329,9 +12379,28 @@ CallStackDestroyObject(interp, delobj); } + /* fprintf(stderr, "DoDealloc obj=%p done\n", delobj);*/ return TCL_OK; } + +static int XOTclCDeallocMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *object) { + XOTclObject *delobj; + XOTclRuntimeState *rst = RUNTIME_STATE(interp); + + rst->deallocCalled = 1; + + /*fprintf(stderr, "XOTclCDeallocMethod obj %p\n",object);*/ + + if (GetObjectFromObj(interp, object, &delobj) != TCL_OK) { + fprintf(stderr, "obj %s does not exist\n", ObjStr(object)); + return XOTclVarErrMsg(interp, "Can't destroy object ", + ObjStr(object), " that does not exist.", (char *) NULL); + } + + return DoDealloc(interp, delobj); +} + static int XOTclCNewMethod(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *withChildof, int objc, Tcl_Obj *CONST objv[]) { Tcl_Obj *fullname; @@ -13275,7 +13344,7 @@ /* fprintf(stderr, " ... delete object %s %p, class=%s\n", key, obj, className(obj->cl));*/ freeUnsetTraceVariable(interp, obj); - Tcl_DeleteCommandFromToken(interp, obj->id); + if (obj->id) Tcl_DeleteCommandFromToken(interp, obj->id); Tcl_DeleteHashEntry(hPtr); deleted++; } @@ -13297,7 +13366,7 @@ ) { /* fprintf(stderr, " ... delete class %s %p\n", key, cl); */ freeUnsetTraceVariable(interp, &cl->object); - Tcl_DeleteCommandFromToken(interp, cl->object.id); + if (cl->object.id) Tcl_DeleteCommandFromToken(interp, cl->object.id); Tcl_DeleteHashEntry(hPtr); deleted++; } Index: generic/xotclInt.h =================================================================== diff -u -r04747ba752ca2b7a4f30586348e39ab04f190da9 -rf3cbadd6d76459cc00032877fa905bb618e9f780 --- generic/xotclInt.h (.../xotclInt.h) (revision 04747ba752ca2b7a4f30586348e39ab04f190da9) +++ generic/xotclInt.h (.../xotclInt.h) (revision f3cbadd6d76459cc00032877fa905bb618e9f780) @@ -412,7 +412,7 @@ #define XOTCL_IS_ROOT_META_CLASS 0x0080 #define XOTCL_IS_ROOT_CLASS 0x0100 /* DESTROYED set, when object is physically destroyed with PrimitiveODestroy */ -#define XOTCL_MUST_DELETE 0x1000 +#define XOTCL_CMD_NOT_FOUND 0x1000 #define XOTCL_DURING_DELETE 0x2000 #define XOTCL_DELETED 0x4000 #define XOTCL_RECREATE 0x8000 @@ -665,6 +665,7 @@ int cacheInterface; int exitHandlerDestroyRound; int returnCode; + int deallocCalled; long newCounter; XOTclStringIncrStruct iss; Proc fakeProc; Index: generic/xotclStack85.c =================================================================== diff -u -r4d8ba3b513cf95b9b567b509df9e595291768a62 -rf3cbadd6d76459cc00032877fa905bb618e9f780 --- generic/xotclStack85.c (.../xotclStack85.c) (revision 4d8ba3b513cf95b9b567b509df9e595291768a62) +++ generic/xotclStack85.c (.../xotclStack85.c) (revision f3cbadd6d76459cc00032877fa905bb618e9f780) @@ -72,7 +72,8 @@ if (flag & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { XOTclCallStackContent *csc = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); #if defined(TCL85STACK_TRACE) - fprintf(stderr, "... self returns %s\n",objectName(csc->self)); + fprintf(stderr, "... self returns %p %.6x %s\n",csc->self, + csc->self->flags, objectName(csc->self)); #endif return csc->self; } else if (flag & FRAME_IS_XOTCL_OBJECT) { @@ -304,7 +305,19 @@ CallStackPush(XOTclCallStackContent *csc, XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd, int frameType) { obj->activationCount ++; #if 1 - if (cl) {cl->object.activationCount ++;} + if (cl) { + Namespace *nsPtr = ((Command *)cmd)->nsPtr; + cl->object.activationCount ++; + /*fprintf(stderr, "... %s cmd %s cmd ns %p (%s) obj ns %p parent %p\n", + className(cl), + Tcl_GetCommandName(obj->teardown, cmd), + ((Command *)cmd)->nsPtr, ((Command *)cmd)->nsPtr->fullName, + cl->object.nsPtr,cl->object.nsPtr ? ((Namespace*)cl->object.nsPtr)->parentPtr : NULL);*/ + + /* incremement the namespace ptr in case tcl tries to delete this namespace + during the invocation */ + nsPtr->refCount ++; + } #endif /*fprintf(stderr, "incr activationCount for %s to %d\n", objectName(obj), obj->activationCount);*/ csc->self = obj; @@ -333,18 +346,48 @@ Tcl_GetCommandName(interp, csc->cmdPtr)); #endif obj->activationCount --; - /*fprintf(stderr, "decr activationCount for %s to %d\n", objectName(csc->self), csc->self->activationCount);*/ + + /*fprintf(stderr, "decr activationCount for %s to %d\n", objectName(csc->self), + csc->self->activationCount);*/ if (obj->activationCount < 1 && obj->flags & XOTCL_DESTROY_CALLED) { CallStackDoDestroy(interp, obj); } #if 1 if (csc->cl) { + Namespace *nsPtr = ((Command *)(csc->cmdPtr))->nsPtr; + obj = &csc->cl->object; obj->activationCount --; + /* fprintf(stderr, "CallStackPop cl=%p %s (%d) flags %.6x cl ns=%p cmd %p cmd ns %p\n", + obj, objectName(obj), obj->activationCount, obj->flags, csc->cl->nsPtr, + csc->cmdPtr, ((Command *)csc->cmdPtr)->nsPtr); */ + + /*fprintf(stderr, "dealloc called %d\n",rst->deallocCalled);*/ + + /*fprintf(stderr, "CallStackPop check ac %d flags %.6x\n", + obj->activationCount, obj->flags & XOTCL_DESTROY_CALLED);*/ + if (obj->activationCount < 1 && obj->flags & XOTCL_DESTROY_CALLED) { + /* fprintf(stderr, "CallStackPop calls CallStackDoDestroy %p\n",obj);*/ CallStackDoDestroy(interp, obj); } + + nsPtr->refCount--; + /*fprintf(stderr, "CallStackPop parent %s activationCount %d flags %.4x refCount %d\n", + nsPtr->fullName, nsPtr->activationCount, nsPtr->flags, nsPtr->refCount);*/ + + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + /* the namspace refcound has reached 0, we have to free + it. unfortunately, NamespaceFree() is not exported */ + fprintf(stderr, "HAVE TO FREE %p\n",nsPtr); + /*NamespaceFree(nsPtr);*/ + ckfree(nsPtr->fullName); + ckfree(nsPtr->name); + ckfree((char*)nsPtr); + } + + /*fprintf(stderr, "CallStackPop done\n");*/ } #endif } Index: tests/destroytest.xotcl =================================================================== diff -u -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 -rf3cbadd6d76459cc00032877fa905bb618e9f780 --- tests/destroytest.xotcl (.../destroytest.xotcl) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) +++ tests/destroytest.xotcl (.../destroytest.xotcl) (revision f3cbadd6d76459cc00032877fa905bb618e9f780) @@ -1,7 +1,13 @@ package require XOTcl +puts stderr XXXX===1 + xotcl::use xotcl1 +puts stderr XXXX===2 + package require xotcl::test +puts stderr XXXX===3 + proc ? {cmd expected {msg ""}} { set count 10 if {$msg ne ""} { @@ -46,6 +52,7 @@ ? {Object isobject c1} 0 "$::case object deleted" ? "set ::firstDestroy" 1 "$::case, firstDestroy called" + # # simple case, destroy does not propagate, c1 survives # @@ -227,6 +234,11 @@ ? {Object isobject test::c1} 0 "$::case object still exists after proc" ? "set ::firstDestroy" 1 "$::case, firstDestroy called" ? "set ::ObjectDestroy" 1 "$::case: destroy was called when poping stack frame" +? {Object isobject ::test::C} 0 "$::case class still exists after proc" +? {namespace exists ::test::C} 0 "$::case namespace ::test::C still exists after proc" +? {namespace exists ::test} 0 "$::case parent ::test namespace still exists after proc" +? {namespace exists ::xotcl::classes::test::C} 0 "$::case namespace ::xotcl::classes::test::C still exists after proc" +puts stderr XXXXX3 # # namespace delete: tcl delays delete until the namespace is not @@ -235,7 +247,10 @@ # set case "delete parent namespace (2)" namespace eval ::test { + ? {namespace exists test::C} 0 "exists test::C" + puts stderr AAA Class C -superclass O + puts stderr BBB C instproc destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy block"} C instproc foo {} { puts stderr "==== $::case [self]" @@ -261,6 +276,7 @@ ? {Object isobject test::c1} 0 "$::case object still exists after proc" ? "set ::firstDestroy" 1 "$::case, firstDestroy called" ? "set ::ObjectDestroy" 0 "$::case, ObjectDestroy called" ;# toplevel destroy was blocked +puts stderr =============OK_STILL-after-61 # # controlled namespace delete: xotcl has its own namespace cleanup, @@ -274,6 +290,9 @@ C instproc foo {} { puts stderr "==== $::case [self]" o destroy + puts stderr "AAAA" + # the following isobject call has a problem in Tcl_GetCommandFromObj(), + # which tries to access invalid memory puts stderr "AAAA [self] exists [Object isobject [self]]" my set x 1 #? "[self] set x" 1 "$::case can still access [self]" @@ -283,7 +302,9 @@ ? "set ::ObjectDestroy" 1 "$::case, ObjectDestroy called" } C o::c1 +puts stderr =====OK1 o::c1 foo +puts stderr =====OK-DONE puts stderr ======[Object isobject ::o::c1] ? {Object isobject ::o::c1} 0 "$::case object o::c1 still exists after proc" ? {Object isobject o} 0 "$::case object o still exists after proc"