Index: doc/namespace.n ================================================================== --- doc/namespace.n +++ doc/namespace.n @@ -78,17 +78,14 @@ but this command returns \fB::\fR for the global namespace as a convenience to programmers. .TP \fBnamespace delete \fR?\fInamespace namespace ...\fR? . -Each namespace \fInamespace\fR is deleted -and all variables, procedures, and child namespaces -contained in the namespace are deleted. -If a procedure is currently executing inside the namespace, -the namespace will be kept alive until the procedure returns; -however, the namespace is marked to prevent other code from -looking it up by name. +Each namespace \fInamespace\fR is deleted and its ensemble commands, child +namespaces, commands, and variables are deleted in that order. Any evaluation +levels using the namespace as the current namespace then use the global +namespace instead. If a namespace does not exist, this command returns an error. If no namespace names are given, this command does nothing. .TP \fBnamespace ensemble\fR \fIsubcommand\fR ?\fIarg ...\fR? . Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -888,10 +888,11 @@ int dummy9; void *dummy10; void *dummy11; void *dummy12; void *dummy13; + void *dummy14; } Tcl_CallFrame; /* *---------------------------------------------------------------------------- * Information about commands that is returned by Tcl_GetCommandInfo and Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -859,11 +859,11 @@ /* * Initialise the thread-specific data ekeko. Note that the thread's alloc * cache was already initialised by the call to alloc the interp struct. */ -#if TCL_THREADS && defined(USE_THREAD_ALLOC) +#if (!defined(TCL_THREADS) || TCL_THREADS) && defined(USE_THREAD_ALLOC) iPtr->allocCache = TclpGetAllocCache(); #else iPtr->allocCache = NULL; #endif iPtr->pendingObjDataPtr = NULL; @@ -892,10 +892,11 @@ cmdInfoPtr->name, &isNew); if (isNew) { cmdPtr = ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; + iPtr->globalNsPtr->refCount++; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = cmdInfoPtr->compileProc; cmdPtr->proc = TclInvokeObjectCommand; cmdPtr->clientData = cmdPtr; @@ -1074,11 +1075,11 @@ TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, NULL); #endif /* !TCL_NO_DEPRECATED */ TclpSetVariables(interp); -#if TCL_THREADS +#if !defined(TCL_THREADS) || TCL_THREADS /* * The existence of the "threaded" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with threads * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can * introspect on the interpreter level of thread safety. @@ -1714,11 +1715,11 @@ * bytecode releases its literals without caring to update the literal * table, as it will be freed later in this function without further use. */ TclHandleFree(iPtr->handle); - TclTeardownNamespace(iPtr->globalNsPtr); + Tcl_DeleteNamespace((Tcl_Namespace *)iPtr->globalNsPtr); /* * Delete all the hidden commands. */ @@ -1761,22 +1762,16 @@ } Tcl_DeleteHashTable(hTablePtr); ckfree(hTablePtr); } - /* - * Pop the root frame pointer and finish deleting the global - * namespace. The order is important [Bug 1658572]. - */ - if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) { Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); } Tcl_PopCallFrame(interp); ckfree(iPtr->rootFramePtr); iPtr->rootFramePtr = NULL; - Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); /* * Free up the result *after* deleting variables, since variable deletion * could have transferred ownership of the result string to Tcl. */ @@ -2427,10 +2422,11 @@ } cmdPtr = ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; + nsPtr->refCount++; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = NULL; cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = cmdPtr; @@ -2625,10 +2621,11 @@ */ cmdPtr->nsPtr->refCount++; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + nsPtr = (Namespace *) TclEnsureNamespace(interp, (Tcl_Namespace *) cmdPtr->nsPtr); TclNsDecrRefCount(cmdPtr->nsPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { @@ -2672,10 +2669,11 @@ } cmdPtr = ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; + nsPtr->refCount++; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = NULL; cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; @@ -2957,12 +2955,16 @@ result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); if (result != TCL_OK) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = oldHPtr; + /* reference count was already incremented above */ cmdPtr->nsPtr = cmdNsPtr; goto done; + } else { + cmdPtr->nsPtr->refCount++; + TclNsDecrRefCount(cmdNsPtr); } /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need @@ -3415,12 +3417,10 @@ /* * Call trace functions for the command being deleted. Then delete its * traces. */ - cmdPtr->nsPtr->refCount++; - if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); /* @@ -3444,11 +3444,10 @@ * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. */ TclInvalidateNsCmdLookup(cmdPtr->nsPtr); - TclNsDecrRefCount(cmdPtr->nsPtr); /* * If the command being deleted has a compile function, increment the * interpreter's compileEpoch to invalidate its compiled code. This makes * sure that we don't later try to execute old code compiled with @@ -3529,10 +3528,11 @@ * ByteCode is freed) or replaced by a new reference (when a cached * CmdName Command reference is found to be invalid and * TclNRExecuteByteCode looks up the command in the command hashtable). */ + TclNsDecrRefCount(cmdPtr->nsPtr); TclCleanupCommandMacro(cmdPtr); return 0; } /* @@ -4517,19 +4517,20 @@ static int EvalObjvCore( ClientData data[], Tcl_Interp *interp, - int result) + int result) /* ignored */ { Command *cmdPtr = NULL, *preCmdPtr = data[0]; int flags = PTR2INT(data[1]); int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; Namespace *lookupNsPtr = NULL; int enterTracesDone = 0; + result = TCL_OK; /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). */ @@ -4568,10 +4569,11 @@ lookupNsPtr = iPtr->lookupNsPtr; iPtr->lookupNsPtr = NULL; } else if (flags & TCL_EVAL_INVOKE) { lookupNsPtr = iPtr->globalNsPtr; + lookupNsPtr->refCount++; } else { /* * TCL_EVAL_INVOKE was not set: clear rewrite rules */ @@ -4579,10 +4581,11 @@ TclResetRewriteEnsemble(interp, 1); if (flags & TCL_EVAL_GLOBAL) { TEOV_SwitchVarFrame(interp); lookupNsPtr = iPtr->globalNsPtr; + lookupNsPtr->refCount++; } } /* * Lookup the Command to dispatch. @@ -4601,17 +4604,19 @@ * resolving it ourselves, all we can do is raise an error. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to invoke a deleted command")); Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); - return TCL_ERROR; + result = TCL_ERROR; + goto cleanup; } } if (cmdPtr == NULL) { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + result = TEOV_NotFound(interp, objc, objv, lookupNsPtr); + goto cleanup; } } if (enterTracesDone || iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { @@ -4621,11 +4626,11 @@ objc, objv); Tcl_IncrRefCount(commandPtr); if (!enterTracesDone) { - int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, + result = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, objc, objv); /* * Send any exception from enter traces back as an exception * raised by the traced command. @@ -4634,13 +4639,13 @@ * Would either converting all exceptions to TCL_ERROR, or * just swallowing them be better? (Swallowing them has the * problem of permanently hiding program errors.) */ - if (code != TCL_OK) { + if (result != TCL_OK) { Tcl_DecrRefCount(commandPtr); - return code; + goto cleanup; } /* * If the enter traces made the resolved cmdPtr unusable, go * back and resolve again, but next time don't run enter @@ -4666,11 +4671,18 @@ } TclNRAddCallback(interp, Dispatch, cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, cmdPtr->objClientData, INT2PTR(objc), objv); - return TCL_OK; + +cleanup: + + if (lookupNsPtr) { + TclNsDecrRefCount(lookupNsPtr); + } + + return result; } static int Dispatch( ClientData data[], @@ -4771,11 +4783,11 @@ /* * If there is a tailcall, schedule it next */ if (data[1] && (data[1] != INT2PTR(1))) { - TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL); + TclNRAddCallback(interp, TclNRTailcallEval, data[1], data[2], NULL, NULL); } /* OPT ?? * Do not interrupt a series of cleanups with async or limit checks: * just check at the end? @@ -5014,10 +5026,12 @@ } if (lookupNsPtr) { savedNsPtr = varFramePtr->nsPtr; varFramePtr->nsPtr = lookupNsPtr; + /* Corresponding TclNsDecrRefCount is in TEOV_NotFoundCallback. */ + varFramePtr->nsPtr->refCount++; } TclSkipTailcall(interp); TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc), newObjv, savedNsPtr, NULL); return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL); @@ -5035,10 +5049,11 @@ Namespace *savedNsPtr = data[2]; int i; if (savedNsPtr) { + TclNsDecrRefCount(iPtr->varFramePtr->nsPtr); iPtr->varFramePtr->nsPtr = savedNsPtr; } /* * Release any resources we locked and allocated during the handler call. @@ -8613,11 +8628,13 @@ */ void TclSetTailcall( Tcl_Interp *interp, - Tcl_Obj *listPtr) + Namespace *nsPtr, + Tcl_Obj *listPtr + ) { /* * Find the splicing spot: right before the NRCommand of the thing * being tailcalled. Note that we skip NRCommands marked by a 1 in data[1] * (used by command redirectors). @@ -8632,10 +8649,13 @@ } if (!runPtr) { Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); } runPtr->data[1] = listPtr; + runPtr->data[2] = nsPtr; + /* Corresponding TclNsDecrRefCount is in EvalObjvCore */ + nsPtr->refCount++; } /* *---------------------------------------------------------------------- * @@ -8676,33 +8696,27 @@ /* * Invocation without args just clears a scheduled tailcall; invocation * with an argument replaces any previously scheduled tailcall. */ - if (iPtr->varFramePtr->tailcallPtr) { - Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); - iPtr->varFramePtr->tailcallPtr = NULL; + if (iPtr->varFramePtr->tailcallNsPtr) { + TclNsDecrRefCount(iPtr->varFramePtr->tailcallNsPtr); + iPtr->varFramePtr->tailcallNsPtr = NULL; + Tcl_DecrRefCount(iPtr->varFramePtr->tailcallCmdPtr); + iPtr->varFramePtr->tailcallCmdPtr = NULL; } /* * Create the callback to actually evaluate the tailcalled - * command, then set it in the varFrame so that PopCallFrame can use it + * command, then set it in the varFrame so that Tcl_PopCallFrame can use it * at the proper time. */ if (objc > 1) { - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - - /* The tailcall data is in a Tcl list: the first element is the - * namespace, the rest the command to be tailcalled. */ - - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - listPtr = Tcl_NewListObj(objc, objv); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - - iPtr->varFramePtr->tailcallPtr = listPtr; + iPtr->varFramePtr->tailcallNsPtr = iPtr->varFramePtr->nsPtr; + iPtr->varFramePtr->tailcallNsPtr->refCount++; + iPtr->varFramePtr->tailcallCmdPtr = Tcl_NewListObj(objc-1, objv+1); } return TCL_RETURN; } /* @@ -8720,40 +8734,28 @@ ClientData data[], Tcl_Interp *interp, int result) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr = data[0], *nsObjPtr; - Tcl_Namespace *nsPtr; + Tcl_Obj *listPtr = data[0]; + Tcl_Namespace *nsPtr = data[1]; int objc; Tcl_Obj **objv; Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); - nsObjPtr = objv[0]; - - if (result == TCL_OK) { - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - } - - if (result != TCL_OK) { - /* - * Tailcall execution was preempted, eg by an intervening catch or by - * a now-gone namespace: cleanup and return. - */ - - Tcl_DecrRefCount(listPtr); - return result; - } /* * Perform the tailcall */ TclMarkTailcall(interp); TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); + + /* Reference count already incremented in TclSetTailcall. */ iPtr->lookupNsPtr = (Namespace *) nsPtr; - return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); + + return TclNREvalObjv(interp, objc, objv, 0, NULL); } int TclNRReleaseValues( ClientData data[], @@ -8847,13 +8849,13 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { + Tcl_Obj *listPtr; CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp); + Namespace *nsPtr = (Namespace *)TclGetCurrentNamespace(interp); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); return TCL_ERROR; } @@ -8863,34 +8865,23 @@ "yieldto can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; } - if (((Namespace *) nsPtr)->flags & NS_DYING) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto called in deleted namespace", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", - NULL); - return TCL_ERROR; - } - /* * Add the tailcall in the caller env, then just yield. * * This is essentially code from TclNRTailcallObjCmd */ - - listPtr = Tcl_NewListObj(objc, objv); - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); + listPtr = Tcl_NewListObj(objc-1, objv+1); /* * Add the callback in the caller's env, then instruct TEBC to yield. */ iPtr->execEnvPtr = corPtr->callerEEPtr; - TclSetTailcall(interp, listPtr); + TclSetTailcall(interp, nsPtr, listPtr); iPtr->execEnvPtr = corPtr->eePtr; return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); } @@ -9001,10 +8992,12 @@ NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); NRE_ASSERT((corPtr->callerEEPtr->callbackPtr->procPtr == NRCoroutineCallerCallback)); cmdPtr->deleteProc = NULL; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + + /* Corresponding cmdPtr->refCount ++ is in TclNRCoroutineObjCmd */ TclCleanupCommandMacro(cmdPtr); corPtr->eePtr->corPtr = NULL; TclDeleteExecEnv(corPtr->eePtr); corPtr->eePtr = NULL; @@ -9375,10 +9368,11 @@ TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); /* ensure that the command is looked up in the correct namespace */ iPtr->lookupNsPtr = lookupNsPtr; + lookupNsPtr->refCount++; Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); iPtr->numLevels--; SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); Index: generic/tclCompCmdsSZ.c ================================================================== --- generic/tclCompCmdsSZ.c +++ generic/tclCompCmdsSZ.c @@ -2616,18 +2616,15 @@ if (parsePtr->numWords < 2 || parsePtr->numWords > 256 || envPtr->procPtr == NULL) { return TCL_ERROR; } - /* make room for the nsObjPtr */ - /* TODO: Doesn't this have to be a known value? */ - CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); + TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords - 1, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3935,16 +3932,15 @@ if (parsePtr->numWords < 2) { return TCL_ERROR; } - OP( NS_CURRENT); for (i = 1 ; i < parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - OP4( LIST, i); + OP4( LIST, i-1); OP( YIELD_TO_INVOKE); return TCL_OK; } /* Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -1135,10 +1135,11 @@ if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) { TclFreeLocalCache(interp, codePtr->localCachePtr); } TclHandleRelease(codePtr->interpHandle); + TclNsDecrRefCount(codePtr->nsPtr); ckfree(codePtr); } /* * --------------------------------------------------------------------- @@ -2804,10 +2805,11 @@ p = ckalloc(structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = namespacePtr; + codePtr->nsPtr->refCount++; codePtr->nsEpoch = namespacePtr->resolverEpoch; codePtr->refCount = 0; TclPreserveByteCode(codePtr); if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) { codePtr->flags = TCL_BYTECODE_RESOLVE_VARS; Index: generic/tclEnsemble.c ================================================================== --- generic/tclEnsemble.c +++ generic/tclEnsemble.c @@ -148,11 +148,11 @@ Tcl_DictSearch search; Tcl_Obj *listObj; const char *simpleName; int index, done; - if (nsPtr == NULL || nsPtr->flags & NS_DYING) { + if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "tried to manipulate ensemble of deleted namespace", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); @@ -1713,11 +1713,11 @@ Tcl_DStringFree(&buf); return TCL_ERROR; } - if (ensemblePtr->nsPtr->flags & NS_DYING) { + if (ensemblePtr->nsPtr->flags & NS_DEAD) { /* * Don't know how we got here, but make things give up quickly. */ if (!Tcl_InterpDeleted(interp)) { @@ -1909,10 +1909,11 @@ */ TclSkipTailcall(interp); Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; + ensemblePtr->nsPtr->refCount++; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } unknownOrAmbiguousSubcommand: /* Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -2393,11 +2393,12 @@ #endif yieldParameter = 0; Tcl_SetObjResult(interp, OBJ_AT_TOS); goto doYield; - case INST_YIELD_TO_INVOKE: + case INST_YIELD_TO_INVOKE: { + Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); corPtr = iPtr->execEnvPtr->corPtr; valuePtr = OBJ_AT_TOS; if (!corPtr) { TRACE(("[%.30s] => ERROR: yield outside coroutine\n", O2S(valuePtr))); @@ -2404,21 +2405,10 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto can only be called in a coroutine", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); - CACHE_STACK_INFO(); - goto gotError; - } - if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) { - TRACE(("[%.30s] => ERROR: yield in deleted\n", - O2S(valuePtr))); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto called in deleted namespace", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", - NULL); CACHE_STACK_INFO(); goto gotError; } #ifdef TCL_COMPILE_DEBUG @@ -2441,14 +2431,15 @@ * 'yieldParameter'). */ Tcl_IncrRefCount(valuePtr); iPtr->execEnvPtr = corPtr->callerEEPtr; - TclSetTailcall(interp, valuePtr); + TclSetTailcall(interp, currNsPtr, valuePtr); iPtr->execEnvPtr = corPtr->eePtr; yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/ + } doYield: /* TIP #280: Record the last piece of info needed by * 'TclGetSrcInfoForPc', and push the frame. */ @@ -2466,11 +2457,11 @@ INT2PTR(yieldParameter), NULL, NULL); return TCL_OK; } case INST_TAILCALL: { - Tcl_Obj *listPtr, *nsObjPtr; + Tcl_Obj *listPtr; opnd = TclGetUInt1AtPtr(pc+1); if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); @@ -2502,16 +2493,19 @@ * Push the evaluation of the called command into the NR callback * stack. */ listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); - nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - if (iPtr->varFramePtr->tailcallPtr) { - Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); + if (iPtr->varFramePtr->tailcallNsPtr) { + TclNsDecrRefCount(iPtr->varFramePtr->tailcallNsPtr); + iPtr->varFramePtr->tailcallNsPtr = NULL; + Tcl_DecrRefCount(iPtr->varFramePtr->tailcallCmdPtr); + iPtr->varFramePtr->tailcallCmdPtr = NULL; } - iPtr->varFramePtr->tailcallPtr = listPtr; + iPtr->varFramePtr->tailcallNsPtr = iPtr->varFramePtr->nsPtr; + iPtr->varFramePtr->tailcallNsPtr->refCount++; + iPtr->varFramePtr->tailcallCmdPtr = listPtr; result = TCL_RETURN; cleanup = opnd; goto processExceptionReturn; } Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -292,14 +292,10 @@ unsigned long nsId; /* Unique id for the namespace. */ Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status * flags NS_DYING and NS_DEAD listed below. */ - int activationCount; /* Number of "activations" or active call - * frames for this namespace that are on the - * Tcl call stack. The namespace won't be - * freed until activationCount becomes zero. */ unsigned int refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently * registered in the namespace. Indexed by @@ -415,15 +411,15 @@ * namespace resolution code to recognize that the namespace is * "deleted". When the last namespaceName object in any byte code * unit that refers to the namespace has been freed (i.e., when * the namespace's refCount is 0), the namespace's storage will * be freed. - * NS_KILLED - 1 means that TclTeardownNamespace has already been called on - * this namespace and it should not be called again [Bug 1355942] - * NS_SUPPRESS_COMPILATION - - * Marks the commands in this namespace for not being compiled, - * forcing them to be looked up every time. + * NS_KILLED - Obsolete. Previously, 1 meant that TclTeardownNamespace has + * already been called on this namespace and it should not be + * called again [Bug 1355942] NS_SUPPRESS_COMPILATION - Marks the + * commands in this namespace for not being compiled, forcing them + * to be looked up every time. */ #define NS_DYING 0x01 #define NS_DEAD 0x02 #define NS_KILLED 0x04 @@ -1154,11 +1150,12 @@ * case, the code that sets it should also * have some means of discovering what the * meaning of the value is, which we do not * specify. */ LocalCache *localCachePtr; - Tcl_Obj *tailcallPtr; + Namespace * tailcallNsPtr; + Tcl_Obj *tailcallCmdPtr; /* NULL if no tailcall is scheduled */ } CallFrame; #define FRAME_IS_PROC 0x1 #define FRAME_IS_LAMBDA 0x2 @@ -2827,11 +2824,12 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues; -MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); +MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Namespace *nsPtr, + Tcl_Obj *listPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); /* These two can be considered for the public api */ MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp); MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp); @@ -4831,11 +4829,13 @@ *---------------------------------------------------------------- * Inline version of Tcl_GetCurrentNamespace and Tcl_GetGlobalNamespace. */ #define TclGetCurrentNamespace(interp) \ - (Tcl_Namespace *) ((Interp *)(interp))->varFramePtr->nsPtr + (Tcl_Namespace *) ((((Interp *)(interp))->varFramePtr->nsPtr->flags & NS_DEAD) \ + ? ((Interp *) (interp))->globalNsPtr \ + : ((Interp *) (interp))->varFramePtr->nsPtr) #define TclGetGlobalNamespace(interp) \ (Tcl_Namespace *) ((Interp *)(interp))->globalNsPtr /* Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -306,12 +306,12 @@ nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; /* - * TODO: Examine whether it would be better to guard based on NS_DYING - * or NS_KILLED. It appears that these are not tested because they can + * TODO: Examine whether it would be better to guard based on NS_DYING. + * It appears that these are not tested because they can * be set in a global interp that has been [namespace delete]d, but * which never really completely goes away because of lingering global * things like ::errorInfo and [::unknown] and hidden commands. * Review of those designs might permit stricter checking here. */ @@ -320,11 +320,11 @@ Tcl_Panic("Trying to push call frame for dead namespace"); /*NOTREACHED*/ } } - nsPtr->activationCount++; + nsPtr->refCount++; framePtr->nsPtr = nsPtr; framePtr->isProcCallFrame = isProcCallFrame; framePtr->objc = 0; framePtr->objv = NULL; framePtr->callerPtr = iPtr->framePtr; @@ -338,11 +338,12 @@ framePtr->varTablePtr = NULL; /* and no local variables */ framePtr->numCompiledLocals = 0; framePtr->compiledLocals = NULL; framePtr->clientData = NULL; framePtr->localCachePtr = NULL; - framePtr->tailcallPtr = NULL; + framePtr->tailcallNsPtr = NULL; + framePtr->tailcallCmdPtr = NULL; /* * Push the new call frame onto the interpreter's stack of procedure call * frames making it the current frame. */ @@ -376,11 +377,10 @@ Tcl_PopCallFrame( Tcl_Interp *interp) /* Interpreter with call frame to pop. */ { register Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = iPtr->framePtr; - Namespace *nsPtr; /* * It's important to remove the call frame from the interpreter's stack of * call frames before deleting local variables, so that traces invoked by * the variable deletion don't see the partially-deleted frame. @@ -405,25 +405,22 @@ } framePtr->localCachePtr = NULL; } /* - * Decrement the namespace's count of active call frames. If the namespace - * is "dying" and there are no more active call frames, call - * Tcl_DeleteNamespace to destroy it. + * Decrement the namespace's count of active call frames. */ - nsPtr = framePtr->nsPtr; - nsPtr->activationCount--; - if ((nsPtr->flags & NS_DYING) - && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { - Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); - } + /* Corresponds to refCount++ in Tcl_PushCallFrame */ + TclNsDecrRefCount(framePtr->nsPtr); framePtr->nsPtr = NULL; - if (framePtr->tailcallPtr) { - TclSetTailcall(interp, framePtr->tailcallPtr); + if (framePtr->tailcallNsPtr) { + TclSetTailcall(interp, framePtr->tailcallNsPtr, + framePtr->tailcallCmdPtr); + TclNsDecrRefCount(framePtr->tailcallNsPtr); + framePtr->tailcallNsPtr = NULL; } } /* *---------------------------------------------------------------------- @@ -782,12 +779,12 @@ nsPtr->childTablePtr = NULL; #endif nsPtr->nsId = ++(tsdPtr->numNsCreated); nsPtr->interp = interp; nsPtr->flags = 0; - nsPtr->activationCount = 0; - nsPtr->refCount = 0; + /* Corresponding TclNsDecrRefCount is at the end of Tcl_DeleteNamespace */ + nsPtr->refCount = 1; Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); TclInitVarHashTable(&nsPtr->varTable, nsPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; @@ -903,22 +900,24 @@ void Tcl_DeleteNamespace( Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */ { - register Namespace *nsPtr = (Namespace *) namespacePtr; + int i, newChildren; + register Namespace *nsPtr = (Namespace *) namespacePtr, *childPtr ; Interp *iPtr = (Interp *) nsPtr->interp; Namespace *globalNsPtr = (Namespace *) - TclGetGlobalNamespace((Tcl_Interp *) iPtr); - Tcl_HashEntry *entryPtr; + TclGetGlobalNamespace((Tcl_Interp *) iPtr); + register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Command *cmdPtr; - /* - * Ensure that this namespace doesn't get deallocated in the meantime. - */ - nsPtr->refCount++; + if (nsPtr->flags & NS_DYING) { + return; + } + + nsPtr->flags |= NS_DYING; /* * Give anyone interested - notably TclOO - a chance to use this namespace * normally despite the fact that the namespace is going to go. Allows the * calling of destructors. Will only be called once (unless re-established @@ -931,54 +930,172 @@ if (nsPtr->earlyDeleteProc != NULL) { Tcl_NamespaceDeleteProc *earlyDeleteProc = nsPtr->earlyDeleteProc; nsPtr->earlyDeleteProc = NULL; - nsPtr->activationCount++; earlyDeleteProc(nsPtr->clientData); - nsPtr->activationCount--; - } - - /* - * Delete all coroutine commands now: break the circular ref cycle between - * the namespace and the coroutine command [Bug 2724403]. This code is - * essentially duplicated in TclTeardownNamespace() for all other - * commands. Don't optimize to Tcl_NextHashEntry() because of traces. - * - * NOTE: we could avoid traversing the ns's command list by keeping a - * separate list of coros. - */ - - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); - entryPtr != NULL;) { - cmdPtr = Tcl_GetHashValue(entryPtr); - if (cmdPtr->nreProc == TclNRInterpCoroutine) { - Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, - (Tcl_Command) cmdPtr); - entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); - } else { - entryPtr = Tcl_NextHashEntry(&search); - } - } - - /* - * If the namespace has associated ensemble commands, delete them first. - * This leaves the actual contents of the namespace alone (unless they are - * linked ensemble commands, of course). Note that this code is actually - * reentrant so command delete traces won't purturb things badly. - */ - - while (nsPtr->ensembles != NULL) { - EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles; - - /* - * Splice out and link to indicate that we've already been killed. - */ - - nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; - ensemblePtr->next = ensemblePtr; - Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token); + } + + do { + + /* + * If the namespace has associated ensemble commands, delete them first. + * This leaves the actual contents of the namespace alone (unless they are + * linked ensemble commands, of course). Note that this code is actually + * reentrant so command delete traces won't purturb things badly. + */ + + while (nsPtr->ensembles != NULL) { + EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles; + + /* + * Splice out and link to indicate that we've already been killed. + */ + + nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; + ensemblePtr->next = ensemblePtr; + Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token); + } + + + /* + * Delete all coroutine commands now: break the circular ref cycle between + * the namespace and the coroutine command [Bug 2724403]. This code is + * essentially duplicated in TclTeardownNamespace() for all other + * commands. Don't optimize to Tcl_NextHashEntry() because of traces. + * + * NOTE: we could avoid traversing the ns's command list by keeping a + * separate list of coros. + */ + + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + entryPtr != NULL;) { + cmdPtr = Tcl_GetHashValue(entryPtr); + if (cmdPtr->nreProc == TclNRInterpCoroutine) { + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, + (Tcl_Command) cmdPtr); + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + } else { + entryPtr = Tcl_NextHashEntry(&search); + } + } + + /* + * Delete all the child namespaces. + * + * BE CAREFUL: When each child is deleted, it will divorce itself from its + * parent. You can't traverse a hash table properly if its elements are + * being deleted. Because of traces (and the desire to avoid the + * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) we copy to a temporary array and then delete all those + * namespaces. + * + * Important: leave the hash table itself still live. + */ + +#ifndef BREAK_NAMESPACE_COMPAT + do { + int length = nsPtr->childTable.numEntries; + Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + newChildren = 0; + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + TclStackFree((Tcl_Interp *) iPtr, children); + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + childPtr = Tcl_GetHashValue(entryPtr); + if (!(childPtr->flags & NS_DYING)) { + newChildren = 1; + break; + } + } + + } while (newChildren); +#else + if (nsPtr->childTablePtr != NULL) { + while (nsPtr->childTablePtr->numEntries > 0) { + int length = nsPtr->childTablePtr->numEntries; + Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + TclStackFree((Tcl_Interp *) iPtr, children); + } + } +#endif + /* + * Delete all commands in this namespace. Be careful when traversing the + * hash table: when each command is deleted, it removes itself from the + * command table. Because of traces (and the desire to avoid the quadratic + * problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) we copy to a temporary array and then delete all those + * commands. + */ + + while (nsPtr->cmdTable.numEntries > 0) { + int length = nsPtr->cmdTable.numEntries; + Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Command *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + cmds[i] = Tcl_GetHashValue(entryPtr); + cmds[i]->refCount++; + i++; + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, + (Tcl_Command) cmds[i]); + TclCleanupCommandMacro(cmds[i]); + } + TclStackFree((Tcl_Interp *) iPtr, cmds); + } + + /* + * Destroying the namespace's variable table, which may trigger traces. + * Variable table should be cleared but not freed! + * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards. + */ + + TclDeleteNamespaceVars(nsPtr); + TclInitVarHashTable(&nsPtr->varTable, nsPtr); + + } while (nsPtr->varTable.table.numEntries > 0 + || newChildren || nsPtr->ensembles != NULL); + + /* + * Free any client data associated with the namespace. + */ + + if (nsPtr->deleteProc != NULL) { + nsPtr->deleteProc(nsPtr->clientData); } /* * If the namespace has a registered unknown handler (TIP 181), then free * it here. @@ -988,88 +1105,87 @@ Tcl_DecrRefCount(nsPtr->unknownHandlerPtr); nsPtr->unknownHandlerPtr = NULL; } /* - * If the namespace is on the call frame stack, it is marked as "dying" - * (NS_DYING is OR'd into its flags): the namespace can't be looked up by - * name but its commands and variables are still usable by those active - * call frames. When all active call frames referring to the namespace - * have been popped from the Tcl stack, Tcl_PopCallFrame will call this - * function again to delete everything in the namespace. If no nsName - * objects refer to the namespace (i.e., if its refCount is zero), its - * commands and variables are deleted and the storage for its namespace - * structure is freed. Otherwise, if its refCount is nonzero, the - * namespace's commands and variables are deleted but the structure isn't - * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the - * namespace resolution code to recognize that the namespace is "deleted". - * The structure's storage is freed by FreeNsNameInternalRep when its - * refCount reaches 0. - */ - - if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) { - nsPtr->flags |= NS_DYING; - if (nsPtr->parentPtr != NULL) { - entryPtr = Tcl_FindHashEntry( - TclGetNamespaceChildTable((Tcl_Namespace *) - nsPtr->parentPtr), nsPtr->name); - if (entryPtr != NULL) { - Tcl_DeleteHashEntry(entryPtr); - } - } - nsPtr->parentPtr = NULL; - } else if (!(nsPtr->flags & NS_KILLED)) { - /* - * Delete the namespace and everything in it. If this is the global - * namespace, then clear it but don't free its storage unless the - * interpreter is being torn down. Set the NS_KILLED flag to avoid - * recursive calls here - if the namespace is really in the process of - * being deleted, ignore any second call. - */ - - nsPtr->flags |= (NS_DYING|NS_KILLED); - - TclTeardownNamespace(nsPtr); - - if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { - /* - * If this is the global namespace, then it may have residual - * "errorInfo" and "errorCode" variables for errors that occurred - * while it was being torn down. Try to clear the variable list - * one last time. - */ - - TclDeleteNamespaceVars(nsPtr); + * Remove the namespace from its parent's child hashtable. + */ + + if (nsPtr->parentPtr != NULL) { + entryPtr = Tcl_FindHashEntry( + TclGetNamespaceChildTable((Tcl_Namespace *) + nsPtr->parentPtr), nsPtr->name); + if (entryPtr != NULL) { + Tcl_DeleteHashEntry(entryPtr); + } + } + + nsPtr->parentPtr = NULL; + + + /* + * Delete the namespace path if one is installed. + */ + + if (nsPtr->commandPathLength != 0) { + UnlinkNsPath(nsPtr); + nsPtr->commandPathLength = 0; + } + if (nsPtr->commandPathSourceList != NULL) { + NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; + + do { + if (nsPathPtr->nsPtr != NULL && nsPathPtr->creatorNsPtr != NULL) { + nsPathPtr->creatorNsPtr->cmdRefEpoch++; + } + nsPathPtr->nsPtr = NULL; + nsPathPtr = nsPathPtr->nextPtr; + } while (nsPathPtr != NULL); + nsPtr->commandPathSourceList = NULL; + } + + + /* + * Reset the namespace's id field to ensure that this namespace won't be + * interpreted as valid by, e.g., the cache validation code for cached + * command references in Tcl_GetCommandFromObj. + */ + + nsPtr->nsId = 0; + + if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { + + /* No variables or commands are allowed after this point */ + nsPtr->flags |= NS_DEAD; + Tcl_DeleteHashTable(&nsPtr->varTable.table); + Tcl_DeleteHashTable(&nsPtr->cmdTable); + #ifndef BREAK_NAMESPACE_COMPAT - Tcl_DeleteHashTable(&nsPtr->childTable); + Tcl_DeleteHashTable(&nsPtr->childTable); #else - if (nsPtr->childTablePtr != NULL) { - Tcl_DeleteHashTable(nsPtr->childTablePtr); - ckfree(nsPtr->childTablePtr); - } + if (nsPtr->childTablePtr != NULL) { + Tcl_DeleteHashTable(nsPtr->childTablePtr); + ckfree(nsPtr->childTablePtr); + } #endif - Tcl_DeleteHashTable(&nsPtr->cmdTable); - - nsPtr ->flags |= NS_DEAD; - } else { - /* - * Restore the ::errorInfo and ::errorCode traces. - */ - - EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); - EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); - - /* - * We didn't really kill it, so remove the KILLED marks, so it can - * get killed later, avoiding mem leaks. - */ - - nsPtr->flags &= ~(NS_DYING|NS_KILLED); - } - } - TclNsDecrRefCount(nsPtr); + TclNsDecrRefCount(nsPtr); + } else { + /* + * Restore the ::errorInfo and ::errorCode traces. + */ + + EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); + EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); + + /* + * We didn't really kill it, so remove the KILLED marks, so it can + * get killed later, avoiding mem leaks. + */ + + nsPtr->flags &= ~(NS_DYING|NS_DEAD); + } } /* *---------------------------------------------------------------------- * @@ -1095,148 +1211,12 @@ void TclTeardownNamespace( register Namespace *nsPtr) /* Points to the namespace to be dismantled * and unlinked from its parent. */ { - Interp *iPtr = (Interp *) nsPtr->interp; - register Tcl_HashEntry *entryPtr; - Tcl_HashSearch search; int i; - /* - * Start by destroying the namespace's variable table, since variables - * might trigger traces. Variable table should be cleared but not freed! - * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards. - */ - - TclDeleteNamespaceVars(nsPtr); - TclInitVarHashTable(&nsPtr->varTable, nsPtr); - - /* - * Delete all commands in this namespace. Be careful when traversing the - * hash table: when each command is deleted, it removes itself from the - * command table. Because of traces (and the desire to avoid the quadratic - * problems of just using Tcl_FirstHashEntry over and over, [Bug - * f97d4ee020]) we copy to a temporary array and then delete all those - * commands. - */ - - while (nsPtr->cmdTable.numEntries > 0) { - int length = nsPtr->cmdTable.numEntries; - Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Command *) * length); - - i = 0; - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - cmds[i] = Tcl_GetHashValue(entryPtr); - cmds[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, - (Tcl_Command) cmds[i]); - TclCleanupCommandMacro(cmds[i]); - } - TclStackFree((Tcl_Interp *) iPtr, cmds); - } - Tcl_DeleteHashTable(&nsPtr->cmdTable); - Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); - - /* - * Remove the namespace from its parent's child hashtable. - */ - - if (nsPtr->parentPtr != NULL) { - entryPtr = Tcl_FindHashEntry( - TclGetNamespaceChildTable((Tcl_Namespace *) - nsPtr->parentPtr), nsPtr->name); - if (entryPtr != NULL) { - Tcl_DeleteHashEntry(entryPtr); - } - } - nsPtr->parentPtr = NULL; - - /* - * Delete the namespace path if one is installed. - */ - - if (nsPtr->commandPathLength != 0) { - UnlinkNsPath(nsPtr); - nsPtr->commandPathLength = 0; - } - if (nsPtr->commandPathSourceList != NULL) { - NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; - - do { - if (nsPathPtr->nsPtr != NULL && nsPathPtr->creatorNsPtr != NULL) { - nsPathPtr->creatorNsPtr->cmdRefEpoch++; - } - nsPathPtr->nsPtr = NULL; - nsPathPtr = nsPathPtr->nextPtr; - } while (nsPathPtr != NULL); - nsPtr->commandPathSourceList = NULL; - } - - /* - * Delete all the child namespaces. - * - * BE CAREFUL: When each child is deleted, it will divorce itself from its - * parent. You can't traverse a hash table properly if its elements are - * being deleted. Because of traces (and the desire to avoid the - * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug - * f97d4ee020]) we copy to a temporary array and then delete all those - * namespaces. - * - * Important: leave the hash table itself still live. - */ - -#ifndef BREAK_NAMESPACE_COMPAT - while (nsPtr->childTable.numEntries > 0) { - int length = nsPtr->childTable.numEntries; - Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Namespace *) * length); - - i = 0; - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - children[i] = Tcl_GetHashValue(entryPtr); - children[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); - TclNsDecrRefCount(children[i]); - } - TclStackFree((Tcl_Interp *) iPtr, children); - } -#else - if (nsPtr->childTablePtr != NULL) { - while (nsPtr->childTablePtr->numEntries > 0) { - int length = nsPtr->childTablePtr->numEntries; - Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Namespace *) * length); - - i = 0; - for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - children[i] = Tcl_GetHashValue(entryPtr); - children[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); - TclNsDecrRefCount(children[i]); - } - TclStackFree((Tcl_Interp *) iPtr, children); - } - } -#endif - /* * Free the namespace's export pattern array. */ if (nsPtr->exportArrayPtr != NULL) { @@ -1247,27 +1227,11 @@ nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; } - /* - * Free any client data associated with the namespace. - */ - - if (nsPtr->deleteProc != NULL) { - nsPtr->deleteProc(nsPtr->clientData); - } - nsPtr->deleteProc = NULL; - nsPtr->clientData = NULL; - - /* - * Reset the namespace's id field to ensure that this namespace won't be - * interpreted as valid by, e.g., the cache validation code for cached - * command references in Tcl_GetCommandFromObj. - */ - - nsPtr->nsId = 0; + NamespaceFree(nsPtr); } /* *---------------------------------------------------------------------- * @@ -1319,12 +1283,12 @@ void TclNsDecrRefCount( Namespace *nsPtr) { - if ((nsPtr->refCount-- <= 1) && (nsPtr->flags & NS_DEAD)) { - NamespaceFree(nsPtr); + if (nsPtr->refCount-- == 1) { + TclTeardownNamespace(nsPtr); } } /* *---------------------------------------------------------------------- @@ -2219,11 +2183,11 @@ */ if (flags & TCL_GLOBAL_ONLY) { nsPtr = globalNsPtr; } else if (nsPtr == NULL) { - nsPtr = iPtr->varFramePtr->nsPtr; + nsPtr = (Namespace *)TclGetCurrentNamespace(iPtr); } start = qualName; /* Points to start of qualifying * namespace. */ if ((*qualName == ':') && (*(qualName+1) == ':')) { @@ -2437,11 +2401,11 @@ TclEnsureNamespace( Tcl_Interp *interp, Tcl_Namespace *namespacePtr) { Namespace *nsPtr = (Namespace *) namespacePtr; - if (!(nsPtr->flags & NS_DYING)) { + if (!(nsPtr->flags & NS_DEAD)) { return namespacePtr; } return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL); } @@ -2610,11 +2574,11 @@ (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr, TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL)) { if ((cxtNsPtr == realNsPtr) - || !(realNsPtr->flags & NS_DYING)) { + || !(realNsPtr->flags & NS_DEAD)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = Tcl_GetHashValue(entryPtr); } } @@ -2631,11 +2595,11 @@ } (void) TclGetNamespaceForQualName(interp, name, pathNsPtr, TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL) - && !(realNsPtr->flags & NS_DYING)) { + && !(realNsPtr->flags & NS_DEAD)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = Tcl_GetHashValue(entryPtr); } } @@ -2649,11 +2613,11 @@ if (cmdPtr == NULL) { (void) TclGetNamespaceForQualName(interp, name, NULL, TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL) - && !(realNsPtr->flags & NS_DYING)) { + && !(realNsPtr->flags & NS_DEAD)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = Tcl_GetHashValue(entryPtr); } } @@ -2669,19 +2633,22 @@ * Look for the command in the command table of its namespace. Be sure * to check both possible search paths: from the specified namespace * context and from the global namespace. */ - for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { - if ((nsPtr[search] != NULL) && (simpleName != NULL)) { - entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, - simpleName); - if (entryPtr != NULL) { - cmdPtr = Tcl_GetHashValue(entryPtr); + for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { + if ((nsPtr[search] != NULL) && (simpleName != NULL) + && !(nsPtr[search]->flags & NS_DEAD)) { + + entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, + simpleName); + if (entryPtr != NULL) { + cmdPtr = Tcl_GetHashValue(entryPtr); + } } } - } + } if (cmdPtr != NULL) { cmdPtr->flags &= ~CMD_VIA_RESOLVER; return (Tcl_Command) cmdPtr; @@ -2907,11 +2874,11 @@ */ resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; - if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) + if (!(nsPtr->flags & NS_DEAD) && (interp == nsPtr->interp) && (!refNsPtr || (refNsPtr == (Namespace *) TclGetCurrentNamespace(interp)))) { *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } @@ -3266,11 +3233,11 @@ for (i = 1; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); if ((namespacePtr == NULL) - || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { + || (((Namespace *) namespacePtr)->flags & NS_DEAD)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown namespace \"%s\" in namespace delete command", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", TclGetString(objv[i]), NULL); @@ -4700,10 +4667,13 @@ * namespace is dead, and there are no more references to it, free * it. */ TclNsDecrRefCount(resNamePtr->nsPtr); + if (resNamePtr->refNsPtr) { + TclNsDecrRefCount(resNamePtr->refNsPtr); + } ckfree(resNamePtr); } objPtr->typePtr = NULL; } @@ -4783,11 +4753,11 @@ /* * If we found a namespace, then create a new ResolvedNsName structure * that holds a reference to it. */ - if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { + if ((nsPtr == NULL) || (nsPtr->flags & NS_DEAD)) { /* * Our failed lookup proves any previously cached nsName intrep is no * longer valid. Get rid of it so we no longer waste memory storing * it, nor time determining its invalidity again and again. */ @@ -4796,17 +4766,18 @@ TclFreeIntRep(objPtr); } return TCL_ERROR; } - nsPtr->refCount++; resNamePtr = ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; + nsPtr->refCount++; if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; } else { resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + resNamePtr->refNsPtr->refCount++; } resNamePtr->refCount = 1; TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; objPtr->typePtr = &nsNameType; Index: generic/tclOO.c ================================================================== --- generic/tclOO.c +++ generic/tclOO.c @@ -1144,11 +1144,12 @@ * Also delete the command that refers to the object at this point (if * it still exists) because otherwise its pointer to the object * points into freed memory. */ - if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) { + if (oPtr->command == NULL || (( + Command *)oPtr->command)->flags & CMD_IS_DELETED) { /* * Something has already started the command deletion process. We can * go ahead and clean up the the namespace, */ } else { Index: generic/tclOOMethod.c ================================================================== --- generic/tclOOMethod.c +++ generic/tclOOMethod.c @@ -866,10 +866,12 @@ if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { ByteCode *codePtr = pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + nsPtr->refCount++; + TclNsDecrRefCount(codePtr->nsPtr); codePtr->nsPtr = nsPtr; } result = TclProcCompileProc(interp, pmPtr->procPtr, pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr); if (result != TCL_OK) { @@ -1488,10 +1490,12 @@ * of the TCL_EVAL_NOERR flag results in an evaluation configuration * very much like TCL_EVAL_INVOKE. */ ((Interp *)interp)->lookupNsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; + /* Corresponding TclNrDecrRefCount is in EvalObjvCore */ + ((Namespace *)contextPtr->oPtr->namespacePtr)->refCount++; return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL); } static int FinalizeForwardCall( Index: generic/tclObj.c ================================================================== --- generic/tclObj.c +++ generic/tclObj.c @@ -4131,11 +4131,11 @@ if (objPtr->typePtr == &tclCmdNameType) { register Command *cmdPtr = resPtr->cmdPtr; if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) && (interp == cmdPtr->nsPtr->interp) - && !(cmdPtr->nsPtr->flags & NS_DYING)) { + && !(cmdPtr->nsPtr->flags & NS_DEAD)) { register Namespace *refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); if ((resPtr->refNsPtr == NULL) || ((refNsPtr == resPtr->refNsPtr) Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -1891,10 +1891,12 @@ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "CROSSINTERPBYTECODE", NULL); return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; + nsPtr->refCount++; + TclNsDecrRefCount(codePtr->nsPtr); codePtr->nsPtr = nsPtr; } else { TclFreeIntRep(bodyPtr); } } Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -817,20 +817,23 @@ if (flags & TCL_GLOBAL_ONLY) { cxtNsPtr = iPtr->globalNsPtr; } else { cxtNsPtr = iPtr->varFramePtr->nsPtr; + if (cxtNsPtr->flags & NS_DEAD) { + cxtNsPtr = iPtr->globalNsPtr; + } } /* * If this namespace has a variable resolver, then give it first crack at * the variable resolution. It may return a Tcl_Var value, it may signal * to continue onward, or it may signal an error. */ if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) - && !(flags & TCL_AVOID_RESOLVERS)) { + && !(flags & TCL_AVOID_RESOLVERS) && !(cxtNsPtr->flags & NS_DEAD)) { resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { result = cxtNsPtr->varResProc(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags, &var); } else { Index: tests/basic.test ================================================================== --- tests/basic.test +++ tests/basic.test @@ -989,13 +989,13 @@ unset -nocomplain m interp delete slave } -result {0 {}} # Clean up after expand tests -unset noComp l1 l2 constraints -rename l3 {} -rename run {} +catch {unset noComp l1 l2 constraints} +catch {rename l3 {}} +catch {rename run {}} #cleanup catch {namespace delete {*}[namespace children :: test_ns_*]} catch {namespace delete george} catch {interp delete test_interp} Index: tests/coroutine.test ================================================================== --- tests/coroutine.test +++ tests/coroutine.test @@ -656,14 +656,14 @@ namespace delete cotest namespace eval cotest {} lappend ::result [cotest] cotest return $result -} -returnCodes error -cleanup { +} -cleanup { catch {namespace delete ::cotest} catch {rename cotest ""} -} -result {yieldto called in deleted namespace} +} -result {a OUT b 123 c} test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup { namespace eval cotest {} set ::result "" } -body { proc cotest::body {} { @@ -679,14 +679,14 @@ namespace delete cotest namespace eval cotest {} lappend ::result [cotest] cotest return $result -} -returnCodes error -cleanup { +} -cleanup { catch {namespace delete ::cotest} catch {rename cotest ""} -} -result {yieldto called in deleted namespace} +} -result {a OUT b 123 c} test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup { namespace eval cotest {} set ::result "" } -body { proc cotest::body {} { @@ -699,14 +699,14 @@ } lappend ::result [coroutine cotest cotest::body] lappend ::result [cotest] cotest return $result -} -returnCodes error -cleanup { +} -cleanup { catch {namespace delete ::cotest} catch {rename cotest ""} -} -result {yieldto called in deleted namespace} +} -result {a OUT b 123 c} test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup { namespace eval cotest {} set ::result "" } -body { proc cotest::body {} { @@ -720,14 +720,14 @@ } lappend ::result [coroutine cotest cotest::body] lappend ::result [cotest] cotest return $result -} -returnCodes error -cleanup { +} -cleanup { catch {namespace delete ::cotest} catch {rename cotest ""} -} -result {yieldto called in deleted namespace} +} -result {a OUT b 123 c} test coroutine-7.12 {coro floor above street level #3008307} -body { proc c {} { yield } proc cc {} { Index: tests/interp.test ================================================================== --- tests/interp.test +++ tests/interp.test @@ -17,10 +17,28 @@ ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] + +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} + set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} foreach i [interp slaves] { interp delete $i @@ -880,10 +898,19 @@ test interp-18.10 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg } {1 {attempt to call eval in deleted interpreter}} + +test interp-10.11 {test for leaks in simple creation/deletion} -setup { +} -constraints memory -body { + leaktest { + interp create slave + interp delete slave + } +} -cleanup { +} -result 0 # Test alias deletion test interp-19.1 {alias deletion} { catch {interp delete a} Index: tests/namespace.test ================================================================== --- tests/namespace.test +++ tests/namespace.test @@ -135,11 +135,11 @@ namespace delete [namespace current] return [namespace current] } } list [test_ns_1::p] [catch {test_ns_1::p} msg] $msg -} {::test_ns_1 1 {invalid command name "test_ns_1::p"}} +} {:: 1 {invalid command name "test_ns_1::p"}} test namespace-7.2 {Tcl_DeleteNamespace, no active call frames in ns} { namespace eval test_ns_2 { proc p {} { return [namespace current] } @@ -206,10 +206,57 @@ } } -body { # No segmentation fault given --enable-symbols=mem. namespace delete ns1 } -result {} + +test namespace-7.9 { + Looking up a command when the current namespace is deleted +} -body { + list [catch { + namespace eval ns1 { + proc p1 {} {} + namespace delete [namespace current] + p1 + } + } msg] $msg +} -result {1 {invalid command name "p1"}} + +test namespace-7.10 { + A namespace can be looked up during the delete process. +} -body { + variable res failure + namespace eval ns1 { + namespace ensemble create + trace add command [namespace current] delete [list ::apply [list args { + set [namespace parent]::res triggered + } [namespace current]]] + namespace delete [namespace current] + } + return $res +} -cleanup { + unset res +} -result triggered + +test namespace-7.11 { + Commands are deleted before variables. +} -body { + variable res failure + namespace eval ns1 { + namespace ensemble create + namespace upvar [namespace parent] res res + proc p1 {} {} + trace add command p1 delete [list ::apply [list args { + variable res + set res triggered + } [namespace current]]] + namespace delete [namespace current] + } + return $res +} -cleanup { + unset res +} -result triggered test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} interp create test_interp interp eval test_interp { @@ -1587,11 +1634,11 @@ namespace delete [namespace current] return [namespace current] } } test_ns_1::p -} -result {::test_ns_1} +} -result {::} test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} { namespace eval test_ns_1 { proc q {} { return [namespace current] } @@ -2086,11 +2133,11 @@ namespace delete [namespace current] } namespace ensemble create } list [ns foo] [info exist ns::x] -} {1 0} +} {0 0} test namespace-46.9 {ensemble: configuring really configures things} { namespace eval ns { namespace ensemble create -map {a a} -prefixes 0 } set result [list [catch {ns x} msg] $msg] @@ -2741,12 +2788,11 @@ proc bar {} { list [foo] [namespace delete ::test_ns_2] [foo] } bar } - # Should the result be "2 {} {2 3 2 1}" instead? -} -result {2 {} {2 3 1 1}} -cleanup { +} -result {2 {} {2 3 2 2 1}} -cleanup { catch {namespace delete ::test_ns_1} catch {namespace delete ::test_ns_2} catch {namespace delete ::test_ns_3} catch {namespace delete ::test_ns_4} } @@ -3280,19 +3326,27 @@ trace add command abc delete "rename ::testing::def {}; #" trace add command def delete "rename ::testing::abc {}; #" } namespace delete ::testing } {} -test namespace-56.2 {bug f97d4ee020: mutually-entangled deletion} { - namespace eval ::testing { - namespace eval abc {proc xyz {} {}} - namespace eval def {proc xyz {} {}} - trace add command abc::xyz delete "namespace delete ::testing::def {}; #" - trace add command def::xyz delete "namespace delete ::testing::abc {}; #" - } - namespace delete ::testing -} {} +test namespace-56.2 {bug f97d4ee020: mutually-entangled deletion} -setup { + # Since this test deletes the global namespace, isolate the carnage in a + # slave. + interp create slave +} -body { + slave eval { + namespace eval ::testing { + namespace eval abc {proc xyz {} {}} + namespace eval def {proc xyz {} {}} + trace add command abc::xyz delete "namespace delete ::testing::def {}; #" + trace add command def::xyz delete "namespace delete ::testing::abc {}; #" + } + namespace delete ::testing + } +} -cleanup { + interp delete slave +} -result {} test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} { namespace eval ::testing { variable gone {} oo::class create CB { variable cmd Index: tests/oo.test ================================================================== --- tests/oo.test +++ tests/oo.test @@ -610,14 +610,14 @@ set state ok my eval {upvar 0 ::result result} } method nuke {} { namespace delete [namespace current] - return $result + return $::result } destructor { - lappend result [self] $state [info commands localcmdexists] + lappend ::result [self] $state [info commands localcmdexists] } } cls create obj namespace delete [info object namespace obj] [cls create obj2] nuke Index: tests/trace.test ================================================================== --- tests/trace.test +++ tests/trace.test @@ -2476,11 +2476,11 @@ } namespace eval ::foo {proc bar {} {}} trace add command ::foo::bar delete [namespace code callback] namespace eval ::foo namespace delete ::foo set x -} {::foo::bar exists: } +} {::foo::bar exists: ::foo::bar} test trace-34.6 {Bug 1458266} -setup { proc dummy {} {} proc stepTraceHandler {cmdString args} { variable log Index: tests/var.test ================================================================== --- tests/var.test +++ tests/var.test @@ -152,54 +152,60 @@ lappend result [catch {set foo 3} msg] $msg lappend result [catch {set foo(3) 3} msg] $msg } p } {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}} -test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} { +test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} -body { + variable result namespace eval test_ns_var { variable result namespace eval subns { variable foo 2 } upvar 0 subns::foo foo - lappend result [catch {set foo} msg] $msg + lappend [namespace parent]::result [catch {set foo} msg] $msg namespace delete subns - lappend result [catch {set foo 3} msg] $msg - lappend result [catch {set foo(3) 3} msg] $msg + lappend [namespace parent]::result [catch {set foo 3} msg] $msg + lappend [namespace parent]::result [catch {set foo(3) 3} msg] $msg namespace delete [namespace current] - set result } -} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}} + set result +} -cleanup { + unset result +} -result {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}} + test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} { + variable result {} namespace eval test_ns_var { - variable result proc p {} { array set x {1 2 3 4} upvar 0 x(1) foo - lappend result [catch {set foo} msg] $msg + lappend [namespace parent]::result [catch {set foo} msg] $msg unset x - lappend result [catch {set foo 3} msg] $msg + lappend [namespace parent]::result [catch {set foo 3} msg] $msg } set result [p] namespace delete [namespace current] - set result } + set result } {0 2 1 {can't set "foo": upvar refers to element in deleted array}} test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} -setup { unset -nocomplain test_ns_var::x } -body { + variable result {} namespace eval test_ns_var { - variable result {} variable x array set x {1 2 3 4} upvar 0 x(1) foo - lappend result [catch {set foo} msg] $msg + lappend [namespace parent]::result [catch {set foo} msg] $msg unset x - lappend result [catch {set foo 3} msg] $msg + lappend [namespace parent]::result [catch {set foo 3} msg] $msg namespace delete [namespace current] - set result } + set result +} -cleanup { + unset result } -result {0 2 1 {can't set "foo": upvar refers to element in deleted array}} test var-1.19 {TclLookupVar, right error message when parsing variable name} -body { [format set] thisvar(doesntexist) } -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} @@ -1455,11 +1461,76 @@ } -body { array default unset ary x } -returnCodes error -cleanup { unset -nocomplain ary } -result * -match glob + + +test var-25.0 {Look up command from deleted namespace} -body { + variable msg + set result [namespace eval test_ns_var { + namespace delete [namespace current] + # Doesn't result in a panic with message called Tcl_FindHashEntry on + # deleted table when Tcl_FindCommand is called to find resolve "catch" + catch {lindex success} [namespace parent]::msg + }] + list $result $msg +} -result {0 success} + +test var-25.1 {set a variable after deleting current namespace} { + variable msg {} + set result [namespace eval test_ns_var { + variable var1 + namespace delete [namespace current] + set var1 one + namespace which -variable var1 + }] +} {::var1} + +test var-25.3 {The current namespace after deleting the current namespace} { + variable msg {} + namespace eval test_ns_var { + variable var1 + namespace delete [namespace current] + namespace current + } +} :: + +test var-25.4 { + declare a namespace variable after deleting the current namespace +} { + variable msg {} + namespace eval test_ns_var { + variable var1 + namespace delete [namespace current] + variable var1 + set var1 one + namespace which -variable var1 + } +} {::var1} + +test var-25.5 { + create a procedure after deleting the current namespace +} { + namespace eval test_ns_var { + namespace delete [namespace current] + proc p1 {} {return hello} + list [namespace which p1] [p1] + } $msg +} {::p1 hello} + +test var-25.6 { + create a namespace after deleting the current namespace +} { + namespace eval test_ns_var { + namespace delete [namespace current] + namespace eval one {namespace current} + } +} {::one} + + catch {namespace delete ns} catch {unset arr} catch {unset v} catch {rename getbytes ""} Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -784,11 +784,11 @@ $(SHELL_ENV) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) gdb-test: ${TCLTEST_EXE} @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run - @echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run + @echo "set args $(TOP_DIR)/tests/all.tcl $${TESTFLAGS} -singleproc 1" >> gdb.run $(GDB) ./${TCLTEST_EXE} --command=gdb.run @rm gdb.run lldb-test: ${TCLTEST_EXE} @echo "settings set target.env-vars @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > lldb.run