From eadf07dc2cd9a4faad580c36e2d7112f002bd033 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 25 Jun 2007 18:53:28 +0000 Subject: merge updates from HEAD --- ChangeLog | 55 ++++++++ generic/tclBasic.c | 252 ++++++++++++++++++------------------ generic/tclCmdIL.c | 8 +- generic/tclCompExpr.c | 173 ++++++++++++++----------- generic/tclCompile.c | 66 +++++----- generic/tclExecute.c | 47 +++++-- generic/tclInt.h | 4 +- generic/tclNamesp.c | 44 +------ generic/tclParse.c | 154 +++++++++++----------- generic/tclScan.c | 33 ++--- generic/tclVar.c | 330 ++++++++++++++++++----------------------------- macosx/tclMacOSXNotify.c | 25 +++- tests/trace.test | 4 +- 13 files changed, 607 insertions(+), 588 deletions(-) diff --git a/ChangeLog b/ChangeLog index fa61db0..7999a93 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,58 @@ +2007-06-25 Miguel Sofer + + * generic/tclVar.c (UnsetVarStruct): fixing incomplete change, + more streamlining. + +2007-06-24 Miguel Sofer + + * generic/tclVar.c (TclDeleteCompiledLocalVars): removed inlining + that ended up not really optimising (limited benchmarks). Now + calling UnsetVarStruct (streamlined old code is #ifdef'ed out, in + case better benchmarks do show a difference). + + * generic/tclVar.c (UnsetVarStruct): fixed a leak introduced in + last commit. + +2007-06-23 Miguel Sofer + + * generic/tclVar.c (UnsetVarStruct, TclDeleteVars): made the logic + slightly clearer, eliminated some duplicated code. + + *** POTENTIAL INCOMPATIBILITY *** (tclInt.h and Var struct users) + The core never builds VAR_LINK variable to have traces. Such a + "monster", should one exist, will now have its unset traces called + *before* it is unlinked. + +2007-06-23 Daniel Steffen + + * macosx/tclMacOSXNotify.c (AtForkChild): don't call CoreFoundation + APIs after fork() on systems where that would lead to an abort(). + +2007-06-22 Don Porter + + * generic/tclExecute.c: Revised TclStackRealloc() signature to better + * generic/tclInt.h: parallel (and fall back on) Tcl_Realloc. + + * generic/tclNamesp.c (TclResetShadowesCmdRefs): Replaced + ckrealloc based allocations with TclStackRealloc allocations. + + * generic/tclCmdIL.c: More conversions to use TclStackAlloc. + * generic/tclScan.c: + +2007-06-21 Don Porter + + * generic/tclBasic.c: Move most instances of the Tcl_Parse struct + * generic/tclCompExpr.c: off the C stack and onto the Tcl stack. + * generic/tclCompile.c: This is a rather large struct (> 3kB). + * generic/tclParse.c: + +2007-06-21 Miguel Sofer + + * generic/tclBasic.c (TEOvI): Made sure that leave + * generic/tclExecute.c (INST_INVOKE): traces that were created + * tests/trace.test (trace-36.2): during execution of an + originally untraced command do not fire [Bug 1740962], partial fix. + 2007-06-21 Donal K. Fellows * generic/tcl.h, generic/tclCompile.h, generic/tclCompile.c: Remove diff --git a/generic/tclBasic.c b/generic/tclBasic.c index dcfeef0..f20b05d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.244.2.6 2007/06/21 16:04:54 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.244.2.7 2007/06/25 18:53:29 dgp Exp $ */ #include "tclInt.h" @@ -3428,7 +3428,7 @@ TclEvalObjvInternal( CallFrame *varFramePtr = iPtr->varFramePtr; int code = TCL_OK; int traceCode = TCL_OK; - int checkTraces = 1; + int checkTraces = 1, traced; Namespace *savedNsPtr = NULL; Namespace *lookupNsPtr = iPtr->lookupNsPtr; @@ -3478,99 +3478,26 @@ TclEvalObjvInternal( */ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if (cmdPtr == NULL) { - Namespace *currNsPtr = NULL; /* Used to check for and invoke any - * registered unknown command handler - * for the current namespace - * (TIP 181). */ - int newObjc, handlerObjc; - Tcl_Obj **handlerObjv; - - currNsPtr = varFramePtr->nsPtr; - if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) { - currNsPtr = iPtr->globalNsPtr; - if (currNsPtr == NULL) { - Tcl_Panic("TclEvalObjvInternal: NULL global namespace pointer"); - } - } - - /* - * Check to see if the resolution namespace has lost its unknown - * handler. If so, reset it to "::unknown". - */ - - if (currNsPtr->unknownHandlerPtr == NULL) { - TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); - Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); - } - - /* - * Get the list of words for the unknown handler and allocate enough - * space to hold both the handler prefix and all words of the command - * invokation itself. - */ - - Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, - &handlerObjc, &handlerObjv); - newObjc = objc + handlerObjc; - newObjv = (Tcl_Obj **) TclStackAlloc(interp, - (int) sizeof(Tcl_Obj *) * newObjc); - - /* - * Copy command prefix from unknown handler and add on the real - * command's full argument list. Note that we only use memcpy() once - * because we have to increment the reference count of all the handler - * arguments anyway. - */ - - for (i = 0; i < handlerObjc; ++i) { - newObjv[i] = handlerObjv[i]; - Tcl_IncrRefCount(newObjv[i]); - } - memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); - - /* - * Look up and invoke the handler (by recursive call to this - * function). If there is no handler at all, instead of doing the - * recursive call we just generate a generic error message; it would - * be an infinite-recursion nightmare otherwise. - */ - - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); - if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[0]), "\"", NULL); - code = TCL_ERROR; - } else { - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, newObjc, newObjv, command, - length, 0); - iPtr->numLevels--; - } - - /* - * Release any resources we locked and allocated during the handler - * call. - */ - - for (i = 0; i < handlerObjc; ++i) { - Tcl_DecrRefCount(newObjv[i]); - } - TclStackFree(interp, newObjv); - if (savedNsPtr) { - varFramePtr->nsPtr = savedNsPtr; - } - goto done; + if (!cmdPtr) { + goto notFound; } + if (savedNsPtr) { varFramePtr->nsPtr = savedNsPtr; + } else if (iPtr->ensembleRewrite.sourceObjs) { + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ + + iPtr->ensembleRewrite.sourceObjs = NULL; } /* * Call trace functions if needed. */ - if (checkTraces && ((iPtr->tracePtr != NULL) || (cmdPtr->flags & CMD_HAS_EXEC_TRACES))) { + traced = (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)); + if (traced && checkTraces) { int cmdEpoch = cmdPtr->cmdEpoch; int newEpoch; @@ -3581,7 +3508,7 @@ TclEvalObjvInternal( */ cmdPtr->refCount++; - if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + if (iPtr->tracePtr && (traceCode == TCL_OK)) { traceCode = TclCheckInterpTraces(interp, command, length, cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); } @@ -3613,10 +3540,6 @@ TclEvalObjvInternal( cmdPtr->refCount++; iPtr->cmdCount++; if (code == TCL_OK && traceCode == TCL_OK && !TclLimitExceeded(iPtr->limit)) { - if (!(flags & TCL_EVAL_INVOKE) && - (iPtr->ensembleRewrite.sourceObjs != NULL)) { - iPtr->ensembleRewrite.sourceObjs = NULL; - } code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); } if (Tcl_AsyncReady()) { @@ -3630,7 +3553,7 @@ TclEvalObjvInternal( * Call 'leave' command traces */ - if (((iPtr->tracePtr != NULL) || (cmdPtr->flags & CMD_HAS_EXEC_TRACES))) { + if (traced) { if (!(cmdPtr->flags & CMD_IS_DELETED)) { if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { traceCode = TclCheckExecutionTraces(interp, command, length, @@ -3651,7 +3574,6 @@ TclEvalObjvInternal( if (traceCode != TCL_OK) { code = traceCode; } - } /* @@ -3677,6 +3599,92 @@ TclEvalObjvInternal( iPtr->varFramePtr = savedVarFramePtr; } return code; + + notFound: + { + Namespace *currNsPtr = NULL; /* Used to check for and invoke any + * registered unknown command handler + * for the current namespace + * (TIP 181). */ + int newObjc, handlerObjc; + Tcl_Obj **handlerObjv; + + currNsPtr = varFramePtr->nsPtr; + if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) { + currNsPtr = iPtr->globalNsPtr; + if (currNsPtr == NULL) { + Tcl_Panic("TclEvalObjvInternal: NULL global namespace pointer"); + } + } + + /* + * Check to see if the resolution namespace has lost its unknown + * handler. If so, reset it to "::unknown". + */ + + if (currNsPtr->unknownHandlerPtr == NULL) { + TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); + Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); + } + + /* + * Get the list of words for the unknown handler and allocate enough + * space to hold both the handler prefix and all words of the command + * invokation itself. + */ + + Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, + &handlerObjc, &handlerObjv); + newObjc = objc + handlerObjc; + newObjv = (Tcl_Obj **) TclStackAlloc(interp, + (int) sizeof(Tcl_Obj *) * newObjc); + + /* + * Copy command prefix from unknown handler and add on the real + * command's full argument list. Note that we only use memcpy() once + * because we have to increment the reference count of all the handler + * arguments anyway. + */ + + for (i = 0; i < handlerObjc; ++i) { + newObjv[i] = handlerObjv[i]; + Tcl_IncrRefCount(newObjv[i]); + } + memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); + + /* + * Look up and invoke the handler (by recursive call to this + * function). If there is no handler at all, instead of doing the + * recursive call we just generate a generic error message; it would + * be an infinite-recursion nightmare otherwise. + */ + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); + if (cmdPtr == NULL) { + Tcl_AppendResult(interp, "invalid command name \"", + TclGetString(objv[0]), "\"", NULL); + code = TCL_ERROR; + } else { + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, newObjc, newObjv, command, + length, 0); + iPtr->numLevels--; + } + + /* + * Release any resources we locked and allocated during the handler + * call. + */ + + for (i = 0; i < handlerObjc; ++i) { + Tcl_DecrRefCount(newObjv[i]); + } + TclStackFree(interp, newObjv); + if (savedNsPtr) { + varFramePtr->nsPtr = savedNsPtr; + } + goto done; + } } /* @@ -3889,23 +3897,24 @@ TclEvalEx( { Interp *iPtr = (Interp *) interp; const char *p, *next; - Tcl_Parse parse; #define NUM_STATIC_OBJS 20 Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv, **objvSpace; int expandStatic[NUM_STATIC_OBJS], *expand; int linesStatic[NUM_STATIC_OBJS], *lines, *lineSpace; Tcl_Token *tokenPtr; int code = TCL_OK; - int i, commandLength, bytesLeft, expandRequested; + int commandLength, bytesLeft, expandRequested; CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - int gotParse = 0, objectsUsed = 0; + int gotParse = 0; + unsigned int i, objectsUsed = 0; /* These variables keep track of how much * state has been allocated while evaluating * the script, so that it can be freed * properly if an error occurs. */ + Tcl_Parse *parsePtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); CmdFrame *eeFramePtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); /* TIP #280 Structures for tracking of command * locations. */ @@ -3995,7 +4004,7 @@ TclEvalEx( iPtr->evalFlags = 0; do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) { + if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { code = TCL_ERROR; goto error; } @@ -4006,38 +4015,36 @@ TclEvalEx( * block. */ - TclAdvanceLines(&line, p, parse.commandStart); + TclAdvanceLines(&line, p, parsePtr->commandStart); gotParse = 1; - if (parse.numWords > 0) { + if (parsePtr->numWords > 0) { /* * TIP #280. Track lines within the words of the current * command. */ int wordLine = line; - const char *wordStart = parse.commandStart; + const char *wordStart = parsePtr->commandStart; /* * Generate an array of objects for the words of the command. */ int objectsNeeded = 0; + unsigned int numWords = parsePtr->numWords; - if (parse.numWords > NUM_STATIC_OBJS) { - expand = (int *) - ckalloc((unsigned) parse.numWords * sizeof(int)); - objvSpace = (Tcl_Obj **) - ckalloc((unsigned) parse.numWords * sizeof(Tcl_Obj *)); - lineSpace = (int *) - ckalloc((unsigned) parse.numWords * sizeof(int)); + if (numWords > NUM_STATIC_OBJS) { + expand = (int *) ckalloc(numWords * sizeof(int)); + objvSpace = (Tcl_Obj **) ckalloc(numWords * sizeof(Tcl_Obj *)); + lineSpace = (int *) ckalloc(numWords * sizeof(int)); } expandRequested = 0; objv = objvSpace; lines = lineSpace; - for (objectsUsed = 0, tokenPtr = parse.tokenPtr; - objectsUsed < parse.numWords; + for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr; + objectsUsed < numWords; objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { /* * TIP #280. Track lines to current word. Save the information @@ -4098,10 +4105,10 @@ TclEvalEx( Tcl_Obj **copy = objvSpace; int *lcopy = lineSpace; - int wordIdx = parse.numWords; + int wordIdx = numWords; int objIdx = objectsNeeded - 1; - if ((parse.numWords > NUM_STATIC_OBJS) + if ((numWords > NUM_STATIC_OBJS) || (objectsNeeded > NUM_STATIC_OBJS)) { objv = objvSpace = (Tcl_Obj **) ckalloc((unsigned)objectsNeeded*sizeof(Tcl_Obj*)); @@ -4150,10 +4157,10 @@ TclEvalEx( * have been executed. */ - eeFramePtr->cmd.str.cmd = parse.commandStart; - eeFramePtr->cmd.str.len = parse.commandSize; + eeFramePtr->cmd.str.cmd = parsePtr->commandStart; + eeFramePtr->cmd.str.len = parsePtr->commandSize; - if (parse.term == parse.commandStart + parse.commandSize - 1) { + if (parsePtr->term == parsePtr->commandStart + parsePtr->commandSize - 1) { eeFramePtr->cmd.str.len--; } @@ -4163,7 +4170,7 @@ TclEvalEx( iPtr->cmdFramePtr = eeFramePtr; iPtr->numLevels++; code = TclEvalObjvInternal(interp, objectsUsed, objv, - parse.commandStart, parse.commandSize, 0); + parsePtr->commandStart, parsePtr->commandSize, 0); iPtr->numLevels--; iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; @@ -4202,11 +4209,11 @@ TclEvalEx( * executed command. */ - next = parse.commandStart + parse.commandSize; + next = parsePtr->commandStart + parsePtr->commandSize; bytesLeft -= next - p; p = next; - TclAdvanceLines(&line, parse.commandStart, p); - Tcl_FreeParse(&parse); + TclAdvanceLines(&line, parsePtr->commandStart, p); + Tcl_FreeParse(parsePtr); gotParse = 0; } while (bytesLeft > 0); iPtr->varFramePtr = savedVarFramePtr; @@ -4227,8 +4234,8 @@ TclEvalEx( } } if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - commandLength = parse.commandSize; - if (parse.term == parse.commandStart + commandLength - 1) { + commandLength = parsePtr->commandSize; + if (parsePtr->term == parsePtr->commandStart + commandLength - 1) { /* * The terminator character (such as ; or ]) of the command where * the error occurred is the last character in the parsed command. @@ -4238,7 +4245,7 @@ TclEvalEx( commandLength -= 1; } - Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, commandLength); } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -4250,7 +4257,7 @@ TclEvalEx( Tcl_DecrRefCount(objv[i]); } if (gotParse) { - Tcl_FreeParse(&parse); + Tcl_FreeParse(parsePtr); } if (objvSpace != staticObjArray) { ckfree((char *) objvSpace); @@ -4270,6 +4277,7 @@ TclEvalEx( Tcl_DecrRefCount(eeFramePtr->data.eval.path); } TclStackFree(interp, eeFramePtr); + TclStackFree(interp, parsePtr); return code; } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index d8c37eb..63a0779 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.115.2.3 2007/06/21 16:04:55 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.115.2.4 2007/06/25 18:53:29 dgp Exp $ */ #include "tclInt.h" @@ -4026,7 +4026,9 @@ Tcl_LsortObjCmd( if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; } - elementArray = (SortElement *) ckalloc(length * sizeof(SortElement)); + + elementArray = (SortElement *) + TclStackAlloc(interp, length * sizeof(SortElement)); for (i=0; i < length; i++){ elementArray[i].objPtr = listObjPtrs[i]; elementArray[i].count = 0; @@ -4064,7 +4066,7 @@ Tcl_LsortObjCmd( } Tcl_SetObjResult(interp, resultPtr); } - ckfree((char *) elementArray); + TclStackFree(interp, elementArray); done: if (sortInfo.sortMode == SORTMODE_COMMAND) { diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index f1f4645..eb95fc7 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.53.2.1 2007/06/21 16:04:55 dgp Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.53.2.2 2007/06/25 18:53:30 dgp Exp $ */ #include "tclInt.h" @@ -443,7 +443,10 @@ ParseExpr( scanned = tokenPtr->size; break; - case SCRIPT: + case SCRIPT: { + Tcl_Parse *nestedPtr = + (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; tokenPtr->type = TCL_TOKEN_COMMAND; tokenPtr->start = start; @@ -452,19 +455,18 @@ ParseExpr( end = start + numBytes; start++; while (1) { - Tcl_Parse nested; code = Tcl_ParseCommand(interp, start, (end - start), 1, - &nested); + nestedPtr); if (code != TCL_OK) { - parsePtr->term = nested.term; - parsePtr->errorType = nested.errorType; - parsePtr->incomplete = nested.incomplete; + parsePtr->term = nestedPtr->term; + parsePtr->errorType = nestedPtr->errorType; + parsePtr->incomplete = nestedPtr->incomplete; break; } - start = (nested.commandStart + nested.commandSize); - Tcl_FreeParse(&nested); - if ((nested.term < end) && (*nested.term == ']') - && !nested.incomplete) { + start = (nestedPtr->commandStart + nestedPtr->commandSize); + Tcl_FreeParse(nestedPtr); + if ((nestedPtr->term < end) && (*(nestedPtr->term) == ']') + && !(nestedPtr->incomplete)) { break; } @@ -477,6 +479,7 @@ ParseExpr( break; } } + TclStackFree(interp, nestedPtr); end = start; start = tokenPtr->start; if (code != TCL_OK) { @@ -489,6 +492,7 @@ ParseExpr( parsePtr->numTokens++; break; } + } tokenPtr = parsePtr->tokenPtr + wordIndex; tokenPtr->size = scanned; @@ -1148,10 +1152,11 @@ Tcl_ParseExpr( OpNode *opTree = NULL; /* Will point to the tree of operators */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ - Tcl_Parse parse; /* Holds the Tcl_Tokens of substitutions */ - + Tcl_Parse *exprParsePtr = + (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + /* Holds the Tcl_Tokens of substitutions */ int code = ParseExpr(interp, start, numBytes, &opTree, litList, - funcList, &parse); + funcList, exprParsePtr); if (numBytes < 0) { numBytes = (start ? strlen(start) : 0); @@ -1160,12 +1165,13 @@ Tcl_ParseExpr( TclParseInit(interp, start, numBytes, parsePtr); if (code == TCL_OK) { ConvertTreeToTokens(interp, start, numBytes, opTree, litList, - parse.tokenPtr, parsePtr); + exprParsePtr->tokenPtr, parsePtr); } else { /* TODO: copy over any error info to *parsePtr */ } - Tcl_FreeParse(&parse); + Tcl_FreeParse(exprParsePtr); + TclStackFree(interp, exprParsePtr); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); ckfree((char *) opTree); @@ -1176,7 +1182,8 @@ Tcl_ParseExpr( ExprNode *lastOrphanPtr, *nodes = staticNodes; int nodesAvailable = NUM_STATIC_NODES; int nodesUsed = 0; - Tcl_Parse scratch; /* Parsing scratch space */ + Tcl_Parse *scratchPtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + /* Parsing scratch space */ Tcl_Obj *msg = NULL, *post = NULL; int scanned = 0, code = TCL_OK, insertMark = 0; const char *mark = "_@_"; @@ -1193,7 +1200,7 @@ Tcl_ParseExpr( numBytes = (start ? strlen(start) : 0); } - TclParseInit(interp, start, numBytes, &scratch); + TclParseInit(interp, start, numBytes, scratchPtr); TclParseInit(interp, start, numBytes, parsePtr); /* @@ -1324,7 +1331,7 @@ Tcl_ParseExpr( if ((NODE_TYPE & lastNodePtr->lexeme) == LEAF) { const char *operand = - scratch.tokenPtr[lastNodePtr->token].start; + scratchPtr->tokenPtr[lastNodePtr->token].start; msg = Tcl_ObjPrintf("missing operator at %s", mark); if (operand[0] == '0') { @@ -1342,32 +1349,32 @@ Tcl_ParseExpr( continue; } - if (scratch.numTokens+1 >= scratch.tokensAvailable) { - TclExpandTokenArray(&scratch); + if (scratchPtr->numTokens+1 >= scratchPtr->tokensAvailable) { + TclExpandTokenArray(scratchPtr); } - nodePtr->token = scratch.numTokens; - tokenPtr = scratch.tokenPtr + nodePtr->token; + nodePtr->token = scratchPtr->numTokens; + tokenPtr = scratchPtr->tokenPtr + nodePtr->token; tokenPtr->type = TCL_TOKEN_SUB_EXPR; tokenPtr->start = start; - scratch.numTokens++; + scratchPtr->numTokens++; switch (nodePtr->lexeme) { case NUMBER: case BOOLEAN: - tokenPtr = scratch.tokenPtr + scratch.numTokens; + tokenPtr = scratchPtr->tokenPtr + scratchPtr->numTokens; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = start; tokenPtr->size = scanned; tokenPtr->numComponents = 0; - scratch.numTokens++; + scratchPtr->numTokens++; break; case QUOTED: code = Tcl_ParseQuotedString(interp, start, numBytes, - &scratch, 1, &end); + scratchPtr, 1, &end); if (code != TCL_OK) { - scanned = scratch.term - start; + scanned = scratchPtr->term - start; scanned += (scanned < numBytes); continue; } @@ -1376,7 +1383,7 @@ Tcl_ParseExpr( case BRACED: code = Tcl_ParseBraces(interp, start, numBytes, - &scratch, 1, &end); + scratchPtr, 1, &end); if (code != TCL_OK) { continue; } @@ -1384,13 +1391,13 @@ Tcl_ParseExpr( break; case VARIABLE: - code = Tcl_ParseVarName(interp, start, numBytes, &scratch, 1); + code = Tcl_ParseVarName(interp, start, numBytes, scratchPtr, 1); if (code != TCL_OK) { - scanned = scratch.term - start; + scanned = scratchPtr->term - start; scanned += (scanned < numBytes); continue; } - tokenPtr = scratch.tokenPtr + nodePtr->token + 1; + tokenPtr = scratchPtr->tokenPtr + nodePtr->token + 1; if (tokenPtr->type != TCL_TOKEN_VARIABLE) { TclNewLiteralStringObj(msg, "invalid character \"$\""); code = TCL_ERROR; @@ -1399,8 +1406,10 @@ Tcl_ParseExpr( scanned = tokenPtr->size; break; - case SCRIPT: - tokenPtr = scratch.tokenPtr + scratch.numTokens; + case SCRIPT: { + Tcl_Parse *nestedPtr = + (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + tokenPtr = scratchPtr->tokenPtr + scratchPtr->numTokens; tokenPtr->type = TCL_TOKEN_COMMAND; tokenPtr->start = start; tokenPtr->numComponents = 0; @@ -1408,19 +1417,18 @@ Tcl_ParseExpr( end = start + numBytes; start++; while (1) { - Tcl_Parse nested; code = Tcl_ParseCommand(interp, - start, (end - start), 1, &nested); + start, (end - start), 1, nestedPtr); if (code != TCL_OK) { - parsePtr->term = nested.term; - parsePtr->errorType = nested.errorType; - parsePtr->incomplete = nested.incomplete; + parsePtr->term = nestedPtr->term; + parsePtr->errorType = nestedPtr->errorType; + parsePtr->incomplete = nestedPtr->incomplete; break; } - start = (nested.commandStart + nested.commandSize); - Tcl_FreeParse(&nested); - if ((nested.term < end) && (*nested.term == ']') - && !nested.incomplete) { + start = (nestedPtr->commandStart + nestedPtr->commandSize); + Tcl_FreeParse(nestedPtr); + if ((nestedPtr->term < end) && (*(nestedPtr->term) == ']') + && !(nestedPtr->incomplete)) { break; } @@ -1433,6 +1441,7 @@ Tcl_ParseExpr( break; } } + TclStackFree(interp, nestedPtr); end = start; start = tokenPtr->start; if (code != TCL_OK) { @@ -1442,13 +1451,14 @@ Tcl_ParseExpr( } scanned = end - start; tokenPtr->size = scanned; - scratch.numTokens++; + scratchPtr->numTokens++; break; } + } - tokenPtr = scratch.tokenPtr + nodePtr->token; + tokenPtr = scratchPtr->tokenPtr + nodePtr->token; tokenPtr->size = scanned; - tokenPtr->numComponents = scratch.numTokens - nodePtr->token - 1; + tokenPtr->numComponents = scratchPtr->numTokens - nodePtr->token - 1; nodePtr->left = -1; nodePtr->right = -1; @@ -1470,16 +1480,16 @@ Tcl_ParseExpr( nodePtr->right = -1; nodePtr->parent = -1; - if (scratch.numTokens >= scratch.tokensAvailable) { - TclExpandTokenArray(&scratch); + if (scratchPtr->numTokens >= scratchPtr->tokensAvailable) { + TclExpandTokenArray(scratchPtr); } - nodePtr->token = scratch.numTokens; - tokenPtr = scratch.tokenPtr + nodePtr->token; + nodePtr->token = scratchPtr->numTokens; + tokenPtr = scratchPtr->tokenPtr + nodePtr->token; tokenPtr->type = TCL_TOKEN_OPERATOR; tokenPtr->start = start; tokenPtr->size = scanned; tokenPtr->numComponents = 0; - scratch.numTokens++; + scratchPtr->numTokens++; lastOrphanPtr = nodePtr; nodesUsed++; @@ -1627,7 +1637,7 @@ Tcl_ParseExpr( * CLOSE_PAREN can only close one OPEN_PAREN. */ - tokenPtr = scratch.tokenPtr + otherPtr->token; + tokenPtr = scratchPtr->tokenPtr + otherPtr->token; tokenPtr->size = start + scanned - tokenPtr->start; break; } @@ -1678,16 +1688,16 @@ Tcl_ParseExpr( nodePtr->right = -1; - if (scratch.numTokens >= scratch.tokensAvailable) { - TclExpandTokenArray(&scratch); + if (scratchPtr->numTokens >= scratchPtr->tokensAvailable) { + TclExpandTokenArray(scratchPtr); } - nodePtr->token = scratch.numTokens; - tokenPtr = scratch.tokenPtr + nodePtr->token; + nodePtr->token = scratchPtr->numTokens; + tokenPtr = scratchPtr->tokenPtr + nodePtr->token; tokenPtr->type = TCL_TOKEN_OPERATOR; tokenPtr->start = start; tokenPtr->size = scanned; tokenPtr->numComponents = 0; - scratch.numTokens++; + scratchPtr->numTokens++; nodePtr->left = lastOrphanPtr - nodes; nodePtr->parent = lastOrphanPtr->parent; @@ -1707,7 +1717,7 @@ Tcl_ParseExpr( * Shift tokens from scratch space to caller space. */ - GenerateTokens(nodes, &scratch, parsePtr); + GenerateTokens(nodes, scratchPtr, parsePtr); } else { if (parsePtr->errorType == TCL_PARSE_SUCCESS) { parsePtr->errorType = TCL_PARSE_SYNTAX; @@ -1723,36 +1733,37 @@ Tcl_ParseExpr( } Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", - ((start - limit) < scratch.string) ? "" : "...", - ((start - limit) < scratch.string) - ? (start - scratch.string) : limit - 3, - ((start - limit) < scratch.string) - ? scratch.string : start - limit + 3, + ((start - limit) < scratchPtr->string) ? "" : "...", + ((start - limit) < scratchPtr->string) + ? (start - scratchPtr->string) : limit - 3, + ((start - limit) < scratchPtr->string) + ? scratchPtr->string : start - limit + 3, (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", insertMark ? mark : "", - (start + scanned + limit > scratch.end) - ? scratch.end - (start + scanned) : limit-3, + (start + scanned + limit > scratchPtr->end) + ? scratchPtr->end - (start + scanned) : limit-3, start + scanned, - (start + scanned + limit > scratch.end) ? "" : "..."); + (start + scanned + limit > scratchPtr->end) ? "" : "..."); if (post != NULL) { Tcl_AppendToObj(msg, ";\n", -1); Tcl_AppendObjToObj(msg, post); Tcl_DecrRefCount(post); } Tcl_SetObjResult(interp, msg); - numBytes = scratch.end - scratch.string; + numBytes = scratchPtr->end - scratchPtr->string; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (parsing expression \"%.*s%s\")", (numBytes < limit) ? numBytes : limit - 3, - scratch.string, (numBytes < limit) ? "" : "...")); + scratchPtr->string, (numBytes < limit) ? "" : "...")); } } if (nodes != staticNodes) { ckfree((char *)nodes); } - Tcl_FreeParse(&scratch); + Tcl_FreeParse(scratchPtr); + TclStackFree(interp, scratchPtr); return code; #endif } @@ -2328,10 +2339,12 @@ TclCompileExpr( OpNode *opTree = NULL; /* Will point to the tree of operators */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ - Tcl_Parse parse; /* Holds the Tcl_Tokens of substitutions */ + Tcl_Parse *parsePtr = + (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + /* Holds the Tcl_Tokens of substitutions */ int code = ParseExpr(interp, script, numBytes, &opTree, litList, - funcList, &parse); + funcList, parsePtr); if (code == TCL_OK) { int litObjc, needsNumConversion = 1; @@ -2346,7 +2359,7 @@ TclCompileExpr( */ Tcl_ListObjGetElements(NULL, litList, &litObjc, &litObjv); - CompileExprTree(interp, opTree, litObjv, funcList, parse.tokenPtr, + CompileExprTree(interp, opTree, litObjv, funcList, parsePtr->tokenPtr, &needsNumConversion, envPtr); if (needsNumConversion) { /* @@ -2360,13 +2373,15 @@ TclCompileExpr( } } - Tcl_FreeParse(&parse); + Tcl_FreeParse(parsePtr); + TclStackFree(interp, parsePtr); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); ckfree((char *) opTree); return code; #else - Tcl_Parse parse; + Tcl_Parse *parsePtr = + (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); int needsNumConversion = 1; /* @@ -2401,14 +2416,15 @@ TclCompileExpr( * Parse the expression then compile it. */ - if (TCL_OK != Tcl_ParseExpr(interp, script, numBytes, &parse)) { + if (TCL_OK != Tcl_ParseExpr(interp, script, numBytes, parsePtr)) { + TclStackFree(interp, parsePtr); return TCL_ERROR; } /* TIP #280 : Track Lines within the expression */ - TclAdvanceLines (&envPtr->line, script, parse.tokenPtr->start); + TclAdvanceLines (&envPtr->line, script, parsePtr->tokenPtr->start); - CompileSubExpr(interp, parse.tokenPtr, &needsNumConversion, envPtr); + CompileSubExpr(interp, parsePtr->tokenPtr, &needsNumConversion, envPtr); if (needsNumConversion) { /* @@ -2419,7 +2435,8 @@ TclCompileExpr( TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } - Tcl_FreeParse(&parse); + Tcl_FreeParse(parsePtr); + TclStackFree(interp, parsePtr); return TCL_OK; #endif diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a946f86..3dac2fd 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.117.2.4 2007/06/21 16:04:56 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.117.2.5 2007/06/25 18:53:30 dgp Exp $ */ #include "tclInt.h" @@ -1112,7 +1112,6 @@ TclCompileScript( CompileEnv *envPtr) /* Holds resulting instructions. */ { Interp *iPtr = (Interp *) interp; - Tcl_Parse parse; int lastTopLevelCmdIndex = -1; /* Index of most recent toplevel command in * the command location table. Initialized to @@ -1131,6 +1130,7 @@ TclCompileScript( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int *wlines; int wlineat, cmdLine; + Tcl_Parse *parsePtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); Tcl_DStringInit(&ds); @@ -1156,7 +1156,7 @@ TclCompileScript( gotParse = 0; cmdLine = envPtr->line; do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) { + if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { /* * Compile bytecodes to report the parse error at runtime. */ @@ -1166,7 +1166,8 @@ TclCompileScript( Tcl_Obj *errInfo = Tcl_DuplicateObj(errMsg); char *cmdString; int cmdLength; - Tcl_Parse subParse; + Tcl_Parse *subParsePtr = + (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); int errorLine = 1; TclNewLiteralStringObj(returnCmd, @@ -1174,15 +1175,16 @@ TclCompileScript( Tcl_IncrRefCount(returnCmd); Tcl_IncrRefCount(errInfo); Tcl_AppendToObj(errInfo, "\n while executing\n\"", -1); - Tcl_AppendLimitedToObj(errInfo, parse.commandStart, + Tcl_AppendLimitedToObj(errInfo, parsePtr->commandStart, /* Drop the command terminator (";","]") if appropriate */ - (parse.term == parse.commandStart + parse.commandSize - 1)? - parse.commandSize - 1 : parse.commandSize, 153, NULL); + (parsePtr->term == + parsePtr->commandStart + parsePtr->commandSize - 1)? + parsePtr->commandSize - 1 : parsePtr->commandSize, 153, NULL); Tcl_AppendToObj(errInfo, "\"", -1); Tcl_ListObjAppendElement(NULL, returnCmd, errInfo); - for (p = envPtr->source; p != parse.commandStart; p++) { + for (p = envPtr->source; p != parsePtr->commandStart; p++) { if (*p == '\n') { errorLine++; } @@ -1196,14 +1198,15 @@ TclCompileScript( Tcl_DecrRefCount(errInfo); cmdString = Tcl_GetStringFromObj(returnCmd, &cmdLength); - Tcl_ParseCommand(interp, cmdString, cmdLength, 0, &subParse); - TclCompileReturnCmd(interp, &subParse, envPtr); + Tcl_ParseCommand(interp, cmdString, cmdLength, 0, subParsePtr); + TclCompileReturnCmd(interp, subParsePtr, envPtr); Tcl_DecrRefCount(returnCmd); - Tcl_FreeParse(&subParse); - return; + Tcl_FreeParse(subParsePtr); + TclStackFree(interp, subParsePtr); + break; } gotParse = 1; - if (parse.numWords > 0) { + if (parsePtr->numWords > 0) { int expand = 0; /* Set if there are dynamic expansions * to handle */ @@ -1224,8 +1227,8 @@ TclCompileScript( * Determine the actual length of the command. */ - commandLength = parse.commandSize; - if (parse.term == parse.commandStart + commandLength - 1) { + commandLength = parsePtr->commandSize; + if (parsePtr->term == parsePtr->commandStart + commandLength - 1) { /* * The command terminator character (such as ; or ]) is the * last character in the parsed command. Reduce the length by @@ -1243,7 +1246,7 @@ TclCompileScript( if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parse.commandStart, + TclPrintSource(stdout, parsePtr->commandStart, TclMin(commandLength, 55)); fprintf(stdout, "\n"); } @@ -1254,8 +1257,8 @@ TclCompileScript( * words. */ - for (wordIdx = 0, tokenPtr = parse.tokenPtr; - wordIdx < parse.numWords; + for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; + wordIdx < parsePtr->numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { expand = 1; @@ -1268,7 +1271,7 @@ TclCompileScript( lastTopLevelCmdIndex = currCmdIndex; startCodeOffset = (envPtr->codeNext - envPtr->codeStart); EnterCmdStartData(envPtr, currCmdIndex, - parse.commandStart - envPtr->source, startCodeOffset); + parsePtr->commandStart - envPtr->source, startCodeOffset); /* * Should only start issuing instructions after the "command has @@ -1287,10 +1290,10 @@ TclCompileScript( * 'wlines'. */ - TclAdvanceLines(&cmdLine, p, parse.commandStart); - EnterCmdWordData(eclPtr, parse.commandStart - envPtr->source, - parse.tokenPtr, parse.commandStart, parse.commandSize, - parse.numWords, cmdLine, &wlines); + TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); + EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, + parsePtr->tokenPtr, parsePtr->commandStart, parsePtr->commandSize, + parsePtr->numWords, cmdLine, &wlines); wlineat = eclPtr->nuloc - 1; /* @@ -1298,8 +1301,8 @@ TclCompileScript( * command. */ - for (wordIdx = 0, tokenPtr = parse.tokenPtr; - wordIdx < parse.numWords; wordIdx++, + for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; + wordIdx < parsePtr->numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; @@ -1378,7 +1381,7 @@ TclCompileScript( } } - code = (cmdPtr->compileProc)(interp, &parse, envPtr); + code = (cmdPtr->compileProc)(interp, parsePtr, envPtr); if (code == TCL_OK) { if (update) { @@ -1420,7 +1423,7 @@ TclCompileScript( TclSetCmdNameObj(interp, envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr); } - if ((wordIdx == 0) && (parse.numWords == 1)) { + if ((wordIdx == 0) && (parsePtr->numWords == 1)) { /* * Single word script: unshare the command name to * avoid shimmering between bytecode and cmdName @@ -1485,13 +1488,13 @@ TclCompileScript( ckfree((char *) eclPtr->loc[wlineat].line); eclPtr->loc[wlineat].line = wlines; - } /* end if parse.numWords > 0 */ + } /* end if parsePtr->numWords > 0 */ /* * Advance to the next command in the script. */ - next = parse.commandStart + parse.commandSize; + next = parsePtr->commandStart + parsePtr->commandSize; bytesLeft -= next - p; p = next; @@ -1499,8 +1502,8 @@ TclCompileScript( * TIP #280: Track lines in the just compiled command. */ - TclAdvanceLines(&cmdLine, parse.commandStart, p); - Tcl_FreeParse(&parse); + TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); + Tcl_FreeParse(parsePtr); gotParse = 0; } while (bytesLeft > 0); @@ -1520,6 +1523,7 @@ TclCompileScript( } envPtr->numSrcBytes = (p - script); + TclStackFree(interp, parsePtr); Tcl_DStringFree(&ds); } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 32a0160..db6ff1a 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.285.2.8 2007/06/21 16:04:56 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.285.2.9 2007/06/25 18:53:30 dgp Exp $ */ #include "tclInt.h" @@ -444,8 +444,6 @@ static void DeleteExecStack(ExecStack *esPtr); static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); -/* Move to internal stubs? For now, unused */ -extern char * TclStackRealloc(Tcl_Interp *interp, int numBytes); /* *---------------------------------------------------------------------- @@ -878,14 +876,33 @@ TclStackAlloc( return (void *) StackAllocWords(interp, numWords); } -char * +void * TclStackRealloc( Tcl_Interp *interp, + void *ptr, int numBytes) { - int numWords = (numBytes + sizeof(void *) - 1)/sizeof(void *); + Interp *iPtr; + ExecEnv *eePtr; + ExecStack *esPtr; + Tcl_Obj **markerPtr; + int numWords; + + if (interp == NULL) { + return (void *) Tcl_Realloc((char *) ptr, numBytes); + } + + iPtr = (Interp *) interp; + eePtr = iPtr->execEnvPtr; + esPtr = eePtr->execStackPtr; + markerPtr = esPtr->markerPtr; - return (char *) StackReallocWords(interp, numWords); + if ((markerPtr+1) != (Tcl_Obj **)ptr) { + Tcl_Panic("TclStackRealloc: incorrect ptr. Call out of sequence?"); + } + + numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + return (void *) StackReallocWords(interp, numWords); } /* @@ -2000,9 +2017,21 @@ TclExecuteByteCode( DECACHE_STACK_INFO(); cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if (cmdPtr && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) - && iPtr->tracePtr == NULL) { - result = TclEvalObjvInternal(interp, objc, objv, NULL, 0, 0); + if (cmdPtr + && !((cmdPtr->flags & CMD_HAS_EXEC_TRACES) || iPtr->tracePtr) + && !(checkInterp && (codePtr->compileEpoch != iPtr->compileEpoch)) + ) { + cmdPtr->refCount++; + iPtr->cmdCount++; + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + + if (Tcl_AsyncReady()) { + result = Tcl_AsyncInvoke(interp, result); + } + if (result == TCL_OK && TclLimitReady(iPtr->limit)) { + result = Tcl_LimitCheck(interp); + } + TclCleanupCommandMacro(cmdPtr); } else { /* * If trace procedures will be called, we need a command diff --git a/generic/tclInt.h b/generic/tclInt.h index 07c1137..3152e3c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.310.2.4 2007/06/15 16:37:46 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.310.2.5 2007/06/25 18:53:31 dgp Exp $ */ #ifndef _TCLINT @@ -2461,6 +2461,8 @@ MODULE_SCOPE void TclSetBignumIntRep (Tcl_Obj *objPtr, MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); +MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, + int numBytes); MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index dd93a8b..a834ec0 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -22,19 +22,12 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.134.2.3 2007/06/21 16:04:56 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.134.2.4 2007/06/25 18:53:31 dgp Exp $ */ #include "tclInt.h" /* - * Initial size of stack allocated space for tail list - used when resetting - * shadowed command references in the function TclResetShadowedCmdRefs. - */ - -#define NUM_TRAIL_ELEMS 5 - -/* * Thread-local storage used to avoid having a global lock on data that is not * limited to a single interpreter. */ @@ -2660,17 +2653,10 @@ TclResetShadowedCmdRefs( Namespace *trailNsPtr, *shadowNsPtr; Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); int found, i; - - /* - * This function generates an array used to hold the trail list. This - * starts out with stack-allocated space but uses dynamically-allocated - * storage if needed. - */ - - Namespace *(trailStorage[NUM_TRAIL_ELEMS]); - Namespace **trailPtr = trailStorage; int trailFront = -1; - int trailSize = NUM_TRAIL_ELEMS; + int trailSize = 5; /* formerly NUM_TRAIL_ELEMS */ + Namespace **trailPtr = (Namespace **) + TclStackAlloc(interp, trailSize * sizeof(Namespace *)); /* * Start at the namespace containing the new command, and work up through @@ -2748,30 +2734,14 @@ TclResetShadowedCmdRefs( trailFront++; if (trailFront == trailSize) { - size_t currBytes = trailSize * sizeof(Namespace *); int newSize = 2 * trailSize; - size_t newBytes = newSize * sizeof(Namespace *); - - if (trailPtr != trailStorage) { - trailPtr = (Namespace **) ckrealloc((char *) trailPtr, - newBytes); - } else { - Namespace **newPtr = (Namespace **) ckalloc(newBytes); - memcpy(newPtr, trailPtr, currBytes); - trailPtr = newPtr; - } + trailPtr = (Namespace **) TclStackRealloc(interp, + trailPtr, newSize * sizeof(Namespace *)); trailSize = newSize; } trailPtr[trailFront] = nsPtr; } - - /* - * Free any allocated storage. - */ - - if (trailPtr != trailStorage) { - ckfree((char *) trailPtr); - } + TclStackFree(interp, trailPtr); } /* diff --git a/generic/tclParse.c b/generic/tclParse.c index 7add3ad..1732007 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParse.c,v 1.52.2.2 2007/06/12 15:56:43 dgp Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.52.2.3 2007/06/25 18:53:31 dgp Exp $ */ #include "tclInt.h" @@ -174,10 +174,10 @@ static CONST char charTypeTable[] = { static int CommandComplete(CONST char *script, int numBytes); static int ParseComment(CONST char *src, int numBytes, Tcl_Parse *parsePtr); -static int ParseTokens(CONST char *src, int numBytes, +static int ParseTokens(Tcl_Interp *interp, CONST char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr); static int ParseWhiteSpace(CONST char *src, int numBytes, - Tcl_Parse *parsePtr, char *typePtr); + int *incompletePtr, char *typePtr); /* *---------------------------------------------------------------------- @@ -327,7 +327,7 @@ Tcl_ParseCommand( * sequence: it should be treated just like white space. */ - scanned = ParseWhiteSpace(src, numBytes, parsePtr, &type); + scanned = ParseWhiteSpace(src, numBytes, &(parsePtr->incomplete), &type); src += scanned; numBytes -= scanned; if (numBytes == 0) { @@ -383,8 +383,8 @@ Tcl_ParseCommand( && (expPtr->start[0] == '*')) ) /* Is the prefix */ - && (numBytes > 0) - && (ParseWhiteSpace(termPtr, numBytes, parsePtr, &type) == 0) + && (numBytes > 0) && (0 == + ParseWhiteSpace(termPtr, numBytes, &(parsePtr->incomplete), &type)) && (type != TYPE_COMMAND_END) /* Non-whitespace follows */ ) { @@ -398,7 +398,7 @@ Tcl_ParseCommand( * the work. */ - if (ParseTokens(src, numBytes, TYPE_SPACE|terminators, + if (ParseTokens(interp, src, numBytes, TYPE_SPACE|terminators, TCL_SUBST_ALL, parsePtr) != TCL_OK) { goto error; } @@ -562,7 +562,7 @@ Tcl_ParseCommand( * word), and (b) check for the end of the command. */ - scanned = ParseWhiteSpace(src, numBytes, parsePtr, &type); + scanned = ParseWhiteSpace(src, numBytes, &(parsePtr->incomplete), &type); if (scanned) { src += scanned; numBytes -= scanned; @@ -628,9 +628,8 @@ static int ParseWhiteSpace( CONST char *src, /* First character to parse. */ register int numBytes, /* Max number of bytes to scan. */ - Tcl_Parse *parsePtr, /* Information about parse in progress. - * Updated if parsing indicates an incomplete - * command. */ + int *incompletePtr, /* Set this boolean memory to true if parsing + * indicates an incomplete command. */ char *typePtr) /* Points to location to store character type * of character that ends run of whitespace */ { @@ -654,7 +653,7 @@ ParseWhiteSpace( } p+=2; if (--numBytes == 0) { - parsePtr->incomplete = 1; + *incompletePtr = 1; break; } continue; @@ -684,9 +683,7 @@ TclParseAllWhiteSpace( CONST char *src, /* First character to parse. */ int numBytes) /* Max number of byes to scan */ { - Tcl_Parse dummy; /* Since we know ParseWhiteSpace() generates - * no tokens, there's no need for a call to - * Tcl_FreeParse() in this routine. */ + int dummy; char type; CONST char *p = src; @@ -975,7 +972,7 @@ ParseComment( while (numBytes) { if (*p == '\\') { - scanned = ParseWhiteSpace(p, numBytes, parsePtr, &type); + scanned = ParseWhiteSpace(p, numBytes, &(parsePtr->incomplete), &type); if (scanned) { p += scanned; numBytes -= scanned; @@ -1031,6 +1028,7 @@ ParseComment( static int ParseTokens( + Tcl_Interp *interp, register CONST char *src, /* First character to parse. */ register int numBytes, /* Max number of bytes to scan. */ int mask, /* Specifies when to stop parsing. The parse @@ -1051,7 +1049,6 @@ ParseTokens( int noSubstVars = !(flags & TCL_SUBST_VARIABLES); int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES); Tcl_Token *tokenPtr; - Tcl_Parse nested; /* * Each iteration through the following loop adds one token of type @@ -1105,6 +1102,8 @@ ParseTokens( src += parsePtr->tokenPtr[varToken].size; numBytes -= parsePtr->tokenPtr[varToken].size; } else if (*src == '[') { + Tcl_Parse *nestedPtr; + if (noSubstCmds) { tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; @@ -1122,25 +1121,19 @@ ParseTokens( src++; numBytes--; + nestedPtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); while (1) { if (Tcl_ParseCommand(parsePtr->interp, src, - numBytes, 1, &nested) != TCL_OK) { - parsePtr->errorType = nested.errorType; - parsePtr->term = nested.term; - parsePtr->incomplete = nested.incomplete; + numBytes, 1, nestedPtr) != TCL_OK) { + parsePtr->errorType = nestedPtr->errorType; + parsePtr->term = nestedPtr->term; + parsePtr->incomplete = nestedPtr->incomplete; + TclStackFree(interp, nestedPtr); return TCL_ERROR; } - src = nested.commandStart + nested.commandSize; + src = nestedPtr->commandStart + nestedPtr->commandSize; numBytes = parsePtr->end - src; - - /* - * This is equivalent to Tcl_FreeParse(&nested), but - * presumably inlined here for sake of runtime optimization - */ - - if (nested.tokenPtr != nested.staticTokens) { - ckfree((char *) nested.tokenPtr); - } + Tcl_FreeParse(nestedPtr); /* * Check for the closing ']' that ends the command @@ -1148,8 +1141,8 @@ ParseTokens( * parsed command. */ - if ((nested.term < parsePtr->end) && (*nested.term == ']') - && !nested.incomplete) { + if ((nestedPtr->term < parsePtr->end) && (*(nestedPtr->term) == ']') + && !(nestedPtr->incomplete)) { break; } if (numBytes == 0) { @@ -1160,9 +1153,11 @@ ParseTokens( parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->term = tokenPtr->start; parsePtr->incomplete = 1; + TclStackFree(interp, nestedPtr); return TCL_ERROR; } } + TclStackFree(interp, nestedPtr); tokenPtr->type = TCL_TOKEN_COMMAND; tokenPtr->size = src - tokenPtr->start; parsePtr->numTokens++; @@ -1493,7 +1488,7 @@ Tcl_ParseVarName( * any number of substitutions. */ - if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, + if (TCL_OK != ParseTokens(interp, src+1, numBytes-1, TYPE_CLOSE_PAREN, TCL_SUBST_ALL, parsePtr)) { goto error; } @@ -1563,26 +1558,29 @@ Tcl_ParseVar( * in with character just after last * one in the variable specifier. */ { - Tcl_Parse parse; register Tcl_Obj *objPtr; int code; + Tcl_Parse *parsePtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); - if (Tcl_ParseVarName(interp, start, -1, &parse, 0) != TCL_OK) { + if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) { + TclStackFree(interp, parsePtr); return NULL; } if (termPtr != NULL) { - *termPtr = start + parse.tokenPtr->size; + *termPtr = start + parsePtr->tokenPtr->size; } - if (parse.numTokens == 1) { + if (parsePtr->numTokens == 1) { /* * There isn't a variable name after all: the $ is just a $. */ + TclStackFree(interp, parsePtr); return "$"; } - code = TclSubstTokens(interp, parse.tokenPtr, parse.numTokens, NULL, 1); + code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, NULL, 1); + TclStackFree(interp, parsePtr); if (code != TCL_OK) { return NULL; } @@ -1872,7 +1870,7 @@ Tcl_ParseQuotedString( TclParseInit(interp, start, numBytes, parsePtr); } - if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, + if (TCL_OK != ParseTokens(interp, start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL, parsePtr)) { goto error; } @@ -1920,13 +1918,13 @@ Tcl_SubstObj( int flags) /* What substitutions to do. */ { int length, tokensLeft, code; - Tcl_Parse parse; Tcl_Token *endTokenPtr; Tcl_Obj *result; Tcl_Obj *errMsg = NULL; CONST char *p = Tcl_GetStringFromObj(objPtr, &length); + Tcl_Parse *parsePtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); - TclParseInit(interp, p, length, &parse); + TclParseInit(interp, p, length, parsePtr); /* * First parse the string rep of objPtr, as if it were enclosed as a @@ -1934,7 +1932,7 @@ Tcl_SubstObj( * inhibit types of substitution. */ - if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, &parse)) { + if (TCL_OK != ParseTokens(interp, p, length, /* mask */ 0, flags, parsePtr)) { /* * There was a parse error. Save the error message for possible * reporting later. @@ -1956,18 +1954,19 @@ Tcl_SubstObj( */ do { - parse.numTokens = 0; - parse.tokensAvailable = NUM_STATIC_TOKENS; - parse.end = parse.term; - parse.incomplete = 0; - parse.errorType = TCL_PARSE_SUCCESS; - } while (TCL_OK != ParseTokens(p, parse.end - p, 0, flags, &parse)); + parsePtr->numTokens = 0; + parsePtr->tokensAvailable = NUM_STATIC_TOKENS; + parsePtr->end = parsePtr->term; + parsePtr->incomplete = 0; + parsePtr->errorType = TCL_PARSE_SUCCESS; + } while (TCL_OK != + ParseTokens(interp, p, parsePtr->end - p, 0, flags, parsePtr)); /* * The good parse will have to be followed by {, (, or [. */ - switch (*parse.term) { + switch (*(parsePtr->term)) { case '{': /* * Parse error was a missing } in a ${varname} variable @@ -1984,7 +1983,7 @@ Tcl_SubstObj( * array variable substitution at the toplevel. */ - if (*(parse.term - 1) == '$') { + if (*(parsePtr->term - 1) == '$') { /* * Special case where removing the array index left us with * just a dollar sign (array variable with name the empty @@ -2003,7 +2002,7 @@ Tcl_SubstObj( */ Tcl_Token *varTokenPtr = - parse.tokenPtr + parse.numTokens - 2; + parsePtr->tokenPtr + parsePtr->numTokens - 2; if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { Tcl_Panic("Tcl_SubstObj: programming error"); @@ -2011,7 +2010,7 @@ Tcl_SubstObj( if (varTokenPtr[1].type != TCL_TOKEN_TEXT) { Tcl_Panic("Tcl_SubstObj: programming error"); } - parse.numTokens -= 2; + parsePtr->numTokens -= 2; } break; case '[': @@ -2020,9 +2019,9 @@ Tcl_SubstObj( * substitution. */ - parse.end = p + length; - p = parse.term + 1; - length = parse.end - p; + parsePtr->end = p + length; + p = parsePtr->term + 1; + length = parsePtr->end - p; if (length == 0) { /* * No commands, just an unmatched [. As in previous cases, @@ -2037,15 +2036,16 @@ Tcl_SubstObj( */ Tcl_Token *tokenPtr; - Tcl_Parse nested; - CONST char *lastTerm = parse.term; + CONST char *lastTerm = parsePtr->term; + Tcl_Parse *nestedPtr = + (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); while (TCL_OK == - Tcl_ParseCommand(NULL, p, length, 0, &nested)) { - Tcl_FreeParse(&nested); - p = nested.term + (nested.term < nested.end); - length = nested.end - p; - if ((length == 0) && (nested.term == nested.end)) { + Tcl_ParseCommand(NULL, p, length, 0, nestedPtr)) { + Tcl_FreeParse(nestedPtr); + p = nestedPtr->term + (nestedPtr->term < nestedPtr->end); + length = nestedPtr->end - p; + if ((length == 0) && (nestedPtr->term == nestedPtr->end)) { /* * If we run out of string, blame the missing close * bracket on the last command, and do not evaluate it @@ -2054,10 +2054,11 @@ Tcl_SubstObj( break; } - lastTerm = nested.term; + lastTerm = nestedPtr->term; } + TclStackFree(interp, nestedPtr); - if (lastTerm == parse.term) { + if (lastTerm == parsePtr->term) { /* * Parse error in first command. No commands to subst, add * no more tokens. @@ -2070,15 +2071,15 @@ Tcl_SubstObj( * got parsed. */ - if (parse.numTokens == parse.tokensAvailable) { - TclExpandTokenArray(&parse); + if (parsePtr->numTokens == parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); } - tokenPtr = &parse.tokenPtr[parse.numTokens]; - tokenPtr->start = parse.term; + tokenPtr = &(parsePtr->tokenPtr[parsePtr->numTokens]); + tokenPtr->start = parsePtr->term; tokenPtr->numComponents = 0; tokenPtr->type = TCL_TOKEN_COMMAND; tokenPtr->size = lastTerm - tokenPtr->start + 1; - parse.numTokens++; + parsePtr->numTokens++; } break; @@ -2091,12 +2092,13 @@ Tcl_SubstObj( * Next, substitute the parsed tokens just as in normal Tcl evaluation. */ - endTokenPtr = parse.tokenPtr + parse.numTokens; - tokensLeft = parse.numTokens; + endTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; + tokensLeft = parsePtr->numTokens; code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, &tokensLeft, 1); if (code == TCL_OK) { - Tcl_FreeParse(&parse); + Tcl_FreeParse(parsePtr); + TclStackFree(interp, parsePtr); if (errMsg != NULL) { Tcl_SetObjResult(interp, errMsg); Tcl_DecrRefCount(errMsg); @@ -2109,7 +2111,8 @@ Tcl_SubstObj( while (1) { switch (code) { case TCL_ERROR: - Tcl_FreeParse(&parse); + Tcl_FreeParse(parsePtr); + TclStackFree(interp, parsePtr); Tcl_DecrRefCount(result); if (errMsg != NULL) { Tcl_DecrRefCount(errMsg); @@ -2122,7 +2125,8 @@ Tcl_SubstObj( } if (tokensLeft == 0) { - Tcl_FreeParse(&parse); + Tcl_FreeParse(parsePtr); + TclStackFree(interp, parsePtr); if (errMsg != NULL) { if (code != TCL_BREAK) { Tcl_DecrRefCount(result); diff --git a/generic/tclScan.c b/generic/tclScan.c index 8696240..1a05b8c 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclScan.c,v 1.24 2006/04/25 17:15:25 dgp Exp $ + * RCS: @(#) $Id: tclScan.c,v 1.24.6.1 2007/06/25 18:53:31 dgp Exp $ */ #include "tclInt.h" @@ -258,13 +258,11 @@ ValidateFormat( int *totalSubs) /* The number of variables that will be * required. */ { -#define STATIC_LIST_SIZE 16 int gotXpg, gotSequential, value, i, flags; char *end; Tcl_UniChar ch; - int staticAssign[STATIC_LIST_SIZE]; - int *nassign = staticAssign; - int objIndex, xpgSize, nspace = STATIC_LIST_SIZE; + int objIndex, xpgSize, nspace = numVars; + int *nassign = (int *) TclStackAlloc(interp, nspace * sizeof(int)); char buf[TCL_UTF_MAX+1]; /* @@ -273,10 +271,6 @@ ValidateFormat( * is multiply assigned or left unassigned. */ - if (numVars > nspace) { - nassign = (int*)ckalloc(sizeof(int) * numVars); - nspace = numVars; - } for (i = 0; i < nspace; i++) { nassign[i] = 0; } @@ -475,16 +469,10 @@ ValidateFormat( if (xpgSize) { nspace = xpgSize; } else { - nspace += STATIC_LIST_SIZE; - } - if (nassign == staticAssign) { - nassign = (void *) ckalloc(nspace * sizeof(int)); - memcpy((void *) nassign, (void *) staticAssign, - sizeof(staticAssign)); - } else { - nassign = (void *) ckrealloc((void *)nassign, - nspace * sizeof(int)); + nspace += 16; /* formerly STATIC_LIST_SIZE */ } + nassign = (int *) TclStackRealloc(interp, nassign, + nspace * sizeof(int)); for (i = value; i < nspace; i++) { nassign[i] = 0; } @@ -527,9 +515,7 @@ ValidateFormat( } } - if (nassign != staticAssign) { - ckfree((char *)nassign); - } + TclStackFree(interp, nassign); return TCL_OK; badIndex: @@ -543,11 +529,8 @@ ValidateFormat( } error: - if (nassign != staticAssign) { - ckfree((char *)nassign); - } + TclStackFree(interp, nassign); return TCL_ERROR; -#undef STATIC_LIST_SIZE } /* diff --git a/generic/tclVar.c b/generic/tclVar.c index b42808f..64b4617 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.135.2.2 2007/06/21 16:04:57 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.135.2.3 2007/06/25 18:53:31 dgp Exp $ */ #include "tclInt.h" @@ -61,7 +61,7 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, const char *varName, Tcl_Obj *handleObj); static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, const char *part1, - const char *part2, int flags); + const char *part2, int flags, int reachable); static int SetArraySearchObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* @@ -1998,7 +1998,7 @@ TclObjUnsetVar2( varPtr->refCount++; - UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags); + UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags, 1); /* * It's an error to unset an undefined variable. @@ -2060,39 +2060,23 @@ UnsetVarStruct( Var *arrayPtr, Interp *iPtr, const char *part1, /* NULL if it is to be computed on demand, only for - * namespace vars */ + * variables in a hashtable */ const char *part2, - int flags) + int flags, + int reachable) /* indicates if the variable is accessible by name */ { Var dummyVar; Var *dummyVarPtr; ActiveVarTrace *activePtr; Tcl_Obj *part1Ptr = NULL; + int traced = !TclIsVarUntraced(varPtr) + || (arrayPtr && !TclIsVarUntraced(arrayPtr)); - if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) { + if (arrayPtr && arrayPtr->searchPtr) { DeleteSearches(arrayPtr); } /* - * For global/upvar variables referenced in procedures, decrement the - * reference count on the variable referred to, and free the referenced - * variable if it's no longer needed. - */ - - if (TclIsVarLink(varPtr)) { - Var *linkPtr = varPtr->value.linkPtr; - linkPtr->refCount--; - if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) - && (linkPtr->tracePtr == NULL) - && (linkPtr->flags & VAR_IN_HASHTABLE)) { - if (linkPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(linkPtr->hPtr); - } - ckfree((char *) linkPtr); - } - } - - /* * The code below is tricky, because of the possibility that a trace * function might try to access a variable being deleted. To handle this * situation gracefully, do things in three steps: @@ -2104,13 +2088,17 @@ UnsetVarStruct( * gotten recreated by a trace). */ - dummyVar = *varPtr; - dummyVarPtr = &dummyVar; - TclSetVarUndefined(varPtr); - TclSetVarScalar(varPtr); - varPtr->value.objPtr = NULL; /* dummyVar points to any value object */ - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; + if (reachable && (traced || TclIsVarArray(varPtr))) { + dummyVar = *varPtr; + dummyVarPtr = &dummyVar; + TclSetVarUndefined(varPtr); + TclSetVarScalar(varPtr); + varPtr->value.objPtr = NULL; /* dummyVar points to any value object */ + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + } else { + dummyVarPtr = varPtr; + } /* * Call trace functions for the variable being deleted. Then delete its @@ -2122,27 +2110,26 @@ UnsetVarStruct( * call unset traces even if other traces are pending. */ - if ((dummyVar.tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + if (traced) { /* * Get the variable's name if NULL was passed; */ if (part1 == NULL) { - Tcl_Interp *interp = dummyVar.nsPtr->interp; + Tcl_Interp *interp = (Tcl_Interp *) iPtr; TclNewObj(part1Ptr); Tcl_IncrRefCount(part1Ptr); Tcl_GetVariableFullName(interp, (Tcl_Var) dummyVarPtr, part1Ptr); part1 = TclGetString(part1Ptr); } - dummyVar.flags &= ~VAR_TRACE_ACTIVE; + dummyVarPtr->flags &= ~VAR_TRACE_ACTIVE; TclCallVarTraces(iPtr, arrayPtr, dummyVarPtr, part1, part2, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0); - while (dummyVar.tracePtr != NULL) { - VarTrace *tracePtr = dummyVar.tracePtr; - dummyVar.tracePtr = tracePtr->nextPtr; + while (dummyVarPtr->tracePtr != NULL) { + VarTrace *tracePtr = dummyVarPtr->tracePtr; + dummyVarPtr->tracePtr = tracePtr->nextPtr; Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; @@ -2151,37 +2138,57 @@ UnsetVarStruct( activePtr->nextTracePtr = NULL; } } + if (part1Ptr) { + Tcl_DecrRefCount(part1Ptr); + } } - /* - * If the variable is an array, delete all of its elements. This must be - * done after calling the traces on the array, above (that's the way - * traces are defined). If it is a scalar, "discard" its object (decrement - * the ref count of its object, if any). - */ - - if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) { + if (TclIsVarScalar(dummyVarPtr) + && (dummyVarPtr->value.objPtr != NULL)) { /* - * If the array is traced, its name is already in part1. If not, and - * the name is required for some element, it will be computed at - * DeleteArray. + * Decrement the ref count of the var's value */ - DeleteArray(iPtr, part1, dummyVarPtr, (flags - & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) - | TCL_TRACE_UNSETS); - - /* - * Decr ref count - */ - } - if (TclIsVarScalar(dummyVarPtr) - && (dummyVarPtr->value.objPtr != NULL)) { Tcl_Obj *objPtr = dummyVarPtr->value.objPtr; TclDecrRefCount(objPtr); dummyVarPtr->value.objPtr = NULL; + } else if (TclIsVarLink(varPtr)) { + /* + * For global/upvar variables referenced in procedures, decrement the + * reference count on the variable referred to, and free the + * referenced variable if it's no longer needed. + */ + Var *linkPtr = varPtr->value.linkPtr; + linkPtr->refCount--; + if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) + && (linkPtr->tracePtr == NULL) + && (linkPtr->flags & VAR_IN_HASHTABLE)) { + if (linkPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(linkPtr->hPtr); + } + ckfree((char *) linkPtr); + } + } else if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) { + /* + * If the variable is an array, delete all of its elements. This must + * be done after calling the traces on the array, above (that's the + * way traces are defined). If the array is traced, its name is + * already in part1. If not, and the name is required for some + * element, it will be computed at DeleteArray. + */ + + DeleteArray(iPtr, part1, dummyVarPtr, (flags + & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + | TCL_TRACE_UNSETS); } + if (dummyVarPtr == varPtr) { + TclSetVarUndefined(varPtr); + TclSetVarScalar(varPtr); + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + } + /* * If the variable was a namespace variable, decrement its reference * count. @@ -2191,9 +2198,6 @@ UnsetVarStruct( TclClearVarNamespaceVar(varPtr); varPtr->refCount--; } - if (part1Ptr) { - Tcl_DecrRefCount(part1Ptr); - } } /* @@ -4094,7 +4098,7 @@ TclDeleteNamespaceVars( hPtr = Tcl_FirstHashEntry(tablePtr, &search)) { register Var *varPtr = (Var *) Tcl_GetHashValue(hPtr); varPtr->refCount++; /* Make sure we get to remove from hash */ - UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ NULL, NULL, flags); + UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ NULL, NULL, flags, 1); varPtr->refCount--; /* @@ -4146,12 +4150,9 @@ TclDeleteVars( Tcl_HashSearch search; Tcl_HashEntry *hPtr; register Var *varPtr; - Var *linkPtr; int flags; - ActiveVarTrace *activePtr; - Tcl_Obj *objPtr; Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - + /* * Determine what flags to pass to the trace callback functions. */ @@ -4167,84 +4168,8 @@ TclDeleteVars( hPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(hPtr); - /* - * For global/upvar variables referenced in procedures, decrement the - * reference count on the variable referred to, and free the - * referenced variable if it's no longer needed. Don't delete the hash - * entry for the other variable if it's in the same table as us: this - * will happen automatically later on. - */ - - if (TclIsVarLink(varPtr)) { - linkPtr = varPtr->value.linkPtr; - linkPtr->refCount--; - if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) - && (linkPtr->tracePtr == NULL) - && (linkPtr->flags & VAR_IN_HASHTABLE)) { - if (linkPtr->hPtr == NULL) { - ckfree((char *) linkPtr); - } else if (linkPtr->hPtr->tablePtr != tablePtr) { - Tcl_DeleteHashEntry(linkPtr->hPtr); - ckfree((char *) linkPtr); - } - } - } - - /* - * Invoke traces on the variable that is being deleted, then free up - * the variable's space (no need to free the hash entry here, unless - * we're dealing with a global variable: the hash entries will be - * deleted automatically when the whole table is deleted). Note that - * we give TclCallVarTraces the variable's fully-qualified name so - * that any called trace functions can refer to these variables being - * deleted. - */ - - if (varPtr->tracePtr != NULL) { - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); /* until done with traces */ - Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); - TclCallVarTraces(iPtr, NULL, varPtr, TclGetString(objPtr), NULL, - flags, /* leaveErrMsg */ 0); - TclDecrRefCount(objPtr); /* free no longer needed obj */ - - while (varPtr->tracePtr != NULL) { - VarTrace *tracePtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr->nextPtr; - Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); - } - for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { - if (activePtr->varPtr == varPtr) { - activePtr->nextTracePtr = NULL; - } - } - } - - if (TclIsVarArray(varPtr)) { - DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags); - varPtr->value.tablePtr = NULL; - } - if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { - objPtr = varPtr->value.objPtr; - TclDecrRefCount(objPtr); - varPtr->value.objPtr = NULL; - } + UnsetVarStruct(varPtr, NULL, iPtr, NULL, NULL, flags, 0); varPtr->hPtr = NULL; - varPtr->tracePtr = NULL; - TclSetVarUndefined(varPtr); - TclSetVarScalar(varPtr); - - /* - * If the variable was a namespace variable, decrement its reference - * count. We are in the process of destroying its namespace so that - * namespace will no longer "refer" to the variable. - */ - - if (TclIsVarNamespaceVar(varPtr)) { - TclClearVarNamespaceVar(varPtr); - varPtr->refCount--; - } /* * Recycle the variable's memory space if there aren't any upvar's @@ -4288,77 +4213,78 @@ TclDeleteCompiledLocalVars( * assigned local variables to delete. */ { register Var *varPtr; - int flags; /* Flags passed to trace functions. */ - Var *linkPtr; - ActiveVarTrace *activePtr; int numLocals, i; - flags = TCL_TRACE_UNSETS; numLocals = framePtr->numCompiledLocals; varPtr = framePtr->compiledLocals; for (i=0 ; ivalue.linkPtr; - linkPtr->refCount--; - if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) - && (linkPtr->tracePtr == NULL) - && (linkPtr->flags & VAR_IN_HASHTABLE)) { - if (linkPtr->hPtr == NULL) { - ckfree((char *) linkPtr); - } else { - Tcl_DeleteHashEntry(linkPtr->hPtr); - ckfree((char *) linkPtr); - } +#if 1 + UnsetVarStruct(varPtr, NULL, iPtr, varPtr->name, NULL, TCL_TRACE_UNSETS, 0); + varPtr++; +#else + if (!TclIsVarUntraced(varPtr)) { + ActiveVarTrace *activePtr; + + varPtr->flags &= ~VAR_TRACE_ACTIVE; + TclCallVarTraces(iPtr, NULL, varPtr, varPtr->name, NULL, + TCL_TRACE_UNSETS, /* leaveErrMsg */ 0); + while (varPtr->tracePtr != NULL) { + VarTrace *tracePtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr->nextPtr; + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); + } + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; } } + } + if (TclIsVarScalar(varPtr) + && (varPtr->value.objPtr != NULL)) { /* - * Invoke traces on the variable that is being deleted. Then delete - * the variable's trace records. + * Decrement the ref count of the var's value */ - - if (varPtr->tracePtr != NULL) { - TclCallVarTraces(iPtr, NULL, varPtr, varPtr->name, NULL, flags, - /* leaveErrMsg */ 0); - while (varPtr->tracePtr != NULL) { - VarTrace *tracePtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr->nextPtr; - Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); - } - for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { - if (activePtr->varPtr == varPtr) { - activePtr->nextTracePtr = NULL; - } + + Tcl_Obj *objPtr = varPtr->value.objPtr; + TclDecrRefCount(objPtr); + varPtr->value.objPtr = NULL; + } else if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + /* + * If the variable is an array, delete all of its elements. This must + * be done after calling the traces on the array, above (that's the + * way traces are defined). If the array is traced, its name is + * already in part1. If not, and the name is required for some + * element, it will be computed at DeleteArray. + */ + + DeleteArray(iPtr, varPtr->name, varPtr, TCL_TRACE_UNSETS); + } else if (TclIsVarLink(varPtr)) { + /* + * For global/upvar variables referenced in procedures, decrement the + * reference count on the variable referred to, and free the + * referenced variable if it's no longer needed. + */ + Var *linkPtr = varPtr->value.linkPtr; + linkPtr->refCount--; + if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) + && (linkPtr->tracePtr == NULL) + && (linkPtr->flags & VAR_IN_HASHTABLE)) { + if (linkPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(linkPtr->hPtr); } + ckfree((char *) linkPtr); } + } - /* - * Now if the variable is an array, delete its element hash table. - * Otherwise, if it's a scalar variable, decrement the ref count of - * its value. - */ + TclSetVarUndefined(varPtr); + TclSetVarScalar(varPtr); + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; - if (TclIsVarArray(varPtr) && (varPtr->value.tablePtr != NULL)) { - DeleteArray(iPtr, varPtr->name, varPtr, flags); - } - if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { - TclDecrRefCount(varPtr->value.objPtr); - varPtr->value.objPtr = NULL; - } - varPtr->hPtr = NULL; - varPtr->tracePtr = NULL; - TclSetVarUndefined(varPtr); - TclSetVarScalar(varPtr); - varPtr++; + varPtr++; +#endif } } diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index be3b162..100df93 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacOSXNotify.c,v 1.14 2007/04/23 20:46:14 das Exp $ + * RCS: @(#) $Id: tclMacOSXNotify.c,v 1.14.2.1 2007/06/25 18:53:31 dgp Exp $ */ #include "tclInt.h" @@ -319,6 +319,21 @@ static void AtForkChild(void); extern int pthread_atfork(void (*prepare)(void), void (*parent)(void), void (*child)(void)) WEAK_IMPORT_ATTRIBUTE; #endif /* HAVE_WEAK_IMPORT */ +#ifdef __LP64__ +/* + * On 64bit Darwin 9 and later, it is not possible to call CoreFoundation after + * a fork. + */ +#if !defined(MAC_OS_X_VERSION_MIN_REQUIRED) || + MAC_OS_X_VERSION_MIN_REQUIRED < 1050 +MODULE_SCOPE long tclMacOSXDarwinRelease; +#define noCFafterFork (tclMacOSXDarwinRelease >= 9) +#else /* MAC_OS_X_VERSION_MIN_REQUIRED */ +#define noCFafterFork 1 +#endif /* MAC_OS_X_VERSION_MIN_REQUIRED */ +#else /* __LP64__ */ +#define noCFafterFork 0 +#endif /* __LP64__ */ #endif /* HAVE_PTHREAD_ATFORK */ /* @@ -1314,7 +1329,9 @@ AtForkChild(void) UNLOCK_NOTIFIER_INIT; if (tsdPtr->runLoop) { tsdPtr->runLoop = NULL; - CFRunLoopSourceInvalidate(tsdPtr->runLoopSource); + if (!noCFafterFork) { + CFRunLoopSourceInvalidate(tsdPtr->runLoopSource); + } CFRelease(tsdPtr->runLoopSource); tsdPtr->runLoopSource = NULL; } @@ -1330,7 +1347,9 @@ AtForkChild(void) * Tcl_AlertNotifier may break in the child. */ - Tcl_InitNotifier(); + if (!noCFafterFork) { + Tcl_InitNotifier(); + } } } #endif /* HAVE_PTHREAD_ATFORK */ diff --git a/tests/trace.test b/tests/trace.test index 6cc492e..efb60f0 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: trace.test,v 1.51.2.3 2007/06/15 20:30:23 dgp Exp $ +# RCS: @(#) $Id: trace.test,v 1.51.2.4 2007/06/25 18:53:32 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -2494,7 +2494,7 @@ set base { set ::tracevar } -result {$r} } -runbase {- -* - -} $base +runbase {- - - -} $base set base { test trace-37.$n {dynamic trace addition: $t} -setup { -- cgit v0.12