Tcl Source Code

    int i;

    /*
     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup,
	 * unless we are exiting.
     */

    if ((iPtr->numLevels > 0) && !TclInExit() && !TclInThreadExit()) {
	Tcl_Panic("DeleteInterpProc called with active evals");
    }

    /*
     * The interpreter should already be marked deleted; otherwise how did we
     * get here?
     */

    }

    /*
     * Pop the root frame pointer and finish deleting the global
     * namespace. The order is important [Bug 1658572].
     */

    if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()
	    && !TclInThreadExit()) {
	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);

    /*
     * Location stack for uplevel/eval/... scripts which were passed through
     * proc arguments. Actually we track all arguments as we do not and cannot
     * know which arguments will be used as scripts and which will not.
     */

    if (iPtr->lineLAPtr->numEntries && !TclInExit() && !TclInThreadExit()) {
	/*
	 * When the interp goes away we have nothing on the stack, so there
	 * are no arguments, so this table has to be empty.
	 */

	Tcl_Panic("Argument location tracking table not empty");
    }

    Tcl_DeleteHashTable(iPtr->lineLAPtr);
    ckfree((char *) iPtr->lineLAPtr);
    iPtr->lineLAPtr = NULL;

    if (iPtr->lineLABCPtr->numEntries && !TclInExit() && !TclInThreadExit()) {
	/*
	 * When the interp goes away we have nothing on the stack, so there
	 * are no arguments, so this table has to be empty.
	 */

	Tcl_Panic("Argument location tracking table not empty");
    }

 *----------------------------------------------------------------------
 */

static void
DeleteExecStack(
    ExecStack *esPtr)
{
    if (esPtr->markerPtr && !cachedInExit && !TclInThreadExit()) {
	Tcl_Panic("freeing an execStack which is still in use");
    }

    if (esPtr->prevPtr) {
	esPtr->prevPtr->nextPtr = esPtr->nextPtr;
    }
    if (esPtr->nextPtr) {

	tmpPtr = esPtr;
	esPtr = tmpPtr->prevPtr;
	DeleteExecStack(tmpPtr);
    }

    TclDecrRefCount(eePtr->constants[0]);
    TclDecrRefCount(eePtr->constants[1]);
    if (eePtr->callbackPtr && !cachedInExit && !TclInThreadExit()) {
	Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
    }
    if (eePtr->corPtr && !cachedInExit &&!TclInThreadExit()) {
	Tcl_Panic("Deleting execEnv with existing coroutine");
    }
    ckfree(eePtr);
}

/*
 *----------------------------------------------------------------------

static void		ListUpdateInner(ThreadSpecificData *tsdPtr);
static int		ThreadEventProc(Tcl_Event *evPtr, int mask);
static void		ThreadErrorProc(Tcl_Interp *interp);
static void		ThreadFreeProc(ClientData clientData);
static int		ThreadDeleteEvent(Tcl_Event *eventPtr,
			    ClientData clientData);
static void		ThreadExitProc(ClientData clientData);
static void		ReleaseInterp(ClientData clientData);
extern int		Tcltest_Init(Tcl_Interp *interp);

/*
 *----------------------------------------------------------------------
 *
 * TclThread_Init --
 *

    }
    case THREAD_EXIT:
	if (objc > 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	ListRemove(NULL);
	Tcl_DeleteInterp(interp);
	Tcl_ExitThread(0);
	return TCL_ERROR;
    case THREAD_ID:
	if (objc == 2 || objc == 3) {
	    Tcl_Obj *idObj;

	    /*
	     * Check if they want the main thread id or the current thread id.
	     */

NewTestThread(
    ClientData clientData)
{
    ThreadCtrl *ctrlPtr = clientData;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    int result;
    char *threadEvalScript;
    int fullFinal = TclFullFinalizationRequested();

    /*
     * Initialize the interpreter. This should be more general.
     */

    tsdPtr->interp = Tcl_CreateInterp();
    result = Tcl_Init(tsdPtr->interp);

    Tcl_MutexUnlock(&threadMutex);

    /*
     * Run the script.
     */

    Tcl_Preserve(tsdPtr->interp);
    if (fullFinal) {
	Tcl_CreateThreadExitHandler(ReleaseInterp, tsdPtr->interp);
    }
    result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
    if (fullFinal) {
	Tcl_DeleteThreadExitHandler(ReleaseInterp, tsdPtr->interp);
    }
    if (result != TCL_OK) {
	ThreadErrorProc(tsdPtr->interp);
    }

    /*
     * Clean up.
     */

    ListRemove(tsdPtr);
    Tcl_Release(tsdPtr->interp);
    Tcl_DeleteInterp(tsdPtr->interp);
    Tcl_ExitThread(result);

    TCL_THREAD_CREATE_RETURN;
}

static void
ReleaseInterp(
    ClientData clientData)
{
    Tcl_Interp *interp = (Tcl_Interp *) clientData;

    Tcl_Release(interp);
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadErrorProc --
 *
 *	Send a message to the thread willing to hear about errors.

    if (interp == NULL) {
	code = TCL_ERROR;
	result = "no target interp!";
	errorCode = "THREAD";
	errorInfo = "";
    } else {
	int fullFinal = TclFullFinalizationRequested();

	Tcl_Preserve(interp);
	Tcl_ResetResult(interp);
	if (fullFinal) {
	    Tcl_CreateThreadExitHandler(ReleaseInterp, tsdPtr->interp);
	}
	Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
	code = Tcl_GlobalEval(interp, threadEventPtr->script);
	Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
	if (fullFinal) {
	    Tcl_DeleteThreadExitHandler(ReleaseInterp, tsdPtr->interp);
	}
	if (code != TCL_OK) {
	    errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
	    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
	} else {
	    errorCode = errorInfo = NULL;
	}
	result = Tcl_GetStringResult(interp);