diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/regc_nfa.c | 80 | ||||
| -rw-r--r-- | generic/regcomp.c | 2 | ||||
| -rw-r--r-- | generic/tclCompile.c | 74 | ||||
| -rw-r--r-- | generic/tclExecute.c | 19 | ||||
| -rw-r--r-- | generic/tclIO.c | 116 | ||||
| -rw-r--r-- | generic/tclIO.h | 124 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 61 | ||||
| -rw-r--r-- | generic/tclUtil.c | 319 |
8 files changed, 535 insertions, 260 deletions
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 48f56a9..459968a 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -1139,6 +1139,7 @@ FILE *f; /* for debug output; NULL none */ { struct state *s; struct state *nexts; + struct state *to; struct arc *a; struct arc *nexta; int progress; @@ -1146,14 +1147,41 @@ FILE *f; /* for debug output; NULL none */ /* find and eliminate empties until there are no more */ do { progress = 0; - for (s = nfa->states; s != NULL && !NISERR() - && s->no != FREESTATE; s = nexts) { + for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { nexts = s->next; - for (a = s->outs; a != NULL && !NISERR(); a = nexta) { + for (a = s->outs; a != NULL && !NISERR(); + a = a->outchain) + if (a->type == EMPTY) + /* Mark a for deletion; copy arcs + * to preserve graph connectivity + * after it is gone. */ + unempty(nfa, a); + + /* Now pass through and delete the marked arcs. + * Doing all the deletion after all the marking + * prevents arc copying from resurrecting deleted + * arcs which can cause failure to converge. + * [Tcl Bug 3604074] */ + for (a = s->outs; a != NULL; a = nexta) { nexta = a->outchain; - if (a->type == EMPTY && unempty(nfa, a)) + if (a->from == NULL) { progress = 1; - assert(nexta == NULL || s->no != FREESTATE); + to = a->to; + a->from = s; + freearc(nfa, a); + if (to->nins == 0) { + while ((a = to->outs)) + freearc(nfa, a); + if (nexts == to) + nexts = to->next; + freestate(nfa, to); + } + if (s->nouts == 0) { + while ((a = s->ins)) + freearc(nfa, a); + freestate(nfa, s); + } + } } } if (progress && f != NULL) @@ -1174,7 +1202,6 @@ struct arc *a; { struct state *from = a->from; struct state *to = a->to; - int usefrom; /* work on from, as opposed to to? */ assert(a->type == EMPTY); assert(from != nfa->pre && to != nfa->post); @@ -1184,33 +1211,26 @@ struct arc *a; return 1; } - /* decide which end to work on */ - usefrom = 1; /* default: attack from */ - if (from->nouts > to->nins) - usefrom = 0; - else if (from->nouts == to->nins) { - /* decide on secondary issue: move/copy fewest arcs */ - if (from->nins > to->nouts) - usefrom = 0; + /* Mark arc for deletion */ + a->from = NULL; + + if (from->nouts > to->nins) { + copyouts(nfa, to, from); + return 1; } - - freearc(nfa, a); - if (usefrom) { - if (from->nouts == 0) { - /* was the state's only outarc */ - moveins(nfa, from, to); - freestate(nfa, from); - } else - copyins(nfa, from, to); - } else { - if (to->nins == 0) { - /* was the state's only inarc */ - moveouts(nfa, to, from); - freestate(nfa, to); - } else - copyouts(nfa, to, from); + if (from->nouts < to->nins) { + copyins(nfa, from, to); + return 1; + } + + /* from->nouts == to->nins */ + /* decide on secondary issue: move/copy fewest arcs */ + if (from->nins > to->nouts) { + copyouts(nfa, to, from); + return 1; } + copyins(nfa, from, to); return 1; } diff --git a/generic/regcomp.c b/generic/regcomp.c index a1fe5bc..307877a 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -675,6 +675,7 @@ int partial; /* is this only part of a branch? */ /* NB, recursion in parseqatom() may swallow rest of branch */ parseqatom(v, stopper, type, lp, right, t); + NOERRN(); } if (!seencontent) { /* empty branch */ @@ -1084,6 +1085,7 @@ struct subre *top; /* subtree top */ EMPTYARC(atom->end, rp); t->right = subre(v, '=', 0, atom->end, rp); } + NOERR(); assert(SEE('|') || SEE(stopper) || SEE(EOS)); t->flags |= COMBINE(t->flags, t->right->flags); top->flags |= COMBINE(top->flags, t->flags); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1ec7c58..41ee45b 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -361,9 +361,6 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) CompileEnv compEnv; /* Compilation environment structure * allocated in frame. */ LiteralTable *localTablePtr = &(compEnv.localLitTable); - register AuxData *auxDataPtr; - LiteralEntry *entryPtr; - register int i; int length, nested, result; char *string; #ifdef TCL_TIP280 @@ -443,38 +440,16 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ - TclInitByteCodeObj(objPtr, &compEnv); + if (result == TCL_OK) { + TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - } -#endif /* TCL_COMPILE_DEBUG */ - } - - if (result != TCL_OK) { - /* - * Compilation errors. - */ - - entryPtr = compEnv.literalArrayPtr; - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, entryPtr->objPtr); - entryPtr++; - } -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable(iPtr); -#endif /*TCL_COMPILE_DEBUG*/ - - auxDataPtr = compEnv.auxDataArrayPtr; - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); } - auxDataPtr++; +#endif /* TCL_COMPILE_DEBUG */ } } - - + /* * Free storage allocated during compilation. */ @@ -947,6 +922,32 @@ void TclFreeCompileEnv(envPtr) register CompileEnv *envPtr; /* Points to the CompileEnv structure. */ { + if (envPtr->iPtr) { + /* + * We never converted to Bytecode, so free the things we would + * have transferred to it. + */ + + int i; + LiteralEntry *entryPtr = envPtr->literalArrayPtr; + AuxData *auxDataPtr = envPtr->auxDataArrayPtr; + + for (i = 0; i < envPtr->literalArrayNext; i++) { + TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr); + entryPtr++; + } + +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(envPtr->iPtr); +#endif /*TCL_COMPILE_DEBUG*/ + + for (i = 0; i < envPtr->auxDataArrayNext; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + } if (envPtr->mallocedCodeArray) { ckfree((char *) envPtr->codeStart); } @@ -1088,6 +1089,10 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) int* clNext; #endif + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); + } + Tcl_DStringInit(&ds); if (numBytes < 0) { @@ -1991,6 +1996,10 @@ TclInitByteCodeObj(objPtr, envPtr) #endif Interp *iPtr; + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclInitByteCodeObj() called on uninitialized CompileEnv"); + } + iPtr = envPtr->iPtr; codeBytes = (envPtr->codeNext - envPtr->codeStart); @@ -2110,6 +2119,9 @@ TclInitByteCodeObj(objPtr, envPtr) envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; #endif + + /* We've used up the CompileEnv. Mark as uninitialized. */ + envPtr->iPtr = NULL; } /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c09b73e..1ae182c 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -724,11 +724,9 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) register ByteCode *codePtr = NULL; /* Tcl Internal type of bytecode. * Initialized to avoid compiler warning. */ - AuxData *auxDataPtr; - LiteralEntry *entryPtr; Tcl_Obj *saveObjPtr; char *string; - int length, i, result; + int length, result; /* * First handle some common expressions specially. @@ -808,22 +806,7 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ - entryPtr = compEnv.literalArrayPtr; - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, entryPtr->objPtr); - entryPtr++; - } -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable(iPtr); -#endif /*TCL_COMPILE_DEBUG*/ - auxDataPtr = compEnv.auxDataArrayPtr; - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; - } TclFreeCompileEnv(&compEnv); goto done; } diff --git a/generic/tclIO.c b/generic/tclIO.c index eace472..c18d02e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -22,6 +22,108 @@ /* + * For each channel handler registered in a call to Tcl_CreateChannelHandler, + * there is one record of the following type. All of records for a specific + * channel are chained together in a singly linked list which is stored in + * the channel structure. + */ + +typedef struct ChannelHandler { + Channel *chanPtr; /* The channel structure for this channel. */ + int mask; /* Mask of desired events. */ + Tcl_ChannelProc *proc; /* Procedure to call in the type of + * Tcl_CreateChannelHandler. */ + ClientData clientData; /* Argument to pass to procedure. */ + struct ChannelHandler *nextPtr; + /* Next one in list of registered handlers. */ +} ChannelHandler; + +/* + * This structure keeps track of the current ChannelHandler being invoked in + * the current invocation of ChannelHandlerEventProc. There is a potential + * problem if a ChannelHandler is deleted while it is the current one, since + * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this + * problem, structures of the type below indicate the next handler to be + * processed for any (recursively nested) dispatches in progress. The + * nextHandlerPtr field is updated if the handler being pointed to is deleted. + * The nextPtr field is used to chain together all recursive invocations, so + * that Tcl_DeleteChannelHandler can find all the recursively nested + * invocations of ChannelHandlerEventProc and compare the handler being + * deleted against the NEXT handler to be invoked in that invocation; when it + * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr + * field of the structure to the next handler. + */ + +typedef struct NextChannelHandler { + ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in + * this invocation. */ + struct NextChannelHandler *nestedHandlerPtr; + /* Next nested invocation of + * ChannelHandlerEventProc. */ +} NextChannelHandler; + +/* + * The following structure describes the event that is added to the Tcl + * event queue by the channel handler check procedure. + */ + +typedef struct ChannelHandlerEvent { + Tcl_Event header; /* Standard header for all events. */ + Channel *chanPtr; /* The channel that is ready. */ + int readyMask; /* Events that have occurred. */ +} ChannelHandlerEvent; + +/* + * The following structure is used by Tcl_GetsObj() to encapsulates the + * state for a "gets" operation. + */ + +typedef struct GetsState { + Tcl_Obj *objPtr; /* The object to which UTF-8 characters + * will be appended. */ + char **dstPtr; /* Pointer into objPtr's string rep where + * next character should be stored. */ + Tcl_Encoding encoding; /* The encoding to use to convert raw bytes + * to UTF-8. */ + ChannelBuffer *bufPtr; /* The current buffer of raw bytes being + * emptied. */ + Tcl_EncodingState state; /* The encoding state just before the last + * external to UTF-8 conversion in + * FilterInputBytes(). */ + int rawRead; /* The number of bytes removed from bufPtr + * in the last call to FilterInputBytes(). */ + int bytesWrote; /* The number of bytes of UTF-8 data + * appended to objPtr during the last call to + * FilterInputBytes(). */ + int charsWrote; /* The corresponding number of UTF-8 + * characters appended to objPtr during the + * last call to FilterInputBytes(). */ + int totalChars; /* The total number of UTF-8 characters + * appended to objPtr so far, just before the + * last call to FilterInputBytes(). */ +} GetsState; + +/* + * The following structure encapsulates the state for a background channel + * copy. Note that the data buffer for the copy will be appended to this + * structure. + */ + +typedef struct CopyState { + struct Channel *readPtr; /* Pointer to input channel. */ + struct Channel *writePtr; /* Pointer to output channel. */ + int readFlags; /* Original read channel flags. */ + int writeFlags; /* Original write channel flags. */ + int toRead; /* Number of bytes to copy, or -1. */ + int total; /* Total bytes transferred (written). */ + Tcl_Interp *interp; /* Interp that started the copy. */ + Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */ + int bufSize; /* Size of appended buffer. */ + char buffer[1]; /* Copy buffer, this must be the last + * field. */ +} CopyState; + +/* * All static variables used in this file are collected into a single * instance of the following structure. For multi-threaded implementations, * there is one instance of this structure for each thread. @@ -70,6 +172,18 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; /* + * Structure to record a close callback. One such record exists for + * each close callback registered for a channel. + */ + +typedef struct CloseCallback { + Tcl_CloseProc *proc; /* The procedure to call. */ + ClientData clientData; /* Arbitrary one-word data to pass + * to the callback. */ + struct CloseCallback *nextPtr; /* For chaining close callbacks. */ +} CloseCallback; + +/* * Static functions in this file: */ @@ -504,6 +618,8 @@ Tcl_DeleteCloseHandler(chan, proc, clientData) if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) { if (cbPrevPtr == (CloseCallback *) NULL) { statePtr->closeCbPtr = cbPtr->nextPtr; + } else { + cbPrevPtr->nextPtr = cbPtr->nextPtr; } ckfree((char *) cbPtr); break; diff --git a/generic/tclIO.h b/generic/tclIO.h index e9f6151..ec34372 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -30,26 +30,6 @@ error one of EWOULDBLOCK or EAGAIN must be defined #endif /* - * The following structure encapsulates the state for a background channel - * copy. Note that the data buffer for the copy will be appended to this - * structure. - */ - -typedef struct CopyState { - struct Channel *readPtr; /* Pointer to input channel. */ - struct Channel *writePtr; /* Pointer to output channel. */ - int readFlags; /* Original read channel flags. */ - int writeFlags; /* Original write channel flags. */ - int toRead; /* Number of bytes to copy, or -1. */ - int total; /* Total bytes transferred (written). */ - Tcl_Interp *interp; /* Interp that started the copy. */ - Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */ - int bufSize; /* Size of appended buffer. */ - char buffer[1]; /* Copy buffer, this must be the last - * field. */ -} CopyState; - -/* * struct ChannelBuffer: * * Buffers data being sent to or from a channel. @@ -86,18 +66,6 @@ typedef struct ChannelBuffer { #define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4) /* - * Structure to record a close callback. One such record exists for - * each close callback registered for a channel. - */ - -typedef struct CloseCallback { - Tcl_CloseProc *proc; /* The procedure to call. */ - ClientData clientData; /* Arbitrary one-word data to pass - * to the callback. */ - struct CloseCallback *nextPtr; /* For chaining close callbacks. */ -} CloseCallback; - -/* * The following structure describes the information saved from a call to * "fileevent". This is used later when the event being waited for to * invoke the saved script in the interpreter designed in this record. @@ -197,7 +165,8 @@ typedef struct ChannelState { int refCount; /* How many interpreters hold references to * this IO channel? */ - CloseCallback *closeCbPtr; /* Callbacks registered to be called when the + struct CloseCallback *closeCbPtr; + /* Callbacks registered to be called when the * channel is closed. */ char *outputStage; /* Temporary staging buffer used when * translating EOL before converting from @@ -223,8 +192,10 @@ typedef struct ChannelState { int bufSize; /* What size buffers to allocate? */ Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */ - CopyState *csPtrR; /* State of background copy for which channel is input, or NULL. */ - CopyState *csPtrW; /* State of background copy for which channel is output, or NULL. */ + struct CopyState *csPtrR; /* State of background copy for which channel + * is input, or NULL. */ + struct CopyState *csPtrW; /* State of background copy for which channel + * is output, or NULL. */ Channel *topChanPtr; /* Refers to topmost channel in a stack. * Never NULL. */ Channel *bottomChanPtr; /* Refers to bottommost channel in a stack. @@ -331,86 +302,3 @@ typedef struct ChannelState { * it may not be closed again * from within the close handler. */ - -/* - * For each channel handler registered in a call to Tcl_CreateChannelHandler, - * there is one record of the following type. All of records for a specific - * channel are chained together in a singly linked list which is stored in - * the channel structure. - */ - -typedef struct ChannelHandler { - Channel *chanPtr; /* The channel structure for this channel. */ - int mask; /* Mask of desired events. */ - Tcl_ChannelProc *proc; /* Procedure to call in the type of - * Tcl_CreateChannelHandler. */ - ClientData clientData; /* Argument to pass to procedure. */ - struct ChannelHandler *nextPtr; - /* Next one in list of registered handlers. */ -} ChannelHandler; - -/* - * This structure keeps track of the current ChannelHandler being invoked in - * the current invocation of ChannelHandlerEventProc. There is a potential - * problem if a ChannelHandler is deleted while it is the current one, since - * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this - * problem, structures of the type below indicate the next handler to be - * processed for any (recursively nested) dispatches in progress. The - * nextHandlerPtr field is updated if the handler being pointed to is deleted. - * The nextPtr field is used to chain together all recursive invocations, so - * that Tcl_DeleteChannelHandler can find all the recursively nested - * invocations of ChannelHandlerEventProc and compare the handler being - * deleted against the NEXT handler to be invoked in that invocation; when it - * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr - * field of the structure to the next handler. - */ - -typedef struct NextChannelHandler { - ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in - * this invocation. */ - struct NextChannelHandler *nestedHandlerPtr; - /* Next nested invocation of - * ChannelHandlerEventProc. */ -} NextChannelHandler; - - -/* - * The following structure describes the event that is added to the Tcl - * event queue by the channel handler check procedure. - */ - -typedef struct ChannelHandlerEvent { - Tcl_Event header; /* Standard header for all events. */ - Channel *chanPtr; /* The channel that is ready. */ - int readyMask; /* Events that have occurred. */ -} ChannelHandlerEvent; - -/* - * The following structure is used by Tcl_GetsObj() to encapsulates the - * state for a "gets" operation. - */ - -typedef struct GetsState { - Tcl_Obj *objPtr; /* The object to which UTF-8 characters - * will be appended. */ - char **dstPtr; /* Pointer into objPtr's string rep where - * next character should be stored. */ - Tcl_Encoding encoding; /* The encoding to use to convert raw bytes - * to UTF-8. */ - ChannelBuffer *bufPtr; /* The current buffer of raw bytes being - * emptied. */ - Tcl_EncodingState state; /* The encoding state just before the last - * external to UTF-8 conversion in - * FilterInputBytes(). */ - int rawRead; /* The number of bytes removed from bufPtr - * in the last call to FilterInputBytes(). */ - int bytesWrote; /* The number of bytes of UTF-8 data - * appended to objPtr during the last call to - * FilterInputBytes(). */ - int charsWrote; /* The corresponding number of UTF-8 - * characters appended to objPtr during the - * last call to FilterInputBytes(). */ - int totalChars; /* The total number of UTF-8 characters - * appended to objPtr so far, just before the - * last call to FilterInputBytes(). */ -} GetsState; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 77352a1..be7c4cd 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -454,8 +454,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) * Find the parent for the new namespace. */ - TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, - /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), + TclGetNamespaceForQualName(interp, name, NULL, CREATE_NS_IF_UNKNOWN, &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); /* @@ -930,8 +929,7 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) * Check that the pattern doesn't have namespace qualifiers. */ - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { @@ -1032,7 +1030,7 @@ Tcl_AppendExportList(interp, namespacePtr, objPtr) */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } @@ -1158,8 +1156,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) "empty import pattern", -1); return TCL_ERROR; } - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { @@ -1363,8 +1360,7 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) * and the simple pattern. */ - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { @@ -3131,10 +3127,7 @@ NamespaceExportCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp); - char *pattern, *string; - int resetListFirst = 0; - int firstArg, patternCt, i, result; + int firstArg, i; if (objc < 2) { Tcl_WrongNumArgs(interp, 2, objv, @@ -3143,37 +3136,27 @@ NamespaceExportCmd(dummy, interp, objc, objv) } /* - * Process the optional "-clear" argument. + * If no pattern arguments are given, and "-clear" isn't specified, + * return the namespace's current export pattern list. */ - firstArg = 2; - if (firstArg < objc) { - string = Tcl_GetString(objv[firstArg]); - if (strcmp(string, "-clear") == 0) { - resetListFirst = 1; - firstArg++; - } + if (objc == 2) { + Tcl_Obj *listPtr = Tcl_NewObj(); + + (void) Tcl_AppendExportList(interp, NULL, listPtr); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; } /* - * If no pattern arguments are given, and "-clear" isn't specified, - * return the namespace's current export pattern list. + * Process the optional "-clear" argument. */ - patternCt = (objc - firstArg); - if (patternCt == 0) { - if (firstArg > 2) { - return TCL_OK; - } else { /* create list with export patterns */ - Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - result = Tcl_AppendExportList(interp, - (Tcl_Namespace *) currNsPtr, listPtr); - if (result != TCL_OK) { - return result; - } - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; - } + firstArg = 2; + if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { + Tcl_Export(interp, NULL, "::", 1); + Tcl_ResetResult(interp); + firstArg++; } /* @@ -3181,9 +3164,7 @@ NamespaceExportCmd(dummy, interp, objc, objv) */ for (i = firstArg; i < objc; i++) { - pattern = Tcl_GetString(objv[i]); - result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, - ((i == firstArg)? resetListFirst : 0)); + int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0); if (result != TCL_OK) { return result; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index b327b99..7d455af 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -47,27 +47,59 @@ char *tclNativeExecutableName = NULL; #define BRACES_UNMATCHED 4 /* + * Data structures for process-global values. + */ + +typedef void (InitPGVProc) _ANSI_ARGS_ ((char **valuePtr, int *lengthPtr)); + +/* + * A ProcessGlobalValue struct exists for each internal value in Tcl that is + * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of + * the value, and the master is kept as a counted string, with epoch and mutex + * control. Each ProcessGlobalValue struct should be a static variable in some + * file. + */ + +typedef struct ProcessGlobalValue { + int epoch; /* Epoch counter to detect changes in the + * master value. */ + int numBytes; /* Length of the master string. */ + char *value; /* The master string value. */ + InitPGVProc *proc; /* A procedure to initialize the master string + * copy when a "get" request comes in before + * any "set" request has been received. */ + Tcl_Mutex mutex; /* Enforce orderly access from multiple + * threads. */ + Tcl_ThreadDataKey key; /* Key for per-thread data holding the + * (Tcl_Obj) copy for each thread. */ +} PGV; + +/* * The following values determine the precision used when converting * floating-point values to strings. This information is linked to all * of the tcl_precision variables in all interpreters via the procedure * TclPrecTraceProc. */ -static char precisionString[10] = "12"; - /* The string value of all the tcl_precision - * variables. */ -static char precisionFormat[10] = "%.12g"; - /* The format string actually used in calls - * to sprintf. */ -TCL_DECLARE_MUTEX(precisionMutex) +static InitPGVProc InitPrecision; +static PGV precision = { + 0, 0, NULL, InitPrecision, NULL, NULL +}; /* * Prototypes for procedures defined later in this file. */ +static void ClearHash _ANSI_ARGS_((Tcl_HashTable *tablePtr)); +static void FreePGV _ANSI_ARGS_((ClientData clientData)); +static void FreeThreadHash _ANSI_ARGS_((ClientData clientData)); +static Tcl_HashTable * GetThreadHash _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr)); static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* objPtr)); +static void SetPGV _ANSI_ARGS_((PGV *pgvPtr, Tcl_Obj *newValue)); +static Tcl_Obj * GetPGV _ANSI_ARGS_((PGV *pgvPtr)); /* * The following is the Tcl object type definition for an object @@ -1874,6 +1906,32 @@ Tcl_DStringEndSublist(dsPtr) /* *---------------------------------------------------------------------- * + * InitPrecision -- + * + * Set the default value for tcl_precision to 12. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +InitPrecision(valuePtr, lengthPtr) + char **valuePtr; + int *lengthPtr; +{ + *lengthPtr = 2; + *valuePtr = ckalloc(3); + memcpy(*valuePtr, "12", 3); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_PrintDouble -- * * Given a floating-point value, this procedure converts it to @@ -1902,11 +1960,12 @@ Tcl_PrintDouble(interp, value, dst) * characters. */ { char *p, c; + char format[10]; Tcl_UniChar ch; + Tcl_Obj *precisionObj = GetPGV(&precision); - Tcl_MutexLock(&precisionMutex); - sprintf(dst, precisionFormat, value); - Tcl_MutexUnlock(&precisionMutex); + sprintf(format, "%%.%sg", Tcl_GetString(precisionObj)); + sprintf(dst, format, value); /* * If the ASCII result looks like an integer, add ".0" so that it @@ -1984,12 +2043,9 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) * out of date. */ - Tcl_MutexLock(&precisionMutex); - if (flags & TCL_TRACE_READS) { - Tcl_SetVar2(interp, name1, name2, precisionString, + Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision), flags & TCL_GLOBAL_ONLY); - Tcl_MutexUnlock(&precisionMutex); return (char *) NULL; } @@ -2001,9 +2057,8 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) */ if (Tcl_IsSafe(interp)) { - Tcl_SetVar2(interp, name1, name2, precisionString, + Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision), flags & TCL_GLOBAL_ONLY); - Tcl_MutexUnlock(&precisionMutex); return "can't modify precision from a safe interpreter"; } value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); @@ -2011,16 +2066,13 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) value = ""; } prec = strtoul(value, &end, 10); - if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || - (end == value) || (*end != 0)) { - Tcl_SetVar2(interp, name1, name2, precisionString, + if ((prec <= 0) || (prec > TCL_MAX_PREC) + || (end == value) || (*end != 0)) { + Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision), flags & TCL_GLOBAL_ONLY); - Tcl_MutexUnlock(&precisionMutex); return "improper value for precision"; } - TclFormatInt(precisionString, prec); - sprintf(precisionFormat, "%%.%dg", prec); - Tcl_MutexUnlock(&precisionMutex); + SetPGV(&precision, Tcl_NewIntObj(prec)); return (char *) NULL; } @@ -2522,6 +2574,227 @@ TclCheckBadOctal(interp, value) /* *---------------------------------------------------------------------- * + * ClearHash -- + * + * Remove all the entries in the hash table *tablePtr. + * + *---------------------------------------------------------------------- + */ + +static void +ClearHash(tablePtr) + Tcl_HashTable *tablePtr; +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(objPtr); + Tcl_DeleteHashEntry(hPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * GetThreadHash -- + * + * Get a thread-specific (Tcl_HashTable *) associated with a thread data + * key. + * + * Results: + * The Tcl_HashTable * corresponding to *keyPtr. + * + * Side effects: + * The first call on a keyPtr in each thread creates a new Tcl_HashTable, + * and registers a thread exit handler to dispose of it. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashTable * +GetThreadHash(keyPtr) + Tcl_ThreadDataKey *keyPtr; +{ + Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **) + Tcl_GetThreadData(keyPtr, (int) sizeof(Tcl_HashTable *)); + + if (NULL == *tablePtrPtr) { + *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr); + Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); + } + return *tablePtrPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeThreadHash -- + * + * Thread exit handler used by GetThreadHash to dispose of a thread hash + * table. + * + * Side effects: + * Frees a Tcl_HashTable. + * + *---------------------------------------------------------------------- + */ + +static void +FreeThreadHash(clientData) + ClientData clientData; +{ + Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; + + ClearHash(tablePtr); + Tcl_DeleteHashTable(tablePtr); + ckfree((char *) tablePtr); +} + +/* + *---------------------------------------------------------------------- + * + * FreePGV -- + * + * Exit handler used by (Set|Get)PGV to cleanup a PGV at exit. + * + *---------------------------------------------------------------------- + */ + +static void +FreePGV(clientData) + ClientData clientData; +{ + PGV *pgvPtr = (PGV *) clientData; + + pgvPtr->epoch++; + pgvPtr->numBytes = 0; + ckfree(pgvPtr->value); + pgvPtr->value = NULL; + Tcl_MutexFinalize(&pgvPtr->mutex); +} + +/* + *---------------------------------------------------------------------- + * + * SetPGV -- + * + * Utility routine to set a global value shared by all threads in the + * process while keeping a thread-local copy as well. + * + *---------------------------------------------------------------------- + */ + +static void +SetPGV(pgvPtr, newValue) + PGV *pgvPtr; + Tcl_Obj *newValue; +{ + CONST char *bytes; + Tcl_HashTable *cacheMap; + Tcl_HashEntry *hPtr; + int dummy; + + Tcl_MutexLock(&pgvPtr->mutex); + + /* + * Fill the global string value. + */ + + pgvPtr->epoch++; + if (NULL != pgvPtr->value) { + ckfree(pgvPtr->value); + } else { + Tcl_CreateExitHandler(FreePGV, (ClientData) pgvPtr); + } + bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); + pgvPtr->value = ckalloc((unsigned) pgvPtr->numBytes + 1); + memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); + + /* + * Fill the local thread copy directly with the Tcl_Obj value to avoid + * loss of the intrep. Increment newValue refCount early to handle case + * where we set a PGV to itself. + */ + + Tcl_IncrRefCount(newValue); + cacheMap = GetThreadHash(&pgvPtr->key); + ClearHash(cacheMap); + hPtr = Tcl_CreateHashEntry(cacheMap, (char *) pgvPtr->epoch, &dummy); + Tcl_SetHashValue(hPtr, (ClientData) newValue); + Tcl_MutexUnlock(&pgvPtr->mutex); +} + +/* + *---------------------------------------------------------------------- + * + * GetPGV -- + * + * Retrieve a global value shared among all threads of the process, + * preferring a thread-local copy as long as it remains valid. + * + * Results: + * Returns a (Tcl_Obj *) that holds a copy of the global value. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +GetPGV(pgvPtr) + PGV *pgvPtr; +{ + Tcl_Obj *value = NULL; + Tcl_HashTable *cacheMap; + Tcl_HashEntry *hPtr; + int epoch = pgvPtr->epoch; + + cacheMap = GetThreadHash(&pgvPtr->key); + hPtr = Tcl_FindHashEntry(cacheMap, (char *) epoch); + if (NULL == hPtr) { + int dummy; + + /* + * No cache for the current epoch - must be a new one. + * + * First, clear the cacheMap, as anything in it must refer to some + * expired epoch. + */ + + ClearHash(cacheMap); + + /* + * If no thread has set the shared value, call the initializer. + */ + + Tcl_MutexLock(&pgvPtr->mutex); + if ((NULL == pgvPtr->value) && (pgvPtr->proc)) { + pgvPtr->epoch++; + (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes); + if (pgvPtr->value == NULL) { + Tcl_Panic("PGV Initializer did not initialize"); + } + Tcl_CreateExitHandler(FreePGV, (ClientData) pgvPtr); + } + + /* + * Store a copy of the shared value in our epoch-indexed cache. + */ + + value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); + hPtr = Tcl_CreateHashEntry(cacheMap, (char *) pgvPtr->epoch, &dummy); + Tcl_MutexUnlock(&pgvPtr->mutex); + Tcl_SetHashValue(hPtr, (ClientData) value); + Tcl_IncrRefCount(value); + } + return (Tcl_Obj *) Tcl_GetHashValue(hPtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetNameOfExecutable -- * * This procedure simply returns a pointer to the internal full |