summaryrefslogtreecommitdiffstats
path: root/generic/tclEvent.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclEvent.c')
-rw-r--r--generic/tclEvent.c384
1 files changed, 229 insertions, 155 deletions
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index a10da8f..941d566 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -11,8 +11,6 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclEvent.c,v 1.80.2.2 2009/10/07 23:10:50 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -51,8 +49,8 @@ typedef struct ErrAssocData {
} ErrAssocData;
/*
- * For each exit handler created with a call to Tcl_Create(Late)ExitHandler there is
- * a structure of the following type:
+ * For each exit handler created with a call to Tcl_Create(Late)ExitHandler
+ * there is a structure of the following type:
*/
typedef struct ExitHandler {
@@ -76,19 +74,19 @@ static ExitHandler *firstLateExitPtr = NULL;
TCL_DECLARE_MUTEX(exitMutex)
/*
- * This variable is set to 1 when Tcl_Finalize is called, and at the end of
- * its work, it is reset to 0. The variable is checked by TclInExit() to allow
- * different behavior for exit-time processing, e.g. in closing of files and
- * pipes.
+ * This variable is set to 1 when Tcl_Exit is called. The variable is checked
+ * by TclInExit() to allow different behavior for exit-time processing, e.g.,
+ * in closing of files and pipes.
*/
-static int inFinalize = 0;
+static int inExit = 0;
+
static int subsystemsInitialized = 0;
/*
- * This variable contains the application wide exit handler. It will be
- * called by Tcl_Exit instead of the C-runtime exit if this variable is set
- * to a non-NULL value.
+ * This variable contains the application wide exit handler. It will be called
+ * by Tcl_Exit instead of the C-runtime exit if this variable is set to a
+ * non-NULL value.
*/
static Tcl_ExitProc *appExitPtr = NULL;
@@ -117,8 +115,10 @@ static Tcl_ThreadCreateType NewThreadProc(ClientData clientData);
static void BgErrorDeleteProc(ClientData clientData,
Tcl_Interp *interp);
static void HandleBgErrors(ClientData clientData);
-static char * VwaitVarProc(ClientData clientData, Tcl_Interp *interp,
- CONST char *name1, CONST char *name2, int flags);
+static char * VwaitVarProc(ClientData clientData,
+ Tcl_Interp *interp, const char *name1,
+ const char *name2, int flags);
+static void InvokeExitHandlers(void);
/*
*----------------------------------------------------------------------
@@ -143,10 +143,11 @@ Tcl_BackgroundError(
Tcl_Interp *interp) /* Interpreter in which an error has
* occurred. */
{
- TclBackgroundException(interp, TCL_ERROR);
+ Tcl_BackgroundException(interp, TCL_ERROR);
}
+
void
-TclBackgroundException(
+Tcl_BackgroundException(
Tcl_Interp *interp, /* Interpreter in which an exception has
* occurred. */
int code) /* The exception code value */
@@ -158,7 +159,7 @@ TclBackgroundException(
return;
}
- errPtr = (BgError *) ckalloc(sizeof(BgError));
+ errPtr = ckalloc(sizeof(BgError));
errPtr->errorMsg = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errPtr->errorMsg);
errPtr->returnOpts = Tcl_GetReturnOptions(interp, code);
@@ -166,10 +167,10 @@ TclBackgroundException(
errPtr->nextPtr = NULL;
(void) TclGetBgErrorHandler(interp);
- assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL);
+ assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr->firstBgPtr == NULL) {
assocPtr->firstBgPtr = errPtr;
- Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
+ Tcl_DoWhenIdle(HandleBgErrors, assocPtr);
} else {
assocPtr->lastBgPtr->nextPtr = errPtr;
}
@@ -198,7 +199,7 @@ static void
HandleBgErrors(
ClientData clientData) /* Pointer to ErrAssocData structure. */
{
- ErrAssocData *assocPtr = (ErrAssocData *) clientData;
+ ErrAssocData *assocPtr = clientData;
Tcl_Interp *interp = assocPtr->interp;
BgError *errPtr;
@@ -209,15 +210,15 @@ HandleBgErrors(
* that could lead us here.
*/
- Tcl_Preserve((ClientData) assocPtr);
- Tcl_Preserve((ClientData) interp);
+ Tcl_Preserve(assocPtr);
+ Tcl_Preserve(interp);
while (assocPtr->firstBgPtr != NULL) {
int code, prefixObjc;
Tcl_Obj **prefixObjv, **tempObjv;
/*
- * Note we copy the handler command prefix each pass through, so
- * we do support one handler setting another handler.
+ * Note we copy the handler command prefix each pass through, so we do
+ * support one handler setting another handler.
*/
Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix);
@@ -225,7 +226,7 @@ HandleBgErrors(
errPtr = assocPtr->firstBgPtr;
Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
- tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *));
+ tempObjv = ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
tempObjv[prefixObjc+1] = errPtr->returnOpts;
@@ -240,8 +241,8 @@ HandleBgErrors(
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
assocPtr->firstBgPtr = errPtr->nextPtr;
- ckfree((char *) errPtr);
- ckfree((char *) tempObjv);
+ ckfree(errPtr);
+ ckfree(tempObjv);
if (code == TCL_BREAK) {
/*
@@ -254,12 +255,12 @@ HandleBgErrors(
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
- ckfree((char *) errPtr);
+ ckfree(errPtr);
}
} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel != (Tcl_Channel) NULL) {
+ if (errChannel != NULL) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
@@ -277,12 +278,13 @@ HandleBgErrors(
}
Tcl_WriteChars(errChannel, "\n", 1);
Tcl_Flush(errChannel);
+ Tcl_DecrRefCount(options);
}
}
}
assocPtr->lastBgPtr = NULL;
- Tcl_Release((ClientData) interp);
- Tcl_Release((ClientData) assocPtr);
+ Tcl_Release(interp);
+ Tcl_Release(assocPtr);
}
/*
@@ -308,7 +310,7 @@ TclDefaultBgErrorHandlerObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *keyPtr, *valuePtr;
Tcl_Obj *tempObjv[2];
@@ -331,6 +333,7 @@ TclDefaultBgErrorHandlerObjCmd(
if (valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-level\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) {
@@ -343,6 +346,7 @@ TclDefaultBgErrorHandlerObjCmd(
if (valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-code\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) {
@@ -350,19 +354,26 @@ TclDefaultBgErrorHandlerObjCmd(
}
if (level != 0) {
- /* We're handling a TCL_RETURN exception */
+ /*
+ * We're handling a TCL_RETURN exception.
+ */
+
code = TCL_RETURN;
}
if (code == TCL_OK) {
/*
- * Somehow we got to exception handling with no exception.
- * (Pass TCL_OK to TclBackgroundException()?)
- * Just return without doing anything.
+ * Somehow we got to exception handling with no exception. (Pass
+ * TCL_OK to Tcl_BackgroundException()?) Just return without doing
+ * anything.
*/
+
return TCL_OK;
}
- /* Construct the bgerror command */
+ /*
+ * Construct the bgerror command.
+ */
+
TclNewLiteralStringObj(tempObjv[0], "bgerror");
Tcl_IncrRefCount(tempObjv[0]);
@@ -419,8 +430,11 @@ TclDefaultBgErrorHandlerObjCmd(
*/
saved = Tcl_SaveInterpState(interp, code);
-
- /* Invoke the bgerror command. */
+
+ /*
+ * Invoke the bgerror command.
+ */
+
Tcl_AllowExceptions(interp);
code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL);
if (code == TCL_ERROR) {
@@ -439,7 +453,8 @@ TclDefaultBgErrorHandlerObjCmd(
TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN);
} else {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel != (Tcl_Channel) NULL) {
+
+ if (errChannel != NULL) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
@@ -499,8 +514,7 @@ TclSetBgErrorHandler(
Tcl_Interp *interp,
Tcl_Obj *cmdPrefix)
{
- ErrAssocData *assocPtr = (ErrAssocData *)
- Tcl_GetAssocData(interp, "tclBgError", NULL);
+ ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (cmdPrefix == NULL) {
Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
@@ -510,13 +524,12 @@ TclSetBgErrorHandler(
* First access: initialize.
*/
- assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
+ assocPtr = ckalloc(sizeof(ErrAssocData));
assocPtr->interp = interp;
assocPtr->cmdPrefix = NULL;
assocPtr->firstBgPtr = NULL;
assocPtr->lastBgPtr = NULL;
- Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
- (ClientData) assocPtr);
+ Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr);
}
if (assocPtr->cmdPrefix) {
Tcl_DecrRefCount(assocPtr->cmdPrefix);
@@ -546,16 +559,14 @@ Tcl_Obj *
TclGetBgErrorHandler(
Tcl_Interp *interp)
{
- ErrAssocData *assocPtr = (ErrAssocData *)
- Tcl_GetAssocData(interp, "tclBgError", NULL);
+ ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr == NULL) {
Tcl_Obj *bgerrorObj;
TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror");
TclSetBgErrorHandler(interp, bgerrorObj);
- assocPtr = (ErrAssocData *)
- Tcl_GetAssocData(interp, "tclBgError", NULL);
+ assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
}
return assocPtr->cmdPrefix;
}
@@ -574,7 +585,7 @@ TclGetBgErrorHandler(
*
* Side effects:
* Background error information is freed: if there were any pending error
- * reports, they are cancelled.
+ * reports, they are canceled.
*
*----------------------------------------------------------------------
*/
@@ -584,7 +595,7 @@ BgErrorDeleteProc(
ClientData clientData, /* Pointer to ErrAssocData structure. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
- ErrAssocData *assocPtr = (ErrAssocData *) clientData;
+ ErrAssocData *assocPtr = clientData;
BgError *errPtr;
while (assocPtr->firstBgPtr != NULL) {
@@ -592,11 +603,11 @@ BgErrorDeleteProc(
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
- ckfree((char *) errPtr);
+ ckfree(errPtr);
}
- Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
+ Tcl_CancelIdleCall(HandleBgErrors, assocPtr);
Tcl_DecrRefCount(assocPtr->cmdPrefix);
- Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
+ Tcl_EventuallyFree(assocPtr, TCL_DYNAMIC);
}
/*
@@ -622,9 +633,8 @@ Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
- ExitHandler *exitPtr;
+ ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler));
- exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
@@ -638,7 +648,8 @@ Tcl_CreateExitHandler(
*
* TclCreateLateExitHandler --
*
- * Arrange for a given function to be invoked after all pre-thread cleanups
+ * Arrange for a given function to be invoked after all pre-thread
+ * cleanups.
*
* Results:
* None.
@@ -655,9 +666,8 @@ TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
- ExitHandler *exitPtr;
+ ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler));
- exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
@@ -679,7 +689,7 @@ TclCreateLateExitHandler(
*
* Side effects:
* If there is an exit handler corresponding to proc and clientData then
- * it is cancelled; if no such handler exists then nothing happens.
+ * it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
@@ -701,7 +711,7 @@ Tcl_DeleteExitHandler(
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
- ckfree((char *) exitPtr);
+ ckfree(exitPtr);
break;
}
}
@@ -721,8 +731,8 @@ Tcl_DeleteExitHandler(
* None.
*
* Side effects:
- * If there is a late exit handler corresponding to proc and clientData then
- * it is canceled; if no such handler exists then nothing happens.
+ * If there is a late exit handler corresponding to proc and clientData
+ * then it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
@@ -744,7 +754,7 @@ TclDeleteLateExitHandler(
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
- ckfree((char *) exitPtr);
+ ckfree(exitPtr);
break;
}
}
@@ -778,7 +788,7 @@ Tcl_CreateThreadExitHandler(
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
+ exitPtr = ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
exitPtr->nextPtr = tsdPtr->firstExitPtr;
@@ -798,7 +808,7 @@ Tcl_CreateThreadExitHandler(
*
* Side effects:
* If there is an exit handler corresponding to proc and clientData then
- * it is cancelled; if no such handler exists then nothing happens.
+ * it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
@@ -820,7 +830,7 @@ Tcl_DeleteThreadExitHandler(
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
- ckfree((char *) exitPtr);
+ ckfree(exitPtr);
return;
}
}
@@ -862,6 +872,49 @@ Tcl_SetExitProc(
return prevExitProc;
}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InvokeExitHandlers --
+ *
+ * Call the registered exit handlers.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The exit handlers are invoked, and the ExitHandler struct is
+ * freed.
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+InvokeExitHandlers(void)
+{
+ ExitHandler *exitPtr;
+
+ Tcl_MutexLock(&exitMutex);
+ inExit = 1;
+
+ for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
+ /*
+ * Be careful to remove the handler from the list before invoking its
+ * callback. This protects us against double-freeing if the callback
+ * should call Tcl_DeleteExitHandler on itself.
+ */
+
+ firstExitPtr = exitPtr->nextPtr;
+ Tcl_MutexUnlock(&exitMutex);
+ exitPtr->proc(exitPtr->clientData);
+ ckfree(exitPtr);
+ Tcl_MutexLock(&exitMutex);
+ }
+ firstExitPtr = NULL;
+ Tcl_MutexUnlock(&exitMutex);
+}
+
/*
*----------------------------------------------------------------------
@@ -897,14 +950,41 @@ Tcl_Exit(
* returns, so critical is this dependcy.
*/
- currentAppExitPtr((ClientData) INT2PTR(status));
+ currentAppExitPtr(INT2PTR(status));
Tcl_Panic("AppExitProc returned unexpectedly");
} else {
- /*
- * Use default handling.
- */
- Tcl_Finalize();
+ if (TclFullFinalizationRequested()) {
+
+ /*
+ * Thorough finalization for Valgrind et al.
+ */
+
+ Tcl_Finalize();
+
+ } else {
+
+ /*
+ * Fast and deterministic exit (default behavior)
+ */
+
+ InvokeExitHandlers();
+
+ /*
+ * Ensure the thread-specific data is initialised as it is used in
+ * Tcl_FinalizeThread()
+ */
+
+ (void) TCL_TSD_INIT(&dataKey);
+
+ /*
+ * Now finalize the calling thread only (others are not safely
+ * reachable). Among other things, this triggers a flush of the
+ * Tcl_Channels that may have data enqueued.
+ */
+
+ Tcl_FinalizeThread();
+ }
TclpExit(status);
Tcl_Panic("OS exit failed!");
}
@@ -938,8 +1018,8 @@ Tcl_Exit(
void
TclInitSubsystems(void)
{
- if (inFinalize != 0) {
- Tcl_Panic("TclInitSubsystems called while finalizing");
+ if (inExit != 0) {
+ Tcl_Panic("TclInitSubsystems called while exiting");
}
if (subsystemsInitialized == 0) {
@@ -950,14 +1030,8 @@ TclInitSubsystems(void)
TclpInitLock();
if (subsystemsInitialized == 0) {
- /*
- * Have to set this bit here to avoid deadlock with the routines
- * below us that call into TclInitSubsystems.
- */
-
- subsystemsInitialized = 1;
- /*
+ /*
* Initialize locks used by the memory allocators before anything
* interesting happens so we can use the allocators in the
* implementation of self-initializing locks.
@@ -975,12 +1049,13 @@ TclInitSubsystems(void)
TclpInitPlatform(); /* Creates signal handler(s) */
TclInitDoubleConversion(); /* Initializes constants for
* converting to/from double. */
- TclInitObjSubsystem(); /* Register obj types, create
+ TclInitObjSubsystem(); /* Register obj types, create
* mutexes. */
TclInitIOSubsystem(); /* Inits a tsd key (noop). */
TclInitEncodingSubsystem(); /* Process wide encoding init. */
TclpSetInterfaces();
- TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
+ TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
+ subsystemsInitialized = 1;
}
TclpInitUnlock();
}
@@ -993,8 +1068,8 @@ TclInitSubsystems(void)
* Tcl_Finalize --
*
* Shut down Tcl. First calls registered exit handlers, then carefully
- * shuts down various subsystems. Called by Tcl_Exit or when the Tcl
- * shared library is being unloaded.
+ * shuts down various subsystems. Should be invoked by user before the
+ * Tcl shared library is being unloaded in an embedded context.
*
* Results:
* None.
@@ -1014,23 +1089,7 @@ Tcl_Finalize(void)
* Invoke exit handlers first.
*/
- Tcl_MutexLock(&exitMutex);
- inFinalize = 1;
- for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
- /*
- * Be careful to remove the handler from the list before invoking its
- * callback. This protects us against double-freeing if the callback
- * should call Tcl_DeleteExitHandler on itself.
- */
-
- firstExitPtr = exitPtr->nextPtr;
- Tcl_MutexUnlock(&exitMutex);
- (*exitPtr->proc)(exitPtr->clientData);
- ckfree((char *) exitPtr);
- Tcl_MutexLock(&exitMutex);
- }
- firstExitPtr = NULL;
- Tcl_MutexUnlock(&exitMutex);
+ InvokeExitHandlers();
TclpInitLock();
if (subsystemsInitialized == 0) {
@@ -1059,7 +1118,8 @@ Tcl_Finalize(void)
*/
Tcl_MutexLock(&exitMutex);
- for (exitPtr = firstLateExitPtr; exitPtr != NULL; exitPtr = firstLateExitPtr) {
+ for (exitPtr = firstLateExitPtr; exitPtr != NULL;
+ exitPtr = firstLateExitPtr) {
/*
* Be careful to remove the handler from the list before invoking its
* callback. This protects us against double-freeing if the callback
@@ -1069,7 +1129,7 @@ Tcl_Finalize(void)
firstLateExitPtr = exitPtr->nextPtr;
Tcl_MutexUnlock(&exitMutex);
exitPtr->proc(exitPtr->clientData);
- ckfree((char *) exitPtr);
+ ckfree(exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstLateExitPtr = NULL;
@@ -1080,6 +1140,7 @@ Tcl_Finalize(void)
* after the exit handlers, because there are order dependencies.
*/
+ TclFinalizeEvaluation();
TclFinalizeExecution();
TclFinalizeEnvironment();
@@ -1110,8 +1171,6 @@ Tcl_Finalize(void)
TclFinalizeEncodingSubsystem();
- Tcl_SetPanicProc(NULL);
-
/*
* Repeat finalization of the thread local storage once more. Although
* this step is already done by the Tcl_FinalizeThread call above, series
@@ -1135,10 +1194,10 @@ Tcl_Finalize(void)
/*
* There have been several bugs in the past that cause exit handlers to be
* established during Tcl_Finalize processing. Such exit handlers leave
- * malloc'ed memory, and Tcl_FinalizeThreadAlloc or
- * Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The result
- * can be a mysterious crash on process exit. Check here that nobody's
- * done this.
+ * malloc'ed memory, and Tcl_FinalizeMemorySubsystem or
+ * Tcl_FinalizeThreadAlloc will result in a corrupted heap. The result can
+ * be a mysterious crash on process exit. Check here that nobody's done
+ * this.
*/
if (firstExitPtr != NULL) {
@@ -1185,7 +1244,6 @@ Tcl_Finalize(void)
*/
TclFinalizeMemorySubsystem();
- inFinalize = 0;
alreadyFinalized:
TclFinalizeLock();
@@ -1220,7 +1278,7 @@ Tcl_FinalizeThread(void)
* initialized already.
*/
- tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ tsdPtr = TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
tsdPtr->inExit = 1;
@@ -1233,8 +1291,8 @@ Tcl_FinalizeThread(void)
*/
tsdPtr->firstExitPtr = exitPtr->nextPtr;
- (*exitPtr->proc)(exitPtr->clientData);
- ckfree((char *) exitPtr);
+ exitPtr->proc(exitPtr->clientData);
+ ckfree(exitPtr);
}
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
@@ -1274,7 +1332,7 @@ Tcl_FinalizeThread(void)
int
TclInExit(void)
{
- return inFinalize;
+ return inExit;
}
/*
@@ -1296,13 +1354,12 @@ TclInExit(void)
int
TclInThreadExit(void)
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+
if (tsdPtr == NULL) {
return 0;
- } else {
- return tsdPtr->inExit;
}
+ return tsdPtr->inExit;
}
/*
@@ -1328,48 +1385,61 @@ Tcl_VwaitObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int done, foundEvent;
- char *nameString;
+ const char *nameString;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
nameString = Tcl_GetString(objv[1]);
- if (Tcl_TraceVar(interp, nameString,
+ if (Tcl_TraceVar2(interp, nameString, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, (ClientData) &done) != TCL_OK) {
+ VwaitVarProc, &done) != TCL_OK) {
return TCL_ERROR;
};
done = 0;
foundEvent = 1;
while (!done && foundEvent) {
foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ break;
+ }
if (Tcl_LimitExceeded(interp)) {
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
break;
}
}
- Tcl_UntraceVar(interp, nameString,
+ Tcl_UntraceVar2(interp, nameString, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, (ClientData) &done);
+ VwaitVarProc, &done);
- /*
- * Clear out the interpreter's result, since it may have been set by event
- * handlers.
- */
-
- Tcl_ResetResult(interp);
if (!foundEvent) {
- Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
- "\": would wait forever", NULL);
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't wait for variable \"%s\": would wait forever",
+ nameString));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
return TCL_ERROR;
}
if (!done) {
- Tcl_AppendResult(interp, "limit exceeded", NULL);
+ /*
+ * The interpreter's result was already set to the right error message
+ * prior to exiting the loop above.
+ */
+
return TCL_ERROR;
}
+
+ /*
+ * Clear out the interpreter's result, since it may have been set by event
+ * handlers.
+ */
+
+ Tcl_ResetResult(interp);
return TCL_OK;
}
@@ -1378,11 +1448,11 @@ static char *
VwaitVarProc(
ClientData clientData, /* Pointer to integer to set to 1. */
Tcl_Interp *interp, /* Interpreter containing variable. */
- CONST char *name1, /* Name of variable. */
- CONST char *name2, /* Second part of variable name. */
+ const char *name1, /* Name of variable. */
+ const char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
- int *donePtr = (int *) clientData;
+ int *donePtr = clientData;
*donePtr = 1;
return NULL;
@@ -1411,12 +1481,12 @@ Tcl_UpdateObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int optionIndex;
int flags = 0; /* Initialized to avoid compiler warning. */
- static CONST char *updateOptions[] = {"idletasks", NULL};
- enum updateOptions {REGEXP_IDLETASKS};
+ static const char *const updateOptions[] = {"idletasks", NULL};
+ enum updateOptions {OPT_IDLETASKS};
if (objc == 1) {
flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
@@ -1426,7 +1496,7 @@ Tcl_UpdateObjCmd(
return TCL_ERROR;
}
switch ((enum updateOptions) optionIndex) {
- case REGEXP_IDLETASKS:
+ case OPT_IDLETASKS:
flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
break;
default:
@@ -1438,9 +1508,12 @@ Tcl_UpdateObjCmd(
}
while (Tcl_DoOneEvent(flags) != 0) {
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "limit exceeded", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
return TCL_ERROR;
}
}
@@ -1456,11 +1529,11 @@ Tcl_UpdateObjCmd(
#ifdef TCL_THREADS
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* NewThreadProc --
*
- * Bootstrap function of a new Tcl thread.
+ * Bootstrap function of a new Tcl thread.
*
* Results:
* None.
@@ -1468,23 +1541,22 @@ Tcl_UpdateObjCmd(
* Side Effects:
* Initializes Tcl notifier for the current thread.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static Tcl_ThreadCreateType
NewThreadProc(
ClientData clientData)
{
- ThreadClientData *cdPtr;
+ ThreadClientData *cdPtr = clientData;
ClientData threadClientData;
Tcl_ThreadCreateProc *threadProc;
- cdPtr = (ThreadClientData *) clientData;
threadProc = cdPtr->proc;
threadClientData = cdPtr->clientData;
- ckfree((char *) clientData); /* Allocated in Tcl_CreateThread() */
+ ckfree(clientData); /* Allocated in Tcl_CreateThread() */
- (*threadProc)(threadClientData);
+ threadProc(threadClientData);
TCL_THREAD_CREATE_RETURN;
}
@@ -1512,21 +1584,23 @@ NewThreadProc(
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
- Tcl_ThreadCreateProc proc, /* Main() function of the thread */
+ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
ClientData clientData, /* The one argument to Main() */
int stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
#ifdef TCL_THREADS
- ThreadClientData *cdPtr;
+ ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData));
+ int result;
- cdPtr = (ThreadClientData *) ckalloc(sizeof(ThreadClientData));
cdPtr->proc = proc;
cdPtr->clientData = clientData;
-
- return TclpThreadCreate(idPtr, NewThreadProc, (ClientData) cdPtr,
- stackSize, flags);
+ result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags);
+ if (result != TCL_OK) {
+ ckfree(cdPtr);
+ }
+ return result;
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
generated by cgit v0.12 at 2025-10-31 12:53:24 (GMT)