Index: ChangeLog.2008 ================================================================== --- ChangeLog.2008 +++ ChangeLog.2008 @@ -1808,10 +1808,19 @@ 2008-08-05 Miguel Sofer * generic/tclExecute.c: Fix for [Bug 2038069] by dgp. * tests/execute.test: + +2008-08-04 Don Porter S + + [dgp-refactor branch] + + * generic/tclBasic.c: Move toplevel exception handling code into + TclEvalScriptTokens where the right data is available to construct + the stack trace, and out of callers which lacked that data. Fixes + long failing basic-46.* tests. 2008-08-04 Miguel Sofer * tests/nre.test: Added tests for [if], [while] and [for]. A test for [foreach] has been added and marked as knownbug, awaiting for it Index: generic/tclAssembly.c ================================================================== --- generic/tclAssembly.c +++ generic/tclAssembly.c @@ -941,11 +941,11 @@ int TclCompileAssembleCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ + * created by TclParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; /* Token in the input script */ @@ -976,11 +976,11 @@ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s\" body, line %d)", parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, Tcl_GetErrorLine(interp))); - envPtr->numCommands = numCommands; + TclDisposeFailedCompile(envPtr, numCommands); envPtr->codeNext = envPtr->codeStart + offset; envPtr->currStackDepth = depth; TclCompileSyntaxError(interp, envPtr); } return TCL_OK; @@ -1032,11 +1032,12 @@ do { /* * Parse out one command line from the assembly script. */ - status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); + status = TclParseCommand(interp, instPtr, bytesLeft, + PARSE_USE_INTERNAL_TOKENS, parsePtr); /* * Report errors in the parse. */ Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -4412,11 +4412,408 @@ * evaluate and concatenate. */ int count) /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, - NULL, NULL); + NULL, NULL, 0); +} + +/* + *---------------------------------------------------------------------- + * + * TclEvalScriptTokens -- + * + * + * Results: + * + * Side effects: + * + * TIP #280 : Keep public API, internally extended API. + *---------------------------------------------------------------------- + */ + +int +TclEvalScriptTokens( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + int length, + int flags, + int line, + int* clNextOuter, /* Information about an outer context for */ + const char* outerScript) /* continuation line data. This is set only in + * TclSubstTokens(), to properly handle + * [...]-nested commands. The 'outerScript' + * refers to the most-outer script containing + * the embedded command, which is refered to + * by 'script'. The 'clNextOuter' refers to + * the current entry in the table of + * continuation lines in this "master script", + * and the character offsets are relative to + * the 'outerScript' as well. + * + * If outerScript == script, then this call is + * for the outer-most script/command. See + * Tcl_EvalEx() and TclEvalObjEx() for places + * generating arguments for which this is true. + */ +{ + int numCommands = tokenPtr->numComponents; + Tcl_Token *scriptTokenPtr = tokenPtr; + Interp *iPtr = (Interp *) interp; + int code = TCL_OK; + unsigned int objLength = 20; + int *expand, *expandStack, *lines, *lineSpace, *linesStack; + Tcl_Obj **objvSpace, **stackObjArray; + const char *cmdString = scriptTokenPtr->start; + int cmdSize = scriptTokenPtr->size; + CmdFrame *eeFramePtr; /* TIP #280 Structures for tracking of command + * locations. */ + int allowExceptions = 1; + int *clNext = NULL; /* Pointer for the tracking of invisible + * continuation lines. Initialized only if the + * caller gave us a table of locations to + * track, via scriptCLLocPtr. It always refers + * to the table entry holding the location of + * the next invisible continuation line to + * look for, while parsing the script. */ + + if (iPtr->scriptCLLocPtr) { + if (clNextOuter) { + clNext = clNextOuter; + } else { + clNext = &iPtr->scriptCLLocPtr->loc[0]; + } + } + + if (iPtr->numLevels == 0) { + allowExceptions = iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS; + } + + if (length == 0) { + Tcl_Panic("EvalScriptTokens: can't eval zero tokens"); + } + if (tokenPtr->type != TCL_TOKEN_SCRIPT) { + Tcl_Panic("EvalScriptTokens: invalid token array, expected script"); + } + tokenPtr++; length--; + if (numCommands) { + TclAdvanceLines(&line, scriptTokenPtr->start, tokenPtr->start); + TclAdvanceContinuations(&line, &clNext, tokenPtr->start - outerScript); + } + + if (length == 0) { + return TclInterpReady(interp); + } + + /* + * TIP #280 Initialize tracking. Do not push on the frame stack yet. + * + * We open a new context, either for a sourced script, or 'eval'. + * For sourced files we always have a path object, even if nothing was + * specified in the interp itself. That makes code using it simpler as + * NULL checks can be left out. Sourced file without path in the + * 'scriptFile' is possible during Tcl initialization. + */ + + eeFramePtr = TclStackAlloc(interp, sizeof(CmdFrame)); + if (iPtr->evalFlags & TCL_EVAL_FILE) { + /* + * Set up for a sourced file. + */ + + eeFramePtr->type = TCL_LOCATION_SOURCE; + + if (iPtr->scriptFile) { + /* + * Normalization here, to have the correct pwd. Should have + * negligible impact on performance, as the norm should have been + * done already by the 'source' invoking us, and it caches the + * result. + */ + + Tcl_Obj *norm = Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile); + + if (norm == NULL) { + /* + * Error message in the interp result. + */ + TclStackFree(interp, eeFramePtr); + return TCL_ERROR; + } + eeFramePtr->data.eval.path = norm; + } else { + TclNewLiteralStringObj(eeFramePtr->data.eval.path, ""); + } + Tcl_IncrRefCount(eeFramePtr->data.eval.path); + } else { + /* + * Set up for plain eval. + */ + + eeFramePtr->type = TCL_LOCATION_EVAL; + eeFramePtr->data.eval.path = NULL; + } + + eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; + eeFramePtr->framePtr = iPtr->framePtr; + eeFramePtr->nextPtr = iPtr->cmdFramePtr; + eeFramePtr->nline = 0; + eeFramePtr->line = NULL; + eeFramePtr->cmdObj = NULL; + + iPtr->cmdFramePtr = eeFramePtr; + iPtr->evalFlags = 0; + objvSpace = stackObjArray = + TclStackAlloc(interp, objLength * sizeof(Tcl_Obj *)); + expand = expandStack = + TclStackAlloc(interp, objLength * sizeof(int)); + lineSpace = linesStack = + TclStackAlloc(interp, objLength * sizeof(int)); + while (numCommands-- && (code == TCL_OK)) { + unsigned int objc, expandRequested = 0; + unsigned int objectsNeeded = 0; + unsigned int numWords = tokenPtr->numComponents; + Tcl_Obj **objv; + Tcl_Token *commandTokenPtr = tokenPtr; + + /* + * TIP #280. Track lines within the words of the current command. + * We use a separate pointer into the table of continuation line + * locations to not lose our position for the per-command parsing. + */ + + int wordLine = line; + const char *wordStart = commandTokenPtr->start; + int *wordCLNext = clNext; + + if (length == 0) { + Tcl_Panic("EvalScriptTokens: overran token array"); + } + if (tokenPtr->type != TCL_TOKEN_CMD) { + Tcl_Panic("EvalScriptTokens: invalid token array, expected cmd"); + } + tokenPtr++; length--; + + if (numWords == 0) continue; + if (numWords > objLength) { + if (expand != expandStack) { + ckfree(expand); + } + expand = ckalloc(numWords * sizeof(int)); + if (objvSpace != stackObjArray) { + ckfree(objvSpace); + } + objvSpace = ckalloc(numWords * sizeof(Tcl_Obj *)); + if (lineSpace != linesStack) { + ckfree(lineSpace); + } + lineSpace = ckalloc(numWords * sizeof(int)); + objLength = numWords; + } + + objv = objvSpace; + lines = lineSpace; + iPtr->cmdFramePtr = eeFramePtr->nextPtr; + for (objc = 0; objc < numWords; + objc++, length -= (tokenPtr->numComponents + 1), + tokenPtr += tokenPtr->numComponents+1) { + if (length == 0) { + Tcl_Panic("EvalScriptTokens: overran token array"); + } + if (!(tokenPtr->type & (TCL_TOKEN_WORD + | TCL_TOKEN_SIMPLE_WORD | TCL_TOKEN_EXPAND_WORD))) { + Tcl_Panic("EvalScriptTokens: invalid token array, expected word: %d: %.*s", tokenPtr->type, tokenPtr->size, tokenPtr->start); + } + if (length < tokenPtr->numComponents + 1) { + Tcl_Panic("EvalScriptTokens: overran token array"); + } + + /* + * TIP #280. Track lines to current word. Save the information + * on a per-word basis, signaling dynamic words as needed. + * Make the information available to the recursively called + * evaluator as well, including the type of context (source + * vs. eval). + */ + + TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); + TclAdvanceContinuations (&wordLine, &wordCLNext, + tokenPtr->start - outerScript); + wordStart = tokenPtr->start; + + lines[objc] = TclWordKnownAtCompileTime(tokenPtr, NULL) + ? wordLine : -1; + + if (eeFramePtr->type == TCL_LOCATION_SOURCE) { + iPtr->evalFlags |= TCL_EVAL_FILE; + } + + code = TclSubstTokens(interp, tokenPtr+1, tokenPtr->numComponents, + NULL, wordLine, wordCLNext, outerScript, flags); + + iPtr->evalFlags = 0; + + if (code != TCL_OK) { + break; + } + objv[objc] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(objv[objc]); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + int numElements; + + code = TclListObjLength(interp, objv[objc], &numElements); + if (code == TCL_ERROR) { + /* + * Attempt to expand a non-list + */ + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (expanding word %d)", objc)); + objc++; + break; + } + expandRequested = 1; + expand[objc] = 1; + objectsNeeded += (numElements ? numElements : 1); + } else { + expand[objc] = 0; + objectsNeeded++; + } + + if (wordCLNext) { + TclContinuationsEnterDerived (objv[objc], + wordStart - outerScript, wordCLNext); + } + } + iPtr->cmdFramePtr = eeFramePtr; + if (code != TCL_OK) { + goto error; + } + if (expandRequested) { + /* Some word expansion was requested. Check for objv resize */ + Tcl_Obj **copy = objvSpace; + int *lcopy = lineSpace; + int wordIdx = numWords; + int objIdx = objectsNeeded - 1; + int inPlaceCopy = 1; + + if (objectsNeeded > objLength) { + inPlaceCopy = 0; + objv = objvSpace = ckalloc(objectsNeeded * sizeof(Tcl_Obj*)); + lines = lineSpace = ckalloc(objectsNeeded * sizeof (int)); + } + + objc = 0; + while (wordIdx--) { + if (expand[wordIdx]) { + int numElements; + Tcl_Obj **elements, *temp = copy[wordIdx]; + Tcl_ListObjGetElements(NULL, temp, &numElements, + &elements); + objc += numElements; + while (numElements--) { + lines[objIdx] = -1; + objv[objIdx--] = elements[numElements]; + Tcl_IncrRefCount(elements[numElements]); + } + Tcl_DecrRefCount(temp); + } else { + lines[objIdx] = lcopy[wordIdx]; + objv[objIdx--] = copy[wordIdx]; + objc++; + } + } + objv += objIdx+1; + + if (!inPlaceCopy && (copy != stackObjArray)) { + ckfree(copy); + ckfree(lcopy); + } + } + + /* + * Execute the command and free the objects for its words. + * + * TIP #280: Remember the command itself for 'info frame'. + * Here is where we put our frame on the stack of frames too. + * _After_ the nested commands have been executed. + */ + + eeFramePtr->cmd = commandTokenPtr->start; + eeFramePtr->len = commandTokenPtr->size; + eeFramePtr->nline = objc; + eeFramePtr->line = lines; + + TclArgumentEnter(interp, objv, objc, eeFramePtr); + code = Tcl_EvalObjv(interp, objc, objv, + flags|TCL_EVAL_NOERR|TCL_EVAL_SOURCE_IN_FRAME); + TclArgumentRelease(interp, objv, objc); + + eeFramePtr->line = NULL; + eeFramePtr->nline = 0; + if (eeFramePtr->cmdObj) { + Tcl_DecrRefCount(eeFramePtr->cmdObj); + eeFramePtr->cmdObj = NULL; + } + + error: + while (objc > 0) { + Tcl_DecrRefCount(objv[--objc]); + } + cmdString = commandTokenPtr->start; + cmdSize = commandTokenPtr->size; + + /* + * TIP #280 Track Lines. Now we track how many lines were in the + * executed command. + */ + + if (numCommands) { + TclAdvanceLines(&line, commandTokenPtr->start, tokenPtr->start); + } + } + if (length && (code == TCL_OK)) { + code = TclSubstTokens(interp, tokenPtr, length, NULL, line, clNext, + outerScript, flags); + } + if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_LogCommandInfo(interp, scriptTokenPtr->start, cmdString, cmdSize); + } + iPtr->flags &= ~ERR_ALREADY_LOGGED; + if (lineSpace != linesStack) { + ckfree(lineSpace); + } + TclStackFree(interp, linesStack); + if (expand != expandStack) { + ckfree(expand); + } + TclStackFree(interp, expandStack); + if (objvSpace != stackObjArray) { + ckfree(objvSpace); + } + TclStackFree(interp, stackObjArray); + + if (iPtr->numLevels == 0) { + if (code == TCL_RETURN) { + code = TclUpdateReturnInfo(iPtr); + } + if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { + ProcessUnexpectedResult(interp, code); + code = TCL_ERROR; + Tcl_LogCommandInfo(interp, scriptTokenPtr->start, + cmdString, cmdSize); + } + } + /* + * TIP #280. Release the local CmdFrame, and its contents. + */ + + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + if (eeFramePtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(eeFramePtr->data.eval.path); + } + TclStackFree(interp, eeFramePtr); + return code; } /* *---------------------------------------------------------------------- * @@ -4458,455 +4855,40 @@ Tcl_Interp *interp, /* Interpreter in which to evaluate the * script. Also used for error reporting. */ const char *script, /* First character of script to evaluate. */ int numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the - * first NUL character. */ - int flags, /* Collection of OR-ed bits that control the - * evaluation of the script. Only - * TCL_EVAL_GLOBAL is currently supported. */ + * first null character. */ + int flags, /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently + * supported. */ int line, /* The line the script starts on. */ - int *clNextOuter, /* Information about an outer context for */ - const char *outerScript) /* continuation line data. This is set only in - * TclSubstTokens(), to properly handle - * [...]-nested commands. The 'outerScript' - * refers to the most-outer script containing - * the embedded command, which is refered to - * by 'script'. The 'clNextOuter' refers to - * the current entry in the table of - * continuation lines in this "master script", - * and the character offsets are relative to - * the 'outerScript' as well. - * - * If outerScript == script, then this call is - * for the outer-most script/command. See - * Tcl_EvalEx() and TclEvalObjEx() for places - * generating arguments for which this is - * true. */ -{ - Interp *iPtr = (Interp *) interp; - const char *p, *next; - const unsigned int minObjs = 20; - Tcl_Obj **objv, **objvSpace; - int *expand, *lines, *lineSpace; - Tcl_Token *tokenPtr; - int commandLength, bytesLeft, expandRequested, code = TCL_OK; - 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; - 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 = TclStackAlloc(interp, sizeof(Tcl_Parse)); - CmdFrame *eeFramePtr = TclStackAlloc(interp, sizeof(CmdFrame)); - Tcl_Obj **stackObjArray = - TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *)); - int *expandStack = TclStackAlloc(interp, minObjs * sizeof(int)); - int *linesStack = TclStackAlloc(interp, minObjs * sizeof(int)); - /* TIP #280 Structures for tracking of command - * locations. */ - int *clNext = NULL; /* Pointer for the tracking of invisible - * continuation lines. Initialized only if the - * caller gave us a table of locations to - * track, via scriptCLLocPtr. It always refers - * to the table entry holding the location of - * the next invisible continuation line to - * look for, while parsing the script. */ - - if (iPtr->scriptCLLocPtr) { - if (clNextOuter) { - clNext = clNextOuter; - } else { - clNext = &iPtr->scriptCLLocPtr->loc[0]; - } - } - - if (numBytes < 0) { - numBytes = strlen(script); - } - Tcl_ResetResult(interp); - - savedVarFramePtr = iPtr->varFramePtr; - if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = iPtr->rootFramePtr; - } - - /* - * Each iteration through the following loop parses the next command from - * the script and then executes it. - */ - - objv = objvSpace = stackObjArray; - lines = lineSpace = linesStack; - expand = expandStack; - p = script; - bytesLeft = numBytes; - - /* - * TIP #280 Initialize tracking. Do not push on the frame stack yet. - * - * We open a new context, either for a sourced script, or 'eval'. - * For sourced files we always have a path object, even if nothing was - * specified in the interp itself. That makes code using it simpler as - * NULL checks can be left out. Sourced file without path in the - * 'scriptFile' is possible during Tcl initialization. - */ - - eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; - eeFramePtr->framePtr = iPtr->framePtr; - eeFramePtr->nextPtr = iPtr->cmdFramePtr; - eeFramePtr->nline = 0; - eeFramePtr->line = NULL; - eeFramePtr->cmdObj = NULL; - - iPtr->cmdFramePtr = eeFramePtr; - if (iPtr->evalFlags & TCL_EVAL_FILE) { - /* - * Set up for a sourced file. - */ - - eeFramePtr->type = TCL_LOCATION_SOURCE; - - if (iPtr->scriptFile) { - /* - * Normalization here, to have the correct pwd. Should have - * negligible impact on performance, as the norm should have been - * done already by the 'source' invoking us, and it caches the - * result. - */ - - Tcl_Obj *norm = Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile); - - if (norm == NULL) { - /* - * Error message in the interp result. - */ - - code = TCL_ERROR; - goto error; - } - eeFramePtr->data.eval.path = norm; - } else { - TclNewLiteralStringObj(eeFramePtr->data.eval.path, ""); - } - Tcl_IncrRefCount(eeFramePtr->data.eval.path); - } else { - /* - * Set up for plain eval. - */ - - eeFramePtr->type = TCL_LOCATION_EVAL; - eeFramePtr->data.eval.path = NULL; - } - - iPtr->evalFlags = 0; - do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { - code = TCL_ERROR; - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - parsePtr->term + 1 - parsePtr->commandStart); - goto posterror; - } - - /* - * TIP #280 Track lines. The parser may have skipped text till it - * found the command we are now at. We have to count the lines in this - * block, and do not forget invisible continuation lines. - */ - - TclAdvanceLines(&line, p, parsePtr->commandStart); - TclAdvanceContinuations(&line, &clNext, - parsePtr->commandStart - outerScript); - - gotParse = 1; - if (parsePtr->numWords > 0) { - /* - * TIP #280. Track lines within the words of the current - * command. We use a separate pointer into the table of - * continuation line locations to not lose our position for the - * per-command parsing. - */ - - int wordLine = line; - const char *wordStart = parsePtr->commandStart; - int *wordCLNext = clNext; - unsigned int objectsNeeded = 0; - unsigned int numWords = parsePtr->numWords; - - /* - * Generate an array of objects for the words of the command. - */ - - if (numWords > minObjs) { - expand = ckalloc(numWords * sizeof(int)); - objvSpace = ckalloc(numWords * sizeof(Tcl_Obj *)); - lineSpace = ckalloc(numWords * sizeof(int)); - } - expandRequested = 0; - objv = objvSpace; - lines = lineSpace; - - iPtr->cmdFramePtr = eeFramePtr->nextPtr; - for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr; - objectsUsed < numWords; - objectsUsed++, tokenPtr += tokenPtr->numComponents+1) { - /* - * TIP #280. Track lines to current word. Save the information - * on a per-word basis, signaling dynamic words as needed. - * Make the information available to the recursively called - * evaluator as well, including the type of context (source - * vs. eval). - */ - - TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); - TclAdvanceContinuations(&wordLine, &wordCLNext, - tokenPtr->start - outerScript); - wordStart = tokenPtr->start; - - lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) - ? wordLine : -1; - - if (eeFramePtr->type == TCL_LOCATION_SOURCE) { - iPtr->evalFlags |= TCL_EVAL_FILE; - } - - code = TclSubstTokens(interp, tokenPtr+1, - tokenPtr->numComponents, NULL, wordLine, - wordCLNext, outerScript); - - iPtr->evalFlags = 0; - - if (code != TCL_OK) { - break; - } - objv[objectsUsed] = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(objv[objectsUsed]); - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - int numElements; - - code = TclListObjLength(interp, objv[objectsUsed], - &numElements); - if (code == TCL_ERROR) { - /* - * Attempt to expand a non-list. - */ - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (expanding word %d)", objectsUsed)); - Tcl_DecrRefCount(objv[objectsUsed]); - break; - } - expandRequested = 1; - expand[objectsUsed] = 1; - - objectsNeeded += (numElements ? numElements : 1); - } else { - expand[objectsUsed] = 0; - objectsNeeded++; - } - - if (wordCLNext) { - TclContinuationsEnterDerived(objv[objectsUsed], - wordStart - outerScript, wordCLNext); - } - } /* for loop */ - iPtr->cmdFramePtr = eeFramePtr; - if (code != TCL_OK) { - goto error; - } - if (expandRequested) { - /* - * Some word expansion was requested. Check for objv resize. - */ - - Tcl_Obj **copy = objvSpace; - int *lcopy = lineSpace; - int wordIdx = numWords; - int objIdx = objectsNeeded - 1; - - if ((numWords > minObjs) || (objectsNeeded > minObjs)) { - objv = objvSpace = - ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = ckalloc(objectsNeeded * sizeof(int)); - } - - objectsUsed = 0; - while (wordIdx--) { - if (expand[wordIdx]) { - int numElements; - Tcl_Obj **elements, *temp = copy[wordIdx]; - - Tcl_ListObjGetElements(NULL, temp, &numElements, - &elements); - objectsUsed += numElements; - while (numElements--) { - lines[objIdx] = -1; - objv[objIdx--] = elements[numElements]; - Tcl_IncrRefCount(elements[numElements]); - } - Tcl_DecrRefCount(temp); - } else { - lines[objIdx] = lcopy[wordIdx]; - objv[objIdx--] = copy[wordIdx]; - objectsUsed++; - } - } - objv += objIdx+1; - - if (copy != stackObjArray) { - ckfree(copy); - } - if (lcopy != linesStack) { - ckfree(lcopy); - } - } - - /* - * Execute the command and free the objects for its words. - * - * TIP #280: Remember the command itself for 'info frame'. We - * shorten the visible command by one char to exclude the - * termination character, if necessary. Here is where we put our - * frame on the stack of frames too. _After_ the nested commands - * have been executed. - */ - - eeFramePtr->cmd = parsePtr->commandStart; - eeFramePtr->len = parsePtr->commandSize; - - if (parsePtr->term == - parsePtr->commandStart + parsePtr->commandSize - 1) { - eeFramePtr->len--; - } - - eeFramePtr->nline = objectsUsed; - eeFramePtr->line = lines; - - TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); - code = Tcl_EvalObjv(interp, objectsUsed, objv, - TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME); - TclArgumentRelease(interp, objv, objectsUsed); - - eeFramePtr->line = NULL; - eeFramePtr->nline = 0; - if (eeFramePtr->cmdObj) { - Tcl_DecrRefCount(eeFramePtr->cmdObj); - eeFramePtr->cmdObj = NULL; - } - - if (code != TCL_OK) { - goto error; - } - for (i = 0; i < objectsUsed; i++) { - Tcl_DecrRefCount(objv[i]); - } - objectsUsed = 0; - if (objvSpace != stackObjArray) { - ckfree(objvSpace); - objvSpace = stackObjArray; - ckfree(lineSpace); - lineSpace = linesStack; - } - - /* - * Free expand separately since objvSpace could have been - * reallocated above. - */ - - if (expand != expandStack) { - ckfree(expand); - expand = expandStack; - } - } - - /* - * Advance to the next command in the script. - * - * TIP #280 Track Lines. Now we track how many lines were in the - * executed command. - */ - - next = parsePtr->commandStart + parsePtr->commandSize; - bytesLeft -= next - p; - p = next; - TclAdvanceLines(&line, parsePtr->commandStart, p); - Tcl_FreeParse(parsePtr); - gotParse = 0; - } while (bytesLeft > 0); - iPtr->varFramePtr = savedVarFramePtr; - code = TCL_OK; - goto cleanup_return; - - error: - /* - * Generate and log various pieces of error information. - */ - - if (iPtr->numLevels == 0) { - if (code == TCL_RETURN) { - code = TclUpdateReturnInfo(iPtr); - } - if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { - ProcessUnexpectedResult(interp, code); - code = TCL_ERROR; - } - } - if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - 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. - * Reduce the length by one so that the error message doesn't - * include the terminator character. - */ - - commandLength -= 1; - } - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - commandLength); - } - posterror: - iPtr->flags &= ~ERR_ALREADY_LOGGED; - - /* - * Then free resources that had been allocated to the command. - */ - - for (i = 0; i < objectsUsed; i++) { - Tcl_DecrRefCount(objv[i]); - } - if (gotParse) { - Tcl_FreeParse(parsePtr); - } - if (objvSpace != stackObjArray) { - ckfree(objvSpace); - ckfree(lineSpace); - } - if (expand != expandStack) { - ckfree(expand); - } - iPtr->varFramePtr = savedVarFramePtr; - - cleanup_return: - /* - * TIP #280. Release the local CmdFrame, and its contents. - */ - - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; - if (eeFramePtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(eeFramePtr->data.eval.path); - } - TclStackFree(interp, linesStack); - TclStackFree(interp, expandStack); - TclStackFree(interp, stackObjArray); - TclStackFree(interp, eeFramePtr); - TclStackFree(interp, parsePtr); - + int* clNextOuter, /* Information about an outer context for */ + const char* outerScript) /* continuation line data. This is set only in + * EvalTokensStandard(), to properly handle + * [...]-nested commands. The 'outerScript' + * refers to the most-outer script containing the + * embedded command, which is refered to by + * 'script'. The 'clNextOuter' refers to the + * current entry in the table of continuation + * lines in this "master script", and the + * character offsets are relative to the + * 'outerScript' as well. + * + * If outerScript == script, then this call is + * for the outer-most script/command. See + * Tcl_EvalEx() and TclEvalObjEx() for places + * generating arguments for which this is true. + */ +{ + Tcl_Token *lastTokenPtr, *tokensPtr = TclParseScript(interp, + script, numBytes, /* flags */ 0, &lastTokenPtr, NULL); + int code = TclEvalScriptTokens(interp, tokensPtr, + 1 + (int)(lastTokenPtr - tokensPtr), flags, line, + clNextOuter, outerScript); + ckfree(tokensPtr); return code; } /* *---------------------------------------------------------------------- @@ -5422,10 +5404,11 @@ const CmdFrame *invoker, /* Frame of the command doing the eval. */ int word) /* Index of the word which is in objPtr. */ { Interp *iPtr = (Interp *) interp; int result; + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); /* * This function consists of three independent blocks for: direct * evaluation of canonical lists, compilation and bytecode execution and * finally direct evaluation. Precisely one of these blocks will be run. @@ -5512,11 +5495,10 @@ * * TIP #280 The invoker provides us with the context for the script. * We transfer this to the byte code compiler. */ - int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); ByteCode *codePtr; CallFrame *savedVarFramePtr = NULL; /* Saves old copy of * iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ @@ -5539,13 +5521,11 @@ /* * We're not supposed to use the compiler or byte-code * interpreter. Let Tcl_EvalEx evaluate the command directly (and * probably more slowly). */ - - const char *script; - int numSrcBytes; + Tcl_Token *lastTokenPtr, *tokensPtr; /* * Now we check if we have data about invisible continuation lines for * the script, and make it available to the direct script parser and * evaluator we are about to call, if so. @@ -5561,21 +5541,25 @@ * continuation line information of the caller, in case we are * executing nested commands in the eval/direct path. */ ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; + Tcl_Obj *copyPtr = TclTokensCopy(objPtr); assert(invoker == NULL); iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); Tcl_IncrRefCount(objPtr); - script = TclGetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + tokensPtr = TclGetTokensFromObj(copyPtr, &lastTokenPtr); + result = TclEvalScriptTokens(interp, tokensPtr, + 1 + (int)(lastTokenPtr - tokensPtr), flags, 1, NULL, + tokensPtr[0].start); - TclDecrRefCount(objPtr); + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(copyPtr); iPtr->scriptCLLocPtr = saveCLLocPtr; return result; } } @@ -5988,13 +5972,11 @@ * name of the command to invoke. */ int flags) /* Combination of flags controlling the call: * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { - if (interp == NULL) { - return TCL_ERROR; - } + /* make whole thing a call to Tcl_EvalObjv */ if ((objc < 1) || (objv == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal argument vector", -1)); return TCL_ERROR; } ADDED generic/tclBrodnik.c Index: generic/tclBrodnik.c ================================================================== --- /dev/null +++ generic/tclBrodnik.c @@ -0,0 +1,293 @@ +/* + * tclBrodnik.c -- + * + * This file contains the implementation of a BrodnikArray. + * + * Contributions from Don Porter, NIST, 2013. (not subject to US copyright) + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclBrodnik.h" + +#if defined(HAVE_INTRIN_H) +# include +#ifdef _WIN64 +# pragma intrinsic(_BitScanReverse64) +#else +# pragma intrinsic(_BitScanReverse) +#endif +#endif + +/* + *---------------------------------------------------------------------- + * + * TclMSB -- + * + * Given a size_t non-zero value n, return the index of the most + * significant bit in n that is set. This is equivalent to returning + * trunc(log2(n)). It's also equivalent to the largest integer k + * such that 2^k <= n. + * + * This routine is adapted from Andrej Brodnik, "Computation of the + * Least Significant Set Bit", pp 7-10, Proceedings of the 2nd + * Electrotechnical and Computer Science Conference, Portoroz, + * Slovenia, 1993. The adaptations permit the computation to take + * place within size_t values without the need for double length + * buffers for calculation. They also fill in a number of details + * the paper omits or leaves unclear. + * + * Results: + * The index of the most significant set bit in n, a value between + * 0 and CHAR_BIT*sizeof(size_t) - 1, inclusive. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMSB( + size_t n) +{ + const int M = CHAR_BIT * sizeof(size_t); /* Bits in a size_t */ + + /* + * TODO: This function corresponds to a processor instruction on + * many platforms. Add here the various platform and compiler + * specific incantations to invoke those assembly instructions. + */ +#if defined(__GNUC__) && ((__GNUC__ >= 4) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 4))) + return n ? M - 1 - __builtin_clzll(n) : 0; +#endif + +#if defined(_MSC_VER) && _MSCVER >= 1300 + unsigned long result; + +#ifdef _WIN64 + (void) _BitScanReverse64(&result, n) +#else + (void) _BitScanReverse(&result, n) +#endif + + return result; +#endif + + if (M == 64) { + + /* + * For a byte, consider two masks, C1 = 10000000 selecting just + * the high bit, and C2 = 01111111 selecting all other bits. + * Then for any byte value n, the computation + * LEAD(n) = C1 & (n | (C2 + (n & C2))) + * will leave all bits but the high bit unset, and will have the + * high bit set iff n!=0. The whole thing is an 8-bit test + * for being non-zero. For an 8-byte size_t, each byte can have + * the test applied all at once, with combined masks. + */ + const size_t C1 = 0x8080808080808080; + const size_t C2 = 0x7F7F7F7F7F7F7F7F; +#define LEAD(n) (C1 & (n | (C2 + (n & C2)))) + + /* + * To shift a bit to a new place, multiplication by 2^k will do. + * To shift the top 7 bits produced by the LEAD test to the high + * 7 bits of the entire size_t, multiply by the right sum of + * powers of 2. In this case + * Q = 1 + 2^7 + 2^14 + 2^21 + 2^28 + 2^35 + 2^42 + * Then shift those 7 bits down to the low 7 bits of the size_t. + * The key to making this work is that none of the shifted bits + * collide with each other in the top 7-bit destination. + * Note that we lose the bit that indicates whether the low byte + * is non-zero. That doesn't matter because we require the original + * value n to be non-zero, so if all other bytes signal to be zero, + * we know the low byte is non-zero, and if one of the other bytes + * signals non-zero, we just don't care what the low byte is. + */ + const size_t Q = 0x0000040810204081; + + /* + * To place a copy of a 7-bit value in each of 7 bytes in + * a size_t, just multply by the right value. In this case + * P = 0x00 01 01 01 01 01 01 01 + * We don't put a copy in the high byte since analysis of the + * remaining steps in the algorithm indicates we do not need it. + */ + const size_t P = 0x0001010101010101; + + /* + * With 7 copies of the LEAD value, we can now apply 7 masks + * to it in a single step by an & against the right value. + * B = 00000000 01111111 01111110 01111100 + * 01111000 01110000 01100000 01000000 + * The higher the MSB of the copied value is, the more of the + * B-masked bytes stored in t will be non-zero. + */ + const size_t B = 0x007F7E7C78706040; + size_t t = B & P * (LEAD(n) * Q >> 57); + + /* + * We want to get a count of the non-zero bytes stored in t. + * First use LEAD(t) to create a set of high bits signaling + * non-zero values as before. Call this value + * X = x6*2^55 +x5*2^47 +x4*2^39 +x3*2^31 +x2*2^23 +x1*2^15 +x0*2^7 + * Then notice what multiplication by + * P = 2^48 + 2^40 + 2^32 + 2^24 + 2^16 + 2^8 + 1 + * produces: + * P*X = x0*2^7 + (x0 + x1)*2^15 + ... + * ... + (x0 + x1 + x2 + x3 + x4 + x5 + x6) * 2^55 + ... + * ... + (x5 + x6)*2^95 + x6*2^103 + * The high terms of this product are going to overflow the size_t + * and get lost, but we don't care about them. What we care is that + * the 2^55 term is exactly the sum we seek. We shift the product + * down by 55 bits and then mask away all but the bottom 3 bits + * (Max sum can be 7) we get exactly the count of non-zero B-masked + * bytes. By design of the mask, this count is the index of the + * MSB of the LEAD value. It indicates which byte of the original + * value contains the MSB of the original value. + */ +#define SUM(t) (0x7 & (int)(LEAD(t) * P >> 55)); + + /* + * Multiply by 8 to get the number of bits to shift to place + * that MSB-containing byte in the low byte. + */ + int k = 8 * SUM(t); + + /* + * Shift the MSB byte to the low byte. Then shift one more bit. + * Since we know the MSB byte is non-zero we only need to compute + * the MSB of the top 7 bits. If all top 7 bits are zero, we know + * the bottom bit is the 1 and the correct index is 0. Compute the + * MSB of that value by the same steps we did before. + */ + t = B & P * (n >> k >> 1); + + /* + * Add the index of the MSB of the byte to the index of the low + * bit of that byte computed before to get the final answer. + */ + return k + SUM(t); + + /* Total operations: 33 + * 10 bit-ands, 6 multiplies, 4 adds, 5 rightshifts, + * 3 assignments, 3 bit-ors, 2 typecasts. + * + * The whole task is one direct computation. + * No branches. No loops. + * + * 33 operations cannot beat one instruction, so assembly + * wins and should be used wherever possible, but this isn't bad. + */ + +#undef SUM + } else if (M == 32) { + + /* Same scheme as above, with adjustments to the 32-bit size */ + const size_t C1 = 0xA0820820; + const size_t C2 = 0x5F7DF7DF; + const size_t C3 = 0xC0820820; + const size_t C4 = 0x20000000; + const size_t Q = 0x00010841; + const size_t P = 0x01041041; + const size_t B = 0x1F79C610; + +#define SUM(t) (0x7 & (LEAD(t) * P >> 29)); + + size_t t = B & P * ((C3 & (LEAD(n) + C4)) * Q >> 27); + int k = 6 * SUM(t); + + t = B & P * (n >> k >> 1); + return k + SUM(t); + + /* Total operations: 33 + * 11 bit-ands, 6 multiplies, 5 adds, 5 rightshifts, + * 3 assignments, 3 bit-ors. + */ + +#undef SUM +#undef LEAD + + } else { + /* Simple and slow fallback for cases we haven't done yet. */ + int k = 0; + + while (n >>= 1) { + k++; + } + return k; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclBAConvertIndices -- + * + * Given a size_t index into the sequence, convert into the + * corresponding index pair of the store[] of a BrodnikArray. + * + * store[] is an array of arrays, and as the total size grows + * larger, the size of the arrays store[i] grow in a way that + * each new array is of about size sqrt(N), yet the index conversion + * routine remains relatively simple to calculate. + * + * Results: + * The index pair is written to *hiPtr and *loPtr, which may not + * be NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclBAConvertIndices( + size_t index, + unsigned int *hiPtr, + unsigned int *loPtr) +{ + size_t r = index + 1; + int k = TclMSB(r); + int shift = (k + 1) >> 1; + unsigned int lobits = (1 << shift) - 1; + unsigned int hibits = 1 << (k - shift); + + *hiPtr = (lobits << 1) - ((k & 1) * hibits) + + ((r >> shift) & (hibits - 1)); + *loPtr = r & lobits; +} + +/* + *---------------------------------------------------------------------- + * + * TclBAInvertIndices -- + * + * Given a size_t index pair hi, lo into the store[] of a BrodnikArray, + * compute and return the size_t index of the element found there. + * + * Results: + * The size_t index value. + * + * Side effects: + * None. + *---------------------------------------------------------------------- + */ + +size_t +TclBAInvertIndices( + unsigned int hi, + unsigned int lo) +{ + size_t plus2 = hi + 2; + int n = TclMSB(plus2) - 1; + unsigned int bit = (((size_t)1)<hi = 0; \ + newPtr->lo = 0; \ + newPtr->dbsize = 1; \ + newPtr->count = 0; \ + newPtr->dbused = 1; \ + newPtr->dbavail = 1; \ + newPtr->store = ckalloc(sizeof(T *)); \ + newPtr->store[0] = ckalloc(sizeof(T)); \ + return newPtr; \ +} \ + \ +scope void \ +BA_ ## T ## _Destroy( \ + BA_ ## T *a) \ +{ \ + unsigned int i = a->dbused; \ + \ + while (i--) { \ + ckfree(a->store[i]); \ + } \ + ckfree(a->store); \ + ckfree(a); \ +} \ + \ +scope size_t \ +BA_ ## T ## _Size( \ + BA_ ## T *a) \ +{ \ + if (a == NULL) { \ + return 0; \ + } \ + return TclBAInvertIndices(a->hi, a->lo); \ +} \ + \ +scope void \ +BA_ ## T ## _Grow( \ + BA_ ## T *a) \ +{ \ + if (a->dbused == a->dbavail) { \ + a->dbavail *= 2; \ + a->store = ckrealloc(a->store, a->dbavail*sizeof(T *)); \ + } \ + a->store[a->dbused] = ckalloc(a->dbsize * sizeof(T)); \ + a->dbused++; \ +} \ + \ +scope void \ +BA_ ## T ## _Shrink( \ + BA_ ## T *a) \ +{ \ + a->dbused--; \ + ckfree(a->store[a->dbused]); \ + if (a->dbavail / a->dbused >= 4) { \ + a->dbavail /= 2; \ + a->store = ckrealloc(a->store, a->dbavail*sizeof(T *)); \ + } \ +} \ + \ +scope void \ +BA_ ## T ## _Copy( \ + T *p, \ + BA_ ## T *a) \ +{ \ + unsigned int i = 0, n = 1, m = 0; \ + if (a->hi == 0) { \ + return; \ + } \ + while (i < a->hi) { \ + memcpy(p, a->store[i++], n * sizeof(T)); \ + p += n; \ + if (m == 0) { \ + m = n; n *= 2; m += n; \ + } \ + m--; \ + } \ + if (a->lo) { \ + memcpy(p, a->store[a->hi], a->lo * sizeof(T)); \ + } \ +} \ + \ +scope T * \ +BA_ ## T ## _Append( \ + BA_ ## T *a) \ +{ \ + T *elemPtr; \ + if (a->hi == a->dbused) { \ + BA_ ## T ## _Grow(a); \ + } \ + elemPtr = a->store[a->hi] + a->lo; \ + a->lo++; \ + if (a->lo == a->dbsize) { \ + a->lo = 0; \ + a->hi++; \ + if (a->count == 0) { \ + a->count = a->dbsize; \ + a->dbsize *= 2; \ + a->count += a->dbsize; \ + } \ + a->count--; \ + } \ + return elemPtr; \ +} \ + \ +scope T * \ +BA_ ## T ## _Detach( \ + BA_ ## T *a) \ +{ \ + T *elemPtr; \ + if (a->hi == 0) { \ + return NULL; \ + } \ + if (a->lo) { \ + a->lo--; \ + } else { \ + a->hi--; \ + a->count++; \ + if (a->count == 3 * (a->dbsize / 2)) { \ + a->count = 0; \ + a->dbsize /= 2; \ + } \ + a->lo = a->dbsize - 1; \ + } \ + elemPtr = a->store[a->hi] + a->lo; \ + if (a->lo == 0 && (a->hi != a->dbused - 1)) { \ + BA_ ## T ## _Shrink(a); \ + } \ + return elemPtr; \ +} \ + \ +scope T * \ +BA_ ## T ## _Get( \ + BA_ ## T *a, \ + size_t index, \ + BP_ ## T *p) \ +{ \ + unsigned int hi, lo; \ + \ + TclBAConvertIndices(index, &hi, &lo); \ + if (hi > a->hi || (hi == a->hi && lo >= a->lo)) { \ + if (p) {p->ptr = NULL;} \ + return NULL; \ + } \ + if (p) { \ + size_t plus2 = hi + 2; \ + int n = TclMSB(plus2) - 1; \ + p->array = a; \ + p->hi = hi; \ + p->lo = lo; \ + p->dbsize = 1 << (n + ((plus2 >> n) & 1)); \ + p->count = 3 * p->dbsize - 3 - hi; \ + p->ptr = a->store[hi] + lo; \ + } \ + return a->store[hi] + lo; \ +} \ + \ +scope T * \ +BA_ ## T ## _At( \ + BA_ ## T *a, \ + size_t index) \ +{ \ + return BA_ ## T ## _Get(a, index, NULL); \ +} \ + \ +scope T * \ +BA_ ## T ## _First( \ + BA_ ## T *a, \ + BP_ ## T *p) \ +{ \ + p->array = a; \ + p->hi = 0; \ + p->lo = 0; \ + p->dbsize = 1; \ + p->count = 0; \ + p->ptr = (a->hi) ? a->store[0] : NULL; \ + return p->ptr; \ +} \ + \ +scope T * \ +BP_ ## T ## _Next( \ + BP_ ## T *p) \ +{ \ + if (p->ptr) { \ + p->lo++; \ + if (p->lo < p->dbsize) { \ + p->ptr++; \ + } else { \ + p->lo = 0; \ + p->hi++; \ + p->ptr = p->array->store[p->hi]; \ + if (p->count == 0) { \ + p->count = p->dbsize; \ + p->dbsize *= 2; \ + p->count += p->dbsize; \ + } \ + p->count--; \ + } \ + if (p->hi > p->array->hi \ + || (p->hi == p->array->hi && p->lo >= p->array->lo)) { \ + p->ptr = NULL; \ + } \ + } \ + return p->ptr; \ +} \ + \ +scope T * \ +BP_ ## T ## _Plus( \ + BP_ ## T *p, \ + size_t incr) \ +{ \ + if (p->ptr) { \ + size_t index = TclBAInvertIndices(p->hi, p->lo); \ + index += incr; \ + return BA_ ## T ## _Get(p->array, index, p); \ + } \ + return p->ptr; \ +} \ + \ +scope T * \ +BP_ ## T ## _Minus( \ + BP_ ## T *p, \ + size_t incr) \ +{ \ + if (p->ptr) { \ + size_t index = TclBAInvertIndices(p->hi, p->lo); \ + if (index < incr) { \ + return p->ptr = NULL; \ + } \ + index -= incr; \ + return BA_ ## T ## _Get(p->array, index, p); \ + } \ + return p->ptr; \ +} + Index: generic/tclCompCmdsGR.c ================================================================== --- generic/tclCompCmdsGR.c +++ generic/tclCompCmdsGR.c @@ -14,10 +14,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" +#include "tclBrodnik.h" #include /* * Prototypes for procedures defined later in this file: */ @@ -176,29 +177,31 @@ * runtime. * *---------------------------------------------------------------------- */ +TclBrodnikArrayDefine(JumpFixup,MODULE_SCOPE); + int TclCompileIfCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - JumpFixupArray jumpFalseFixupArray; + BA_JumpFixup *jumpFalseFixup; /* Used to fix the ifFalse jump after each * test when its target PC is determined. */ - JumpFixupArray jumpEndFixupArray; + BA_JumpFixup *jumpEndFixup; /* Used to fix the jump after each "then" body * to the end of the "if" when that PC is * determined. */ + JumpFixup *falseFixupPtr = NULL, *endFixupPtr = NULL; Tcl_Token *tokenPtr, *testTokenPtr; - int jumpIndex = 0; /* Avoid compiler warning. */ - int jumpFalseDist, numWords, wordIdx, numBytes, j, code; + int jumpFalseDist, numWords, wordIdx, numBytes, code; const char *word; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ int boolVal; /* Value of static condition. */ int compileScripts = 1; @@ -218,12 +221,12 @@ return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); } - TclInitJumpFixupArray(&jumpFalseFixupArray); - TclInitJumpFixupArray(&jumpEndFixupArray); + jumpFalseFixup = BA_JumpFixup_Create(); + jumpEndFixup = BA_JumpFixup_Create(); code = TCL_OK; /* * Each iteration of this loop compiles one "if expr ?then? body" or * "elseif expr ?then? body" clause. @@ -279,17 +282,12 @@ } } else { SetLineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { - TclExpandJumpFixupArray(&jumpFalseFixupArray); - } - jumpIndex = jumpFalseFixupArray.next; - jumpFalseFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - jumpFalseFixupArray.fixup+jumpIndex); + falseFixupPtr = BA_JumpFixup_Append(jumpFalseFixup); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, falseFixupPtr); } code = TCL_OK; } /* @@ -322,21 +320,12 @@ if (compileScripts) { BODY(tokenPtr, wordIdx); } if (realCond) { - /* - * Jump to the end of the "if" command. Both jumpFalseFixupArray - * and jumpEndFixupArray are indexed by "jumpIndex". - */ - - if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { - TclExpandJumpFixupArray(&jumpEndFixupArray); - } - jumpEndFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - jumpEndFixupArray.fixup+jumpIndex); + endFixupPtr = BA_JumpFixup_Append(jumpEndFixup); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, endFixupPtr); /* * Fix the target of the jumpFalse after the test. Generate a 4 * byte jump if the distance is > 120 bytes. This is conservative, * and ensures that we won't have to replace this jump if we later @@ -343,18 +332,17 @@ * also need to replace the proceeding jump to the end of the "if" * with a 4 byte jump. */ TclAdjustStackDepth(-1, envPtr); - if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup+jumpIndex, 120)) { + if (TclFixupForwardJumpToHere(envPtr, falseFixupPtr, 120)) { /* * Adjust the code offset for the proceeding jump to the end * of the "if" command. */ - jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; + endFixupPtr->codeOffset += 3; } } else if (boolVal) { /* * We were processing an "if 1 {...}"; stop compiling scripts. */ @@ -424,21 +412,22 @@ /* * Fix the unconditional jumps to the end of the "if" command. */ - for (j = jumpEndFixupArray.next; j > 0; j--) { - jumpIndex = (j - 1); /* i.e. process the closest jump first. */ - if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup+jumpIndex, 127)) { + endFixupPtr = BA_JumpFixup_Detach(jumpEndFixup); + falseFixupPtr = BA_JumpFixup_Detach(jumpFalseFixup); + + while (endFixupPtr) { + if (TclFixupForwardJumpToHere(envPtr, endFixupPtr, 127)) { /* * Adjust the immediately preceeding "ifFalse" jump. We moved it's * target (just after this jump) down three bytes. */ unsigned char *ifFalsePc = envPtr->codeStart - + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + + falseFixupPtr->codeOffset; unsigned char opCode = *ifFalsePc; if (opCode == INST_JUMP_FALSE1) { jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); jumpFalseDist += 3; @@ -449,19 +438,22 @@ TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); } } + + endFixupPtr = BA_JumpFixup_Detach(jumpEndFixup); + falseFixupPtr = BA_JumpFixup_Detach(jumpFalseFixup); } /* * Free the jumpFixupArray array if malloc'ed storage was used. */ done: - TclFreeJumpFixupArray(&jumpFalseFixupArray); - TclFreeJumpFixupArray(&jumpEndFixupArray); + BA_JumpFixup_Destroy(jumpFalseFixup); + BA_JumpFixup_Destroy(jumpEndFixup); return code; } /* *---------------------------------------------------------------------- Index: generic/tclCompCmdsSZ.c ================================================================== --- generic/tclCompCmdsSZ.c +++ generic/tclCompCmdsSZ.c @@ -1424,16 +1424,13 @@ CompileEnv *envPtr) { Tcl_Token *endTokenPtr, *tokenPtr; int breakOffset = 0, count = 0, bline = line; Tcl_Parse parse; - Tcl_InterpState state = NULL; - TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); - if (state != NULL) { - Tcl_ResetResult(interp); - } + parse.commandStart = NULL; + TclSubstParse(interp, bytes, numBytes, flags, &parse); /* * Tricky point! If the first token does not result in a *guaranteed* push * of a Tcl_Obj on the stack, we must push an empty object. Otherwise it * is possible to get to an INST_STR_CONCAT1 or INST_DONE without enough @@ -1481,11 +1478,11 @@ if (tokenPtr->numComponents > 1) { int i, foundCommand = 0; for (i=2 ; i<=tokenPtr->numComponents ; i++) { - if (tokenPtr[i].type == TCL_TOKEN_COMMAND) { + if (tokenPtr[i].type == TCL_TOKEN_SCRIPT_SUBST) { foundCommand = 1; break; } } if (foundCommand) { @@ -1528,19 +1525,22 @@ catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, catchRange); ExceptionRangeStarts(envPtr, catchRange); switch (tokenPtr->type) { - case TCL_TOKEN_COMMAND: - TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, + case TCL_TOKEN_SCRIPT_SUBST: + TclCompileTokens(interp, tokenPtr, tokenPtr->numComponents + 1, envPtr); count++; break; case TCL_TOKEN_VARIABLE: TclCompileVarSubst(interp, tokenPtr, envPtr); count++; break; + case TCL_TOKEN_ERROR: + TclCompileTokens(interp, tokenPtr, 1, envPtr); + break; default: Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d", tokenPtr->type); } @@ -1642,19 +1642,25 @@ count -= 254; } if (count > 1) { OP1( STR_CONCAT1, count); } + + if (endTokenPtr[-1].type == TCL_TOKEN_ERROR) { + /* + * Bytecode execution will only reach this point after a + * TCL_RETURN, TCL_CONTINUE, or other exception is raised. + * In those cases, we're at a +1 status in stack depth, so + * we POP before continuing with instructions to raise the + * syntax error message. + */ + OP( POP); + TclCompileTokens(interp, endTokenPtr - 1, 1, envPtr); + } Tcl_FreeParse(&parse); - if (state != NULL) { - Tcl_RestoreInterpState(interp, state); - TclCompileSyntaxError(interp, envPtr); - TclAdjustStackDepth(-1, envPtr); - } - /* Final target of the multi-jump from all BREAKs */ if (breakOffset > 0) { TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset, envPtr->codeStart + breakOffset); } Index: generic/tclCompExpr.c ================================================================== --- generic/tclCompExpr.c +++ generic/tclCompExpr.c @@ -477,24 +477,10 @@ BRACED /* { */, 0 /* | or || */, INVALID /* } */, BIT_NOT /* ~ */, INVALID /* DEL */ }; -/* - * The JumpList struct is used to create a stack of data needed for the - * TclEmitForwardJump() and TclFixupForwardJump() calls that are performed - * when compiling the short-circuiting operators QUESTION/COLON, AND, and OR. - * Keeping a stack permits the CompileExprTree() routine to be non-recursive. - */ - -typedef struct JumpList { - JumpFixup jump; /* Pass this argument to matching calls of - * TclEmitForwardJump() and - * TclFixupForwardJump(). */ - struct JumpList *next; /* Point to next item on the stack */ -} JumpList; - /* * Declarations for local functions to this file: */ static void CompileExprTree(Tcl_Interp *interp, OpNode *nodes, @@ -880,12 +866,14 @@ tokenPtr->start = start; parsePtr->numTokens++; switch (lexeme) { case QUOTED: - code = Tcl_ParseQuotedString(NULL, start, numBytes, - parsePtr, 1, &end); + code = parseOnly ? Tcl_ParseQuotedString(NULL, start, + numBytes, parsePtr, 1, &end) + : TclParseQuotedString(NULL, start, numBytes, parsePtr, + PARSE_APPEND | PARSE_USE_INTERNAL_TOKENS, &end); scanned = end - start; break; case BRACED: code = Tcl_ParseBraces(NULL, start, numBytes, @@ -892,11 +880,13 @@ parsePtr, 1, &end); scanned = end - start; break; case VARIABLE: - code = Tcl_ParseVarName(NULL, start, numBytes, parsePtr, 1); + code = parseOnly ? Tcl_ParseVarName(NULL, start, numBytes, + parsePtr, 1) : TclParseVarName(NULL, start, numBytes, + parsePtr, PARSE_APPEND | PARSE_USE_INTERNAL_TOKENS); /* * Handle the quirk that Tcl_ParseVarName reports a successful * parse even when it gets only a "$" with no variable name. */ @@ -908,11 +898,12 @@ goto error; } scanned = tokenPtr->size; break; - case SCRIPT: { + case SCRIPT: + if (parseOnly) { Tcl_Parse *nestedPtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; tokenPtr->type = TCL_TOKEN_COMMAND; @@ -952,11 +943,14 @@ start = tokenPtr->start; scanned = end - start; tokenPtr->size = scanned; parsePtr->numTokens++; break; - } /* SCRIPT case */ + } + code = TclParseScriptSubst(start, numBytes, parsePtr, 0); + scanned = parsePtr->term + 1 - start; + break; } if (code != TCL_OK) { /* * Here we handle all the syntax errors generated by the * Tcl_Token generating parsing routines called in the switch @@ -2238,16 +2232,16 @@ int optimize) { OpNode *nodePtr = nodes + index; OpNode *rootPtr = nodePtr; int numWords = 0; - JumpList *jumpPtr = NULL; + JumpFixup *jumpPtr = NULL; + BA_JumpFixup *stack = NULL; int convert = 1; while (1) { int next; - JumpList *freePtr, *newJump; if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; if (nodePtr->lexeme == QUESTION) { @@ -2282,34 +2276,33 @@ nodePtr->left = numWords; numWords = 2; /* Command plus one argument */ break; } case QUESTION: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); + if (stack == NULL) { + stack = BA_JumpFixup_Create(); + } + jumpPtr = BA_JumpFixup_Append(stack); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, jumpPtr); break; case COLON: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->jump); + jumpPtr = BA_JumpFixup_Append(stack); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, jumpPtr); TclAdjustStackDepth(-1, envPtr); if (convert) { - jumpPtr->jump.jumpType = TCL_TRUE_JUMP; + jumpPtr->jumpType = TCL_TRUE_JUMP; } convert = 1; break; case AND: case OR: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; + if (stack == NULL) { + stack = BA_JumpFixup_Create(); + } + jumpPtr = BA_JumpFixup_Append(stack); TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) - ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump); + ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, jumpPtr); break; } } else { int pc1, pc2, target; @@ -2349,31 +2342,27 @@ */ numWords++; break; case COLON: + jumpPtr = BA_JumpFixup_Detach(stack); CLANG_ASSERT(jumpPtr); - if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { - jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; + if (jumpPtr->jumpType == TCL_TRUE_JUMP) { + jumpPtr->jumpType = TCL_UNCONDITIONAL_JUMP; convert = 1; } - target = jumpPtr->jump.codeOffset + 2; - if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { + target = jumpPtr->codeOffset + 2; + if (TclFixupForwardJumpToHere(envPtr, jumpPtr, 127)) { target += 3; } - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); - TclFixupForwardJump(envPtr, &jumpPtr->jump, - target - jumpPtr->jump.codeOffset, 127); - - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); + jumpPtr = BA_JumpFixup_Detach(stack); + TclFixupForwardJump(envPtr, jumpPtr, + target - jumpPtr->codeOffset, 127); break; case AND: case OR: + jumpPtr = BA_JumpFixup_Detach(stack); CLANG_ASSERT(jumpPtr); pc1 = CurrentOffset(envPtr); TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 : INST_JUMP_TRUE1, 0, envPtr); TclEmitPush(TclRegisterLiteral(envPtr, @@ -2381,30 +2370,30 @@ pc2 = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, envPtr->codeStart + pc1 + 1); - if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { + if (TclFixupForwardJumpToHere(envPtr, jumpPtr, 127)) { pc2 += 3; } TclEmitPush(TclRegisterLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, envPtr->codeStart + pc2 + 1); convert = 0; - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); break; default: TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); convert = 0; break; } if (nodePtr == rootPtr) { /* We're done */ + if (stack) { + BA_JumpFixup_Destroy(stack); + } return; } nodePtr = nodes + nodePtr->p.parent; continue; } Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -13,10 +13,28 @@ */ #include "tclInt.h" #include "tclCompile.h" #include +#include "tclBrodnik.h" + +/* + * Structure used to map between instruction pc and source locations. It + * defines for each compiled Tcl command its code's starting offset and its + * source's starting offset and length. Note that the code offset increases + * monotonically: that is, the table is sorted in code offset order. The + * source offset is not monotonic. + */ + +typedef struct CmdLocation { + int codeOffset; /* Offset of first byte of command code. */ + int numCodeBytes; /* Number of bytes for command's code. */ + int srcOffset; /* Offset of first char of the command. */ + int numSrcBytes; /* Number of command source chars. */ +} CmdLocation; +TclBrodnikArray(CmdLocation); +TclBrodnikArrayDefine(AuxData,MODULE_SCOPE); /* * Variable that controls whether compilation tracing is enabled and, if so, * what level of tracing is desired: * 0: no compilation tracing @@ -660,20 +678,21 @@ /* * Prototypes for procedures defined later in this file: */ static void CleanupByteCode(ByteCode *codePtr); +static void CompileScriptTokens(Tcl_Interp *interp, + Tcl_Token *tokens, Tcl_Token *lastTokenPtr, + CompileEnv *envPtr); static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, ByteCode *codePtr, unsigned char *startPtr); -static void EnterCmdExtentData(CompileEnv *envPtr, - int cmdNumber, int numSrcBytes, int numCodeBytes); -static void EnterCmdStartData(CompileEnv *envPtr, - int cmdNumber, int srcOffset, int codeOffset); +static CmdLocation * EnterCmdStartData(CompileEnv *envPtr, + int srcOffset, int codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); static int IsCompactibleCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr); @@ -1015,13 +1034,12 @@ register ByteCode *codePtr) /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; Interp *iPtr = (Interp *) interp; int numLitObjects = codePtr->numLitObjects; - int numAuxDataItems = codePtr->numAuxDataItems; register Tcl_Obj **objArrayPtr, *objPtr; - register const AuxData *auxDataPtr; + AuxData *auxDataPtr; int i; #ifdef TCL_COMPILE_STATS if (interp != NULL) { ByteCodeStats *statsPtr; @@ -1038,11 +1056,11 @@ statsPtr->currentLitBytes -= (double) codePtr->numLitObjects * sizeof(Tcl_Obj *); statsPtr->currentExceptBytes -= (double) codePtr->numExceptRanges * sizeof(ExceptionRange); statsPtr->currentAuxBytes -= (double) - codePtr->numAuxDataItems * sizeof(AuxData); + BA_AuxData_Size(codePtr->auxData) * sizeof(AuxData); statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes; Tcl_GetTime(&destroyTime); lifetimeSec = destroyTime.sec - codePtr->createTime.sec; if (lifetimeSec > 2000) { /* avoid overflow */ @@ -1060,11 +1078,11 @@ #endif /* TCL_COMPILE_STATS */ /* * A single heap object holds the ByteCode structure and its code, object, * command location, and auxiliary data arrays. This means we only need to - * 1) decrement the ref counts of the LiteralEntry's in its literal array, + * 1) decrement the ref counts of the literal values in its literal array, * 2) call the free procs for the auxiliary data items, 3) free the * localCache if it is unused, and finally 4) free the ByteCode * structure's heap object. * * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like @@ -1096,17 +1114,26 @@ while (numLitObjects--) { /* TclReleaseLiteral calls Tcl_DecrRefCount() for us */ TclReleaseLiteral(interp, *objArrayPtr++); } } + if (codePtr->flags & TCL_BYTECODE_FREE_LITERALS) { + ckfree(codePtr->objArrayPtr); + } - auxDataPtr = codePtr->auxDataArrayPtr; - for (i = 0; i < numAuxDataItems; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); + if (codePtr->auxData) { + BA_AuxData *adArray = codePtr->auxData; + + codePtr->auxData = NULL; + auxDataPtr = BA_AuxData_Detach(adArray); + while (auxDataPtr) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr = BA_AuxData_Detach(adArray); } - auxDataPtr++; + BA_AuxData_Destroy(adArray); } /* * TIP #280. Release the location data associated with this byte code * structure, if any. NOTE: The interp we belong to may be gone already, @@ -1431,11 +1458,11 @@ envPtr->numCommands = 0; envPtr->exceptDepth = 0; envPtr->maxExceptDepth = 0; envPtr->maxStackDepth = 0; envPtr->currStackDepth = 0; - TclInitLiteralTable(&envPtr->localLitTable); + Tcl_InitHashTable(&envPtr->litMap, TCL_ONE_WORD_KEYS); envPtr->codeStart = envPtr->staticCodeSpace; envPtr->codeNext = envPtr->codeStart; envPtr->codeEnd = envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES; envPtr->mallocedCodeArray = 0; @@ -1449,13 +1476,11 @@ envPtr->exceptAuxArrayPtr = envPtr->staticExAuxArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; - envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; - envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; - envPtr->mallocedCmdMap = 0; + envPtr->cmdMap = BA_CmdLocation_Create(); envPtr->atCmdStart = 1; envPtr->expandCount = 0; /* * TIP #280: Set up the extended command location information, based on @@ -1586,14 +1611,11 @@ * data is available. */ envPtr->clNext = NULL; - envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; - envPtr->auxDataArrayNext = 0; - envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; - envPtr->mallocedAuxDataArray = 0; + envPtr->auxData = NULL; } /* *---------------------------------------------------------------------- * @@ -1618,56 +1640,54 @@ void TclFreeCompileEnv( register CompileEnv *envPtr)/* Points to the CompileEnv structure. */ { - if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){ - ckfree(envPtr->localLitTable.buckets); - envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets; - } + Tcl_DeleteHashTable(&envPtr->litMap); 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; + Tcl_Obj **litPtr = envPtr->literalArrayPtr; for (i = 0; i < envPtr->literalArrayNext; i++) { - TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr); - entryPtr++; + TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, *litPtr++); } #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); + if (envPtr->auxData) { + BA_AuxData *adArray = envPtr->auxData; + AuxData *auxDataPtr; + + envPtr->auxData = NULL; + auxDataPtr = BA_AuxData_Detach(adArray); + while (auxDataPtr) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr = BA_AuxData_Detach(adArray); } - auxDataPtr++; + BA_AuxData_Destroy(adArray); } } if (envPtr->mallocedCodeArray) { ckfree(envPtr->codeStart); } - if (envPtr->mallocedLiteralArray) { + if (envPtr->mallocedLiteralArray && envPtr->iPtr) { ckfree(envPtr->literalArrayPtr); } if (envPtr->mallocedExceptArray) { ckfree(envPtr->exceptArrayPtr); ckfree(envPtr->exceptAuxArrayPtr); } - if (envPtr->mallocedCmdMap) { - ckfree(envPtr->cmdMapPtr); - } - if (envPtr->mallocedAuxDataArray) { - ckfree(envPtr->auxDataArrayPtr); - } + BA_CmdLocation_Destroy(envPtr->cmdMap); if (envPtr->extCmdMapPtr) { ReleaseCmdWordData(envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; } } @@ -1808,11 +1828,11 @@ TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); } TclEmitPush(cmdLitIdx, envPtr); } -void +Tcl_Token * TclCompileInvocation( Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, @@ -1850,23 +1870,25 @@ TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx); } else { TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); } TclCheckStackDepth(depth+1, envPtr); + + return tokenPtr; } -static void +static Tcl_Token * CompileExpanded( Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, CompileEnv *envPtr) { int wordIdx = 0; - DefineLineInformation; int depth = TclGetStackDepth(envPtr); + DefineLineInformation; StartExpanding(envPtr); if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; @@ -1910,22 +1932,30 @@ * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general. */ TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); TclCheckStackDepth(depth+1, envPtr); + + return tokenPtr; } static int CompileCmdCompileProc( Tcl_Interp *interp, - Tcl_Parse *parsePtr, + Tcl_Token *tokenPtr, Command *cmdPtr, CompileEnv *envPtr) { int unwind = 0, incrOffset = -1; - DefineLineInformation; + Tcl_Parse parse; int depth = TclGetStackDepth(envPtr); + DefineLineInformation; + + parse.commandStart = tokenPtr->start; + parse.commandSize = tokenPtr->size; + parse.numWords = tokenPtr->numComponents; + parse.tokenPtr = tokenPtr + 1; /* * Emit of the INST_START_CMD instruction is controlled by the value of * envPtr->atCmdStart: * @@ -1953,11 +1983,11 @@ case 2: /* Nothing to do */ ; } - if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { + if (TCL_OK == TclAttemptCompileProc(interp, &parse, 1, cmdPtr, envPtr)) { if (incrOffset >= 0) { /* * We successfully compiled a command. Increment the number of * commands that start at the currently active INST_START_CMD. */ @@ -1990,61 +2020,77 @@ /* * Reset the index of next command. Toss out any from failed nested * partial compiles. */ - envPtr->numCommands = mapPtr->nuloc; + TclDisposeFailedCompile(envPtr, mapPtr->nuloc); return TCL_ERROR; } -static int +void +TclDisposeFailedCompile( + CompileEnv *envPtr, + int numCommands) +{ + while (envPtr->numCommands > numCommands) { + (void) BA_CmdLocation_Detach(envPtr->cmdMap); + envPtr->numCommands--; + } +} + +static Tcl_Token * CompileCommandTokens( Tcl_Interp *interp, - Tcl_Parse *parsePtr, - CompileEnv *envPtr) + Tcl_Token *commandTokenPtr, + CompileEnv *envPtr, + CmdLocation **cmdLocPtrPtr) { Interp *iPtr = (Interp *) interp; - Tcl_Token *tokenPtr = parsePtr->tokenPtr; + + Tcl_Token *tokenPtr = commandTokenPtr; + int numWords = tokenPtr->numComponents; + const char *commandStart = tokenPtr->start; + int commandSize = tokenPtr->size; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; Tcl_Obj *cmdObj = Tcl_NewObj(); Command *cmdPtr = NULL; + CmdLocation *cmdLocPtr = NULL; int code = TCL_ERROR; int cmdKnown, expand = -1; int *wlines, wlineat; int cmdLine = envPtr->line; int *clNext = envPtr->clNext; - int cmdIdx = envPtr->numCommands; int startCodeOffset = envPtr->codeNext - envPtr->codeStart; int depth = TclGetStackDepth(envPtr); - assert (parsePtr->numWords > 0); + assert (numWords > 0); /* Pre-Compile */ + tokenPtr++; envPtr->numCommands++; - EnterCmdStartData(envPtr, cmdIdx, - parsePtr->commandStart - envPtr->source, startCodeOffset); + cmdLocPtr = EnterCmdStartData(envPtr, commandStart - envPtr->source, + startCodeOffset); /* * TIP #280. Scan the words and compute the extended location information. * The map first contain full per-word line information for use by the * compiler. This is later replaced by a reduced form which signals * non-literal words, stored in 'wlines'. */ - EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, - parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->commandSize, parsePtr->numWords, cmdLine, + EnterCmdWordData(eclPtr, commandStart - envPtr->source, + tokenPtr, commandStart, commandSize, numWords, cmdLine, clNext, &wlines, envPtr); wlineat = eclPtr->nuloc - 1; envPtr->line = eclPtr->loc[wlineat].line[0]; envPtr->clNext = eclPtr->loc[wlineat].next[0]; /* Do we know the command word? */ Tcl_IncrRefCount(cmdObj); - tokenPtr = parsePtr->tokenPtr; cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); /* Is this a command we should (try to) compile with a compileProc ? */ if (cmdKnown && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); @@ -2058,43 +2104,47 @@ || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { cmdPtr = NULL; } } if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + expand = ExpandRequested(tokenPtr, numWords); if (expand) { /* We need to expand, but compileProc cannot. */ cmdPtr = NULL; } } } /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ if (cmdPtr) { - code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr); + code = CompileCmdCompileProc(interp, commandTokenPtr, cmdPtr, envPtr); } if (code == TCL_ERROR) { if (expand < 0) { - expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + expand = ExpandRequested(tokenPtr, numWords); } if (expand) { - CompileExpanded(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + tokenPtr = CompileExpanded(interp, tokenPtr, + cmdKnown ? cmdObj : NULL, numWords, envPtr); } else { - TclCompileInvocation(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + tokenPtr = TclCompileInvocation(interp, tokenPtr, + cmdKnown ? cmdObj : NULL, numWords, envPtr); + } + } else { + while (numWords--) { + tokenPtr = TokenAfter(tokenPtr); } } Tcl_DecrRefCount(cmdObj); TclEmitOpcode(INST_POP, envPtr); - EnterCmdExtentData(envPtr, cmdIdx, - parsePtr->term - parsePtr->commandStart, - (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + cmdLocPtr->numSrcBytes = commandSize; + cmdLocPtr->numCodeBytes = (envPtr->codeNext-envPtr->codeStart) + - startCodeOffset; /* * TIP #280: Free full form of per-word line data and insert the reduced * form now */ @@ -2104,12 +2154,14 @@ ckfree(eclPtr->loc[wlineat].line); ckfree(eclPtr->loc[wlineat].next); eclPtr->loc[wlineat].line = wlines; eclPtr->loc[wlineat].next = NULL; + *cmdLocPtrPtr = cmdLocPtr; TclCheckStackDepth(depth, envPtr); - return cmdIdx; + + return tokenPtr; } void TclCompileScript( Tcl_Interp *interp, /* Used for error and status reporting. Also @@ -2119,103 +2171,101 @@ int numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last - * command this routine compiles into bytecode. - * Initial value of -1 indicates this routine - * has not yet generated any bytecode. */ - const char *p = script; /* Where we are in our compile. */ + Tcl_Token *lastTokenPtr; + Tcl_Token *tokens; + + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); + } + tokens = TclParseScript(interp, script, numBytes, /* flags */ 0, + &lastTokenPtr, NULL); + CompileScriptTokens(interp, tokens, lastTokenPtr, envPtr); + ckfree(tokens); +} + +static void +CompileScriptTokens(interp, tokens, lastTokenPtr, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. + * Also serves as context for finding and + * compiling commands. May not be NULL. */ + Tcl_Token *tokens; + Tcl_Token *lastTokenPtr; + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int numCommands = tokens[0].numComponents; int depth = TclGetStackDepth(envPtr); + CmdLocation *cmdLocPtr = NULL; /* Pointer into envPtr->cmdMap for + * the last command this routine + * compiles into bytecode; If we + * exit still value NULL, there + * was no bytecode generated. */ + if (lastTokenPtr < tokens) { + Tcl_Panic("CompileScriptTokens: parse produced no tokens"); + } + if (tokens[0].type != TCL_TOKEN_SCRIPT) { + Tcl_Panic("CompileScriptTokens: invalid token array, expected script"); + } if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); } - /* Each iteration compiles one command from the script. */ - - while (numBytes > 0) { - Tcl_Parse parse; - const char *next; - - if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) { - /* - * Compile bytecodes to report the parse error at runtime. - */ - - Tcl_LogCommandInfo(interp, script, parse.commandStart, - parse.term + 1 - parse.commandStart); - TclCompileSyntaxError(interp, envPtr); - return; - } - + tokenPtr = &(tokens[1]); + if (numCommands) { + TclAdvanceLines(&envPtr->line, tokens[0].start, tokenPtr->start); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + tokenPtr->start - envPtr->source); + } + + while (numCommands--) { + int numWords = tokenPtr->numComponents; + const char * commandStart = tokenPtr->start; + + if (tokenPtr > lastTokenPtr) { + Tcl_Panic("CompileScriptTokens: overran token array"); + } + if (tokenPtr->type != TCL_TOKEN_CMD) { + Tcl_Panic("CompileScriptTokens: invalid token array, expected cmd: %d: %.*s", tokenPtr->type, tokenPtr->size, tokenPtr->start); + } + + /* TODO: comment here justifying. */ + if (numWords == 0) { + tokenPtr++; + continue; + } + #ifdef TCL_COMPILE_DEBUG /* * If tracing, print a line for each top level command compiled. - * TODO: Suppress when numWords == 0 ? */ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - int commandLength = parse.term - parse.commandStart; fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parse.commandStart, - TclMin(commandLength, 55)); + TclPrintSource(stdout, commandStart, TclMin(tokenPtr->size, 55)); fprintf(stdout, "\n"); } #endif - /* - * TIP #280: Count newlines before the command start. - * (See test info-30.33). - */ - - TclAdvanceLines(&envPtr->line, p, parse.commandStart); - TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, - parse.commandStart - envPtr->source); - - /* - * Advance parser to the next command in the script. - */ - - next = parse.commandStart + parse.commandSize; - numBytes -= next - p; - p = next; - - if (parse.numWords == 0) { - /* - * The "command" parsed has no words. In this case we can skip - * the rest of the loop body. With no words, clearly - * CompileCommandTokens() has nothing to do. Since the parser - * aggressively sucks up leading comment and white space, - * including newlines, parse.commandStart must be pointing at - * either the end of script, or a command-terminating semi-colon. - * In either case, the TclAdvance*() calls have nothing to do. - * Finally, when no words are parsed, no tokens have been - * allocated at parse.tokenPtr so there's also nothing for - * Tcl_FreeParse() to do. - * - * The advantage of this shortcut is that CompileCommandTokens() - * can be written with an assumption that parse.numWords > 0, with - * the implication the CCT() always generates bytecode. - */ - continue; - } - - lastCmdIdx = CompileCommandTokens(interp, &parse, envPtr); + tokenPtr = CompileCommandTokens(interp, tokenPtr, envPtr, &cmdLocPtr); /* * TIP #280: Track lines in the just compiled command. */ - TclAdvanceLines(&envPtr->line, parse.commandStart, p); - TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, - p - envPtr->source); - Tcl_FreeParse(&parse); + if (numCommands) { + TclAdvanceLines(&envPtr->line, commandStart, tokenPtr->start); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + tokenPtr->start - envPtr->source); + } } - - if (lastCmdIdx == -1) { + if (tokenPtr <= lastTokenPtr) { + TclCompileTokens(interp, tokenPtr, lastTokenPtr-tokenPtr+1, envPtr); + } else if (cmdLocPtr == NULL) { /* * Compiling the script yielded no bytecode. The script must be all * whitespace, comments, and empty commands. Such scripts are defined * to successfully produce the empty string result, so we emit the * simple bytecode that makes that happen. @@ -2232,11 +2282,11 @@ * command compiled, we need to undo that INST_POP so that the result * of the last command becomes the result of the script. The code * here removes that trailing INST_POP. */ - envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; + cmdLocPtr->numCodeBytes--; envPtr->codeNext--; envPtr->currStackDepth++; } TclCheckStackDepth(depth+1, envPtr); } @@ -2428,36 +2478,10 @@ } adjust++; } break; - case TCL_TOKEN_COMMAND: - /* - * Push any accumulated chars appearing before the command. - */ - - if (Tcl_DStringLength(&textBuffer) > 0) { - int literal = TclRegisterDStringLiteral(envPtr, &textBuffer); - - TclEmitPush(literal, envPtr); - numObjsToConcat++; - Tcl_DStringFree(&textBuffer); - - if (numCL) { - TclContinuationsEnter(TclFetchLiteral(envPtr, literal), - numCL, clPosition); - } - numCL = 0; - } - - envPtr->line += adjust; - TclCompileScript(interp, tokenPtr->start+1, - tokenPtr->size-2, envPtr); - envPtr->line -= adjust; - numObjsToConcat++; - break; - case TCL_TOKEN_VARIABLE: /* * Push any accumulated chars appearing before the $. */ @@ -2473,10 +2497,43 @@ TclCompileVarSubst(interp, tokenPtr, envPtr); numObjsToConcat++; count -= tokenPtr->numComponents; tokenPtr += tokenPtr->numComponents; break; + + case TCL_TOKEN_SCRIPT_SUBST: + /* + * Push any accumulated chars appearing before the command. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal = TclRegisterDStringLiteral(envPtr, &textBuffer); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + Tcl_DStringFree(&textBuffer); + } + + if (count <= tokenPtr->numComponents) { + Tcl_Panic("token components overflow token array"); + } + + envPtr->line += adjust; + CompileScriptTokens(interp, tokenPtr+1, + tokenPtr + (tokenPtr->numComponents), envPtr); + envPtr->line -= adjust; + numObjsToConcat++; + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; + + case TCL_TOKEN_ERROR: + /* Compile bytecodes to report the parse error at runtime. */ + TclSubstTokens(interp, tokenPtr, 1, NULL, 1, NULL, NULL, 0); + Tcl_LogCommandInfo(interp, envPtr->source, + tokenPtr->start, tokenPtr->size); + TclCompileSyntaxError(interp, envPtr); + goto done; default: Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s", tokenPtr->type, tokenPtr->size, tokenPtr->start); } @@ -2515,10 +2572,11 @@ */ if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); } +done: Tcl_DStringFree(&textBuffer); /* * Release the temp table we used to collect the locations of continuation * lines, if any. @@ -2719,34 +2777,29 @@ static void PreventCycle( Tcl_Obj *objPtr, CompileEnv *envPtr) { - int i; - - for (i = 0; i < envPtr->literalArrayNext; i++) { - if (objPtr == TclFetchLiteral(envPtr, i)) { - /* - * Prevent circular reference where the bytecode intrep of - * a value contains a literal which is that same value. - * If this is allowed to happen, refcount decrements may not - * reach zero, and memory may leak. Bugs 467523, 3357771 - * - * NOTE: [Bugs 3392070, 3389764] We make a copy based completely - * on the string value, and do not call Tcl_DuplicateObj() so we - * can be sure we do not have any lingering cycles hiding in - * the intrep. - */ - int numBytes; - const char *bytes = TclGetStringFromObj(objPtr, &numBytes); - Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes); - - Tcl_IncrRefCount(copyPtr); - TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr); - - envPtr->literalArrayPtr[i].objPtr = copyPtr; - } + Tcl_HashEntry *hePtr = Tcl_FindHashEntry(&envPtr->litMap, objPtr); + if (hePtr) { + /* + * Prevent circular reference where the bytecode intrep of + * a value contains a literal which is that same value. + * If this is allowed to happen, refcount decrements may not + * reach zero, and memory may leak. Bugs 467523, 3357771 + * + * NOTE: [Bugs 3392070, 3389764] We make a copy based completely + * on the string value, and do not call Tcl_DuplicateObj() so we + * can be sure we do not have any lingering cycles hiding in + * the intrep. + */ + int numBytes, i = PTR2INT(Tcl_GetHashValue(hePtr)); + const char *bytes = TclGetStringFromObj(objPtr, &numBytes); + + envPtr->literalArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes); + Tcl_IncrRefCount(envPtr->literalArrayPtr[i]); + TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr); } } ByteCode * TclInitByteCode( @@ -2753,30 +2806,30 @@ register CompileEnv *envPtr)/* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { register ByteCode *codePtr; size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; - size_t auxDataArrayBytes, structureSize; + size_t structureSize; register unsigned char *p; #ifdef TCL_COMPILE_DEBUG unsigned char *nextPtr; #endif int numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; - int i, isNew; + int isNew; Interp *iPtr; if (envPtr->iPtr == NULL) { Tcl_Panic("TclInitByteCodeObj() called on uninitialized CompileEnv"); } iPtr = envPtr->iPtr; codeBytes = envPtr->codeNext - envPtr->codeStart; - objArrayBytes = envPtr->literalArrayNext * sizeof(Tcl_Obj *); + objArrayBytes = envPtr->mallocedLiteralArray ? 0 : + envPtr->literalArrayNext * sizeof(Tcl_Obj *); exceptArrayBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); - auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData); cmdLocBytes = GetCmdLocEncodingSize(envPtr); /* * Compute the total number of bytes needed for this bytecode. */ @@ -2783,11 +2836,10 @@ structureSize = sizeof(ByteCode); structureSize += TCL_ALIGN(codeBytes); /* align object array */ structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */ structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ - structureSize += auxDataArrayBytes; structureSize += cmdLocBytes; if (envPtr->iPtr->varFramePtr != NULL) { namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; } else { @@ -2813,42 +2865,40 @@ codePtr->numCommands = envPtr->numCommands; codePtr->numSrcBytes = envPtr->numSrcBytes; codePtr->numCodeBytes = codeBytes; codePtr->numLitObjects = numLitObjects; codePtr->numExceptRanges = envPtr->exceptArrayNext; - codePtr->numAuxDataItems = envPtr->auxDataArrayNext; codePtr->numCmdLocBytes = cmdLocBytes; codePtr->maxExceptDepth = envPtr->maxExceptDepth; codePtr->maxStackDepth = envPtr->maxStackDepth; p += sizeof(ByteCode); codePtr->codeStart = p; memcpy(p, envPtr->codeStart, (size_t) codeBytes); - p += TCL_ALIGN(codeBytes); /* align object array */ - codePtr->objArrayPtr = (Tcl_Obj **) p; - for (i = 0; i < numLitObjects; i++) { - codePtr->objArrayPtr[i] = TclFetchLiteral(envPtr, i); + + if (envPtr->mallocedLiteralArray) { + codePtr->objArrayPtr = envPtr->literalArrayPtr; + codePtr->flags |= TCL_BYTECODE_FREE_LITERALS; + } else { + codePtr->objArrayPtr = (Tcl_Obj **) p; + memcpy(p, envPtr->literalArrayPtr, (size_t) objArrayBytes); + p += TCL_ALIGN(objArrayBytes); /* align exception range array */ } - p += TCL_ALIGN(objArrayBytes); /* align exception range array */ if (exceptArrayBytes > 0) { codePtr->exceptArrayPtr = (ExceptionRange *) p; memcpy(p, envPtr->exceptArrayPtr, (size_t) exceptArrayBytes); } else { codePtr->exceptArrayPtr = NULL; } - p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ - if (auxDataArrayBytes > 0) { - codePtr->auxDataArrayPtr = (AuxData *) p; - memcpy(p, envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes); - } else { - codePtr->auxDataArrayPtr = NULL; - } - - p += auxDataArrayBytes; + p += exceptArrayBytes; + + codePtr->auxData = envPtr->auxData; + envPtr->auxData = NULL; + #ifndef TCL_COMPILE_DEBUG EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); #else nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); if (((size_t)(nextPtr - p)) != cmdLocBytes) { @@ -3108,113 +3158,24 @@ * environment's CmdLocation array is grown if necessary. * *---------------------------------------------------------------------- */ -static void +static CmdLocation * EnterCmdStartData( CompileEnv *envPtr, /* Points to the compilation environment * structure in which to enter command * location information. */ - int cmdIndex, /* Index of the command whose start data is - * being set. */ int srcOffset, /* Offset of first char of the command. */ int codeOffset) /* Offset of first byte of command code. */ { - CmdLocation *cmdLocPtr; - - if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { - Tcl_Panic("EnterCmdStartData: bad command index %d", cmdIndex); - } - - if (cmdIndex >= envPtr->cmdMapEnd) { - /* - * Expand the command location array by allocating more storage from - * the heap. The currently allocated CmdLocation entries are stored - * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive). - */ - - size_t currElems = envPtr->cmdMapEnd; - size_t newElems = 2 * currElems; - size_t currBytes = currElems * sizeof(CmdLocation); - size_t newBytes = newElems * sizeof(CmdLocation); - - if (envPtr->mallocedCmdMap) { - envPtr->cmdMapPtr = ckrealloc(envPtr->cmdMapPtr, newBytes); - } else { - /* - * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a - * ckrealloc equivalent for ourselves. - */ - - CmdLocation *newPtr = ckalloc(newBytes); - - memcpy(newPtr, envPtr->cmdMapPtr, currBytes); - envPtr->cmdMapPtr = newPtr; - envPtr->mallocedCmdMap = 1; - } - envPtr->cmdMapEnd = newElems; - } - - if (cmdIndex > 0) { - if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { - Tcl_Panic("EnterCmdStartData: cmd map not sorted by code offset"); - } - } - - cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex]; + CmdLocation *cmdLocPtr = BA_CmdLocation_Append(envPtr->cmdMap); cmdLocPtr->codeOffset = codeOffset; cmdLocPtr->srcOffset = srcOffset; cmdLocPtr->numSrcBytes = -1; cmdLocPtr->numCodeBytes = -1; -} - -/* - *---------------------------------------------------------------------- - * - * EnterCmdExtentData -- - * - * Registers the source and bytecode length for a command. This - * information is used at runtime to map between instruction pc and - * source locations. - * - * Results: - * None. - * - * Side effects: - * Inserts source and code length information into the compilation - * environment envPtr for the command at index cmdIndex. Starting source - * and bytecode information for the command must already have been - * registered. - * - *---------------------------------------------------------------------- - */ - -static void -EnterCmdExtentData( - CompileEnv *envPtr, /* Points to the compilation environment - * structure in which to enter command - * location information. */ - int cmdIndex, /* Index of the command whose source and code - * length data is being set. */ - int numSrcBytes, /* Number of command source chars. */ - int numCodeBytes) /* Offset of last byte of command code. */ -{ - CmdLocation *cmdLocPtr; - - if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { - Tcl_Panic("EnterCmdExtentData: bad command index %d", cmdIndex); - } - - if (cmdIndex > envPtr->cmdMapEnd) { - Tcl_Panic("EnterCmdExtentData: missing start data for command %d", - cmdIndex); - } - - cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex]; - cmdLocPtr->numSrcBytes = numSrcBytes; - cmdLocPtr->numCodeBytes = numCodeBytes; + return cmdLocPtr; } /* *---------------------------------------------------------------------- * TIP #280 @@ -3660,10 +3621,38 @@ } /* *---------------------------------------------------------------------- * + * TclFetchAuxData -- + * + * Fetch back from the CompileEnv an item of AuxData stored at + * index. + * + * Results: + * The ClientData previously stored by TclCreatAuxData(). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +TclFetchAuxData( + CompileEnv *envPtr, /* CompileEnv from which to fetch */ + int index) /* Index of AuxData to fetch */ +{ + if (envPtr->auxData == NULL) { + return NULL; + } + return BA_AuxData_At(envPtr->auxData, index)->clientData; +} + +/* + *---------------------------------------------------------------------- + * * TclCreateAuxData -- * * Procedure that allocates and initializes a new AuxData structure in a * CompileEnv's array of compilation auxiliary data records. These * AuxData records hold information created during compilation by @@ -3689,158 +3678,20 @@ const AuxDataType *typePtr, /* Pointer to the type to attach to this * AuxData */ register CompileEnv *envPtr)/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { - int index; /* Index for the new AuxData structure. */ - register AuxData *auxDataPtr; - /* Points to the new AuxData structure */ - - index = envPtr->auxDataArrayNext; - if (index >= envPtr->auxDataArrayEnd) { - /* - * Expand the AuxData array. The currently allocated entries are - * stored between elements 0 and (envPtr->auxDataArrayNext - 1) - * [inclusive]. - */ - - size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); - int newElems = 2*envPtr->auxDataArrayEnd; - size_t newBytes = newElems * sizeof(AuxData); - - if (envPtr->mallocedAuxDataArray) { - envPtr->auxDataArrayPtr = - ckrealloc(envPtr->auxDataArrayPtr, newBytes); - } else { - /* - * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must - * code a ckrealloc equivalent for ourselves. - */ - - AuxData *newPtr = ckalloc(newBytes); - - memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes); - envPtr->auxDataArrayPtr = newPtr; - envPtr->mallocedAuxDataArray = 1; - } - envPtr->auxDataArrayEnd = newElems; - } - envPtr->auxDataArrayNext++; - - auxDataPtr = &envPtr->auxDataArrayPtr[index]; + AuxData *auxDataPtr; /* Points to the new AuxData structure */ + + if (envPtr->auxData == NULL) { + envPtr->auxData = BA_AuxData_Create(); + } + + auxDataPtr = BA_AuxData_Append(envPtr->auxData); auxDataPtr->clientData = clientData; auxDataPtr->type = typePtr; - return index; -} - -/* - *---------------------------------------------------------------------- - * - * TclInitJumpFixupArray -- - * - * Initializes a JumpFixupArray structure to hold some number of jump - * fixup entries. - * - * Results: - * None. - * - * Side effects: - * The JumpFixupArray structure is initialized. - * - *---------------------------------------------------------------------- - */ - -void -TclInitJumpFixupArray( - register JumpFixupArray *fixupArrayPtr) - /* Points to the JumpFixupArray structure to - * initialize. */ -{ - fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; - fixupArrayPtr->next = 0; - fixupArrayPtr->end = JUMPFIXUP_INIT_ENTRIES - 1; - fixupArrayPtr->mallocedArray = 0; -} - -/* - *---------------------------------------------------------------------- - * - * TclExpandJumpFixupArray -- - * - * Procedure that uses malloc to allocate more storage for a jump fixup - * array. - * - * Results: - * None. - * - * Side effects: - * The jump fixup array in *fixupArrayPtr is reallocated to a new array - * of double the size, and if fixupArrayPtr->mallocedArray is non-zero - * the old array is freed. Jump fixup structures are copied from the old - * array to the new one. - * - *---------------------------------------------------------------------- - */ - -void -TclExpandJumpFixupArray( - register JumpFixupArray *fixupArrayPtr) - /* Points to the JumpFixupArray structure to - * enlarge. */ -{ - /* - * The currently allocated jump fixup entries are stored from fixup[0] up - * to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume - * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd. - */ - - size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); - int newElems = 2*(fixupArrayPtr->end + 1); - size_t newBytes = newElems * sizeof(JumpFixup); - - if (fixupArrayPtr->mallocedArray) { - fixupArrayPtr->fixup = ckrealloc(fixupArrayPtr->fixup, newBytes); - } else { - /* - * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a - * ckrealloc equivalent for ourselves. - */ - - JumpFixup *newPtr = ckalloc(newBytes); - - memcpy(newPtr, fixupArrayPtr->fixup, currBytes); - fixupArrayPtr->fixup = newPtr; - fixupArrayPtr->mallocedArray = 1; - } - fixupArrayPtr->end = newElems; -} - -/* - *---------------------------------------------------------------------- - * - * TclFreeJumpFixupArray -- - * - * Free any storage allocated in a jump fixup array structure. - * - * Results: - * None. - * - * Side effects: - * Allocated storage in the JumpFixupArray structure is freed. - * - *---------------------------------------------------------------------- - */ - -void -TclFreeJumpFixupArray( - register JumpFixupArray *fixupArrayPtr) - /* Points to the JumpFixupArray structure to - * free. */ -{ - if (fixupArrayPtr->mallocedArray) { - ckfree(fixupArrayPtr->fixup); - } + return (int) (BA_AuxData_Size(envPtr->auxData) - 1); } /* *---------------------------------------------------------------------- * @@ -3934,12 +3785,14 @@ int jumpDist, /* Jump distance to set in jump instr. */ int distThreshold) /* Maximum distance before the two byte jump * is grown to five bytes. */ { unsigned char *jumpPc, *p; - int firstCmd, lastCmd, firstRange, lastRange, k; + int firstRange, lastRange, k; unsigned numBytes; + CmdLocation *cmdLocPtr = NULL; + BP_CmdLocation ptr; if (jumpDist <= distThreshold) { jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; switch (jumpFixupPtr->jumpType) { case TCL_UNCONDITIONAL_JUMP: @@ -3987,16 +3840,14 @@ /* * Adjust the code offsets for any commands and any ExceptionRange records * between the jump and the current code address. */ - firstCmd = jumpFixupPtr->cmdIndex; - lastCmd = envPtr->numCommands - 1; - if (firstCmd < lastCmd) { - for (k = firstCmd; k <= lastCmd; k++) { - envPtr->cmdMapPtr[k].codeOffset += 3; - } + for (cmdLocPtr = BA_CmdLocation_Get(envPtr->cmdMap, + jumpFixupPtr->cmdIndex, &ptr); cmdLocPtr; + cmdLocPtr = BP_CmdLocation_Next(&ptr)) { + cmdLocPtr->codeOffset += 3; } firstRange = jumpFixupPtr->exceptIndex; lastRange = envPtr->exceptArrayNext - 1; for (k = firstRange; k <= lastRange; k++) { @@ -4257,10 +4108,34 @@ } /* *---------------------------------------------------------------------- * + * TclCmdStartAddress -- + * + * Results: + * None. + * + * Side effects: + * Deletes all entries in the hash table of AuxData types. + * + *---------------------------------------------------------------------- + */ + +void * +TclCmdStartAddress( + CompileEnv *envPtr, + int i) +{ + BA_CmdLocation *map = envPtr->cmdMap; + + return envPtr->codeStart + BA_CmdLocation_At(map, i)->codeOffset; +} + +/* + *---------------------------------------------------------------------- + * * GetCmdLocEncodingSize -- * * Computes the total number of bytes needed to encode the command * location information for some compiled code. * @@ -4277,50 +4152,52 @@ GetCmdLocEncodingSize( CompileEnv *envPtr) /* Points to compilation environment structure * containing the CmdLocation structure to * encode. */ { - register CmdLocation *mapPtr = envPtr->cmdMapPtr; - int numCmds = envPtr->numCommands; int codeDelta, codeLen, srcDelta, srcLen; int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; /* The offsets in their respective byte * sequences where the next encoded offset or * length should go. */ - int prevCodeOffset, prevSrcOffset, i; + int prevCodeOffset, prevSrcOffset; + BA_CmdLocation *map = envPtr->cmdMap; + CmdLocation *cmdLocPtr; + BP_CmdLocation ptr; codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; prevCodeOffset = prevSrcOffset = 0; - for (i = 0; i < numCmds; i++) { - codeDelta = mapPtr[i].codeOffset - prevCodeOffset; + for (cmdLocPtr = BA_CmdLocation_First(map, &ptr); cmdLocPtr; + cmdLocPtr = BP_CmdLocation_Next(&ptr)) { + codeDelta = cmdLocPtr->codeOffset - prevCodeOffset; if (codeDelta < 0) { Tcl_Panic("GetCmdLocEncodingSize: bad code offset"); } else if (codeDelta <= 127) { codeDeltaNext++; } else { codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ } - prevCodeOffset = mapPtr[i].codeOffset; + prevCodeOffset = cmdLocPtr->codeOffset; - codeLen = mapPtr[i].numCodeBytes; + codeLen = cmdLocPtr->numCodeBytes; if (codeLen < 0) { Tcl_Panic("GetCmdLocEncodingSize: bad code length"); } else if (codeLen <= 127) { codeLengthNext++; } else { codeLengthNext += 5;/* 1 byte for 0xFF, 4 for length */ } - srcDelta = mapPtr[i].srcOffset - prevSrcOffset; + srcDelta = cmdLocPtr->srcOffset - prevSrcOffset; if ((-127 <= srcDelta) && (srcDelta <= 127) && (srcDelta != -1)) { srcDeltaNext++; } else { srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ } - prevSrcOffset = mapPtr[i].srcOffset; + prevSrcOffset = cmdLocPtr->srcOffset; - srcLen = mapPtr[i].numSrcBytes; + srcLen = cmdLocPtr->numSrcBytes; if (srcLen < 0) { Tcl_Panic("GetCmdLocEncodingSize: bad source length"); } else if (srcLen <= 127) { srcLengthNext++; } else { @@ -4361,24 +4238,25 @@ * command location information. */ unsigned char *startPtr) /* Points to the first byte in codePtr's * memory block where the location information * is to be stored. */ { - register CmdLocation *mapPtr = envPtr->cmdMapPtr; - int numCmds = envPtr->numCommands; register unsigned char *p = startPtr; int codeDelta, codeLen, srcDelta, srcLen, prevOffset; - register int i; + BA_CmdLocation *map = envPtr->cmdMap; + BP_CmdLocation ptr; + CmdLocation *cmdLocPtr; /* * Encode the code offset for each command as a sequence of deltas. */ codePtr->codeDeltaStart = p; prevOffset = 0; - for (i = 0; i < numCmds; i++) { - codeDelta = mapPtr[i].codeOffset - prevOffset; + for (cmdLocPtr = BA_CmdLocation_First(map, &ptr); cmdLocPtr; + cmdLocPtr = BP_CmdLocation_Next(&ptr)) { + codeDelta = cmdLocPtr->codeOffset - prevOffset; if (codeDelta < 0) { Tcl_Panic("EncodeCmdLocMap: bad code offset"); } else if (codeDelta <= 127) { TclStoreInt1AtPtr(codeDelta, p); p++; @@ -4386,20 +4264,21 @@ TclStoreInt1AtPtr(0xFF, p); p++; TclStoreInt4AtPtr(codeDelta, p); p += 4; } - prevOffset = mapPtr[i].codeOffset; + prevOffset = cmdLocPtr->codeOffset; } /* * Encode the code length for each command. */ codePtr->codeLengthStart = p; - for (i = 0; i < numCmds; i++) { - codeLen = mapPtr[i].numCodeBytes; + for (cmdLocPtr = BA_CmdLocation_First(map, &ptr); cmdLocPtr; + cmdLocPtr = BP_CmdLocation_Next(&ptr)) { + codeLen = cmdLocPtr->numCodeBytes; if (codeLen < 0) { Tcl_Panic("EncodeCmdLocMap: bad code length"); } else if (codeLen <= 127) { TclStoreInt1AtPtr(codeLen, p); p++; @@ -4415,31 +4294,33 @@ * Encode the source offset for each command as a sequence of deltas. */ codePtr->srcDeltaStart = p; prevOffset = 0; - for (i = 0; i < numCmds; i++) { - srcDelta = mapPtr[i].srcOffset - prevOffset; + for (cmdLocPtr = BA_CmdLocation_First(map, &ptr); cmdLocPtr; + cmdLocPtr = BP_CmdLocation_Next(&ptr)) { + srcDelta = cmdLocPtr->srcOffset - prevOffset; if ((-127 <= srcDelta) && (srcDelta <= 127) && (srcDelta != -1)) { TclStoreInt1AtPtr(srcDelta, p); p++; } else { TclStoreInt1AtPtr(0xFF, p); p++; TclStoreInt4AtPtr(srcDelta, p); p += 4; } - prevOffset = mapPtr[i].srcOffset; + prevOffset = cmdLocPtr->srcOffset; } /* * Encode the source length for each command. */ codePtr->srcLengthStart = p; - for (i = 0; i < numCmds; i++) { - srcLen = mapPtr[i].numSrcBytes; + for (cmdLocPtr = BA_CmdLocation_First(map, &ptr); cmdLocPtr; + cmdLocPtr = BP_CmdLocation_Next(&ptr)) { + srcLen = cmdLocPtr->numSrcBytes; if (srcLen < 0) { Tcl_Panic("EncodeCmdLocMap: bad source length"); } else if (srcLen <= 127) { TclStoreInt1AtPtr(srcLen, p); p++; @@ -4502,11 +4383,11 @@ statsPtr->currentLitBytes += (double) codePtr->numLitObjects * sizeof(Tcl_Obj *); statsPtr->currentExceptBytes += (double) codePtr->numExceptRanges * sizeof(ExceptionRange); statsPtr->currentAuxBytes += (double) - codePtr->numAuxDataItems * sizeof(AuxData); + BA_AuxData_Size(codePtr->auxData) * sizeof(AuxData); statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes; } #endif /* TCL_COMPILE_STATS */ /* Index: generic/tclCompile.h ================================================================== --- generic/tclCompile.h +++ generic/tclCompile.h @@ -152,25 +152,10 @@ * of this array to be updated. When * numContinueTargets==0, this is NULL. */ int allocContinueTargets; /* The size of the continueTargets array. */ } ExceptionAux; -/* - * Structure used to map between instruction pc and source locations. It - * defines for each compiled Tcl command its code's starting offset and its - * source's starting offset and length. Note that the code offset increases - * monotonically: that is, the table is sorted in code offset order. The - * source offset is not monotonic. - */ - -typedef struct { - int codeOffset; /* Offset of first byte of command code. */ - int numCodeBytes; /* Number of bytes for command's code. */ - int srcOffset; /* Offset of first char of the command. */ - int numSrcBytes; /* Number of command source chars. */ -} CmdLocation; - /* * TIP #280 * Structure to record additional location information for byte code. This * information is internal and not saved. i.e. tbcload'ed code will not have * this information. It records the lines for all words of all commands found @@ -267,21 +252,23 @@ const AuxDataType *type; /* Pointer to the AuxData type associated with * this ClientData. */ ClientData clientData; /* The compilation data itself. */ } AuxData; +/* Forward declarations for fields below */ +struct BrodnikArray_CmdLocation; +TclBrodnikArrayDeclare(AuxData,MODULE_SCOPE); + /* * Structure defining the compilation environment. After compilation, fields * describing bytecode instructions are copied out into the more compact * ByteCode structure defined below. */ #define COMPILEENV_INIT_CODE_BYTES 250 #define COMPILEENV_INIT_NUM_OBJECTS 60 #define COMPILEENV_INIT_EXCEPT_RANGES 5 -#define COMPILEENV_INIT_CMD_MAP_SIZE 40 -#define COMPILEENV_INIT_AUX_DATA_SIZE 5 typedef struct CompileEnv { Interp *iPtr; /* Interpreter containing the code being * compiled. Commands and their compile procs * are specific to an interpreter so the code @@ -303,23 +290,21 @@ * if no ranges have been compiled. */ int maxStackDepth; /* Maximum number of stack elements needed to * execute the code. Set by compilation * procedures before returning. */ int currStackDepth; /* Current stack depth. */ - LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl - * objects referenced by this compiled code. - * Indexed by the string representations of - * the literals. Used to avoid creating - * duplicate objects. */ + Tcl_HashTable litMap; /* Map from literal value to int index where + * that value is stored in literalArrayPtr. + * Used to prevent dup value refs. */ unsigned char *codeStart; /* Points to the first byte of the code. */ unsigned char *codeNext; /* Points to next code array byte to use. */ unsigned char *codeEnd; /* Points just after the last allocated code * array byte. */ int mallocedCodeArray; /* Set 1 if code array was expanded and * codeStart points into the heap.*/ - LiteralEntry *literalArrayPtr; - /* Points to start of LiteralEntry array. */ + Tcl_Obj **literalArrayPtr; + /* Points of array of literal values. */ int literalArrayNext; /* Index of next free object array entry. */ int literalArrayEnd; /* Index just after last obj array entry. */ int mallocedLiteralArray; /* 1 if object array was expanded and objArray * points into the heap, else 0. */ ExceptionRange *exceptArrayPtr; @@ -336,38 +321,25 @@ ExceptionAux *exceptAuxArrayPtr; /* Array of information used to restore the * state when processing BREAK/CONTINUE * exceptions. Must be the same size as the * exceptArrayPtr. */ - CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. + struct BrodnikArray_CmdLocation *cmdMap; + /* Points to array of CmdLocation. * numCommands is the index of the next entry * to use; (numCommands-1) is the entry index * for the last command. */ - int cmdMapEnd; /* Index after last CmdLocation entry. */ - int mallocedCmdMap; /* 1 if command map array was expanded and - * cmdMapPtr points in the heap, else 0. */ - AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ - int auxDataArrayNext; /* Next free compile aux data array index. - * auxDataArrayNext is the number of aux data - * items and (auxDataArrayNext-1) is index of - * current aux data array entry. */ - int auxDataArrayEnd; /* Index after last aux data array entry. */ - int mallocedAuxDataArray; /* 1 if aux data array was expanded and - * auxDataArrayPtr points in heap else 0. */ + BA_AuxData *auxData; /* Points to array of AuxData */ unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; /* Initial storage for code. */ - LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; - /* Initial storage of LiteralEntry array. */ + Tcl_Obj *staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; + /* Initial storage of literal value array. */ ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial ExceptionRange array storage. */ ExceptionAux staticExAuxArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial static except auxiliary info array * storage. */ - CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; - /* Initial storage for cmd location map. */ - AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; - /* Initial storage for aux data array. */ /* TIP #280 */ ExtCmdLoc *extCmdMapPtr; /* Extended command location information for * 'info frame'. */ int line; /* First line of the script, based on the * invoking context, then the line of the @@ -409,10 +381,12 @@ #define TCL_BYTECODE_RESOLVE_VARS 0x0002 #define TCL_BYTECODE_RECOMPILE 0x0004 +#define TCL_BYTECODE_FREE_LITERALS 0x0008 + typedef struct ByteCode { TclHandle interpHandle; /* Handle for interpreter containing the * compiled code. Commands and their compile * procs are specific to an interpreter so the * code emitted will depend on the @@ -452,11 +426,10 @@ int numCommands; /* Number of commands compiled. */ int numSrcBytes; /* Number of source bytes compiled. */ int numCodeBytes; /* Number of code bytes. */ int numLitObjects; /* Number of objects in literal array. */ int numExceptRanges; /* Number of ExceptionRange array elems. */ - int numAuxDataItems; /* Number of AuxData items. */ int numCmdLocBytes; /* Number of bytes needed for encoded command * location information. */ int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; * -1 if no ranges were compiled. */ int maxStackDepth; /* Maximum number of stack elements needed to @@ -469,13 +442,11 @@ * byte. */ ExceptionRange *exceptArrayPtr; /* Points to the start of the ExceptionRange * array. This is just after the last object * in the object array. */ - AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data - * array. This is just after the last entry in - * the ExceptionRange array. */ + BA_AuxData *auxData; /* Array of auxiliary data. */ unsigned char *codeDeltaStart; /* Points to the first of a sequence of bytes * that encode the change in the starting * offset of each command's code. If -127 <= * delta <= 127, it is encoded as 1 byte, @@ -940,22 +911,11 @@ * This field is used to adjust the code * offsets in subsequent ExceptionRange * records when a jump is grown from 2 bytes * to 5 bytes. */ } JumpFixup; - -#define JUMPFIXUP_INIT_ENTRIES 10 - -typedef struct JumpFixupArray { - JumpFixup *fixup; /* Points to start of jump fixup array. */ - int next; /* Index of next free array entry. */ - int end; /* Index of last usable entry in array. */ - int mallocedArray; /* 1 if array was expanded and fixups points - * into the heap, else 0. */ - JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; - /* Initial storage for jump fixup array. */ -} JumpFixupArray; +TclBrodnikArrayDeclare(JumpFixup,MODULE_SCOPE); /* * The structure describing one variable list of a foreach command. Note that * only foreach commands inside procedure bodies are compiled inline so a * ForeachVarList structure always describes local variables. Furthermore, @@ -1007,11 +967,11 @@ } JumptableInfo; MODULE_SCOPE const AuxDataType tclJumptableInfoType; #define JUMPTABLEINFO(envPtr, index) \ - ((JumptableInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) + ((JumptableInfo*)(TclFetchAuxData(envPtr, TclGetUInt4AtPtr(index)))) /* * Structure used to hold information about a [dict update] command that is * needed during program execution. These structures are stored in CompileEnv * and ByteCode structures as auxiliary data. @@ -1067,19 +1027,20 @@ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, Tcl_Parse *parsePtr, int depth, Command *cmdPtr, CompileEnv *envPtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); +MODULE_SCOPE void * TclCmdStartAddress(CompileEnv *envPtr, int i); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, int numBytes, CompileEnv *envPtr, int optimize); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr); -MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Token *TclCompileInvocation(Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, const char *script, int numBytes, CompileEnv *envPtr); @@ -1094,39 +1055,36 @@ const AuxDataType *typePtr, CompileEnv *envPtr); MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, - size_t length, TCL_HASH_TYPE hash, int *newPtr, - Namespace *nsPtr, int flags, - LiteralEntry **globalPtrPtr); + int length); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); +MODULE_SCOPE void TclDisposeFailedCompile(CompileEnv *envPtr, int num); MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr, TclJumpType jumpType, JumpFixup *jumpFixupPtr); MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...); MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, int catchOnly, ByteCode *codePtr); -MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); +MODULE_SCOPE ClientData TclFetchAuxData(CompileEnv *envPtr, int index); MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index); MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, int distThreshold); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); -MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, int numBytes, const CmdFrame *invoker, int word); -MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, int returnCode, ExceptionAux **auxPtrPtr); MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr, ExceptionAux *auxPtr); @@ -1197,19 +1155,10 @@ * Macros and flag values used by Tcl bytecode compilation and execution * modules inside the Tcl core but not used outside. *---------------------------------------------------------------- */ -/* - * Simplified form to access AuxData. - * - * ClientData TclFetchAuxData(CompileEng *envPtr, int index); - */ - -#define TclFetchAuxData(envPtr, index) \ - (envPtr)->auxDataArrayPtr[(index)].clientData - #define LITERAL_ON_HEAP 0x01 #define LITERAL_CMD_NAME 0x02 #define LITERAL_UNSHARED 0x04 /* Index: generic/tclDisassemble.c ================================================================== --- generic/tclDisassemble.c +++ generic/tclDisassemble.c @@ -284,11 +284,11 @@ Tcl_GetString(fileObj), line); } Tcl_AppendPrintfToObj(bufferObj, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, - codePtr->numLitObjects, codePtr->numAuxDataItems, + codePtr->numLitObjects, (int) BA_AuxData_Size(codePtr->auxData), codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS codePtr->numSrcBytes? codePtr->structureSize/(float)codePtr->numSrcBytes : #endif @@ -300,11 +300,11 @@ (unsigned long) codePtr->structureSize, (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), codePtr->numCodeBytes, (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + (unsigned long) (BA_AuxData_Size(codePtr->auxData) * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ /* * If the ByteCode is the compiled body of a Tcl procedure, print @@ -596,11 +596,11 @@ Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); break; case OPERAND_AUX4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - auxPtr = &codePtr->auxDataArrayPtr[opnd]; + auxPtr = BA_AuxData_At(codePtr->auxData,opnd); break; case OPERAND_IDX4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if (opnd >= -1) { Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); @@ -1118,28 +1118,34 @@ /* * Get the auxiliary data from the bytecode. */ aux = Tcl_NewObj(); - for (i=0 ; inumAuxDataItems ; i++) { - AuxData *auxData = &codePtr->auxDataArrayPtr[i]; - Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); - - if (auxData->type->disassembleProc) { - Tcl_Obj *desc = Tcl_NewObj(); - - Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc); - auxDesc = desc; - auxData->type->disassembleProc(auxData->clientData, auxDesc, - codePtr, 0); - } else if (auxData->type->printProc) { - Tcl_Obj *desc = Tcl_NewObj(); - - auxData->type->printProc(auxData->clientData, desc, codePtr, 0); - Tcl_ListObjAppendElement(NULL, auxDesc, desc); - } - Tcl_ListObjAppendElement(NULL, aux, auxDesc); + if (codePtr->auxData) { + BP_AuxData ptr; + AuxData *auxData = BA_AuxData_First(codePtr->auxData, &ptr); + + while (auxData) { + Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); + + if (auxData->type->disassembleProc) { + Tcl_Obj *desc = Tcl_NewObj(); + + Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), + auxDesc); + auxDesc = desc; + auxData->type->disassembleProc(auxData->clientData, auxDesc, + codePtr, 0); + } else if (auxData->type->printProc) { + Tcl_Obj *desc = Tcl_NewObj(); + + auxData->type->printProc(auxData->clientData, desc, codePtr, 0); + Tcl_ListObjAppendElement(NULL, auxDesc, desc); + } + Tcl_ListObjAppendElement(NULL, aux, auxDesc); + auxData = BP_AuxData_Next(&ptr); + } } /* * Get the exception ranges from the bytecode. */ Index: generic/tclEnsemble.c ================================================================== --- generic/tclEnsemble.c +++ generic/tclEnsemble.c @@ -2598,57 +2598,11 @@ Tcl_SetHashValue(hPtr, valueObj); Tcl_IncrRefCount(valueObj); Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); } } else { - /* - * Discover what commands are actually exported by the namespace. - * What we have is an array of patterns and a hash table whose keys - * are the command names exported by the namespace (the contents do - * not matter here.) We must find out what commands are actually - * exported by filtering each command in the namespace against each of - * the patterns in the export list. Note that we use an intermediate - * hash table to make memory management easier, and because that makes - * exact matching far easier too. - * - * Suggestion for future enhancement: compute the unique prefixes and - * place them in the hash too, which should make for even faster - * matching. - */ - - hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); - for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { - char *nsCmdName = /* Name of command in namespace. */ - Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); - - for (i=0 ; insPtr->numExportPatterns ; i++) { - if (Tcl_StringMatch(nsCmdName, - ensemblePtr->nsPtr->exportArrayPtr[i])) { - hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); - - /* - * Remember, hash entries have a full reference to the - * substituted part of the command (as a list) as their - * content! - */ - - if (isNew) { - Tcl_Obj *cmdObj, *cmdPrefixObj; - - TclNewObj(cmdObj); - Tcl_AppendStringsToObj(cmdObj, - ensemblePtr->nsPtr->fullName, - (ensemblePtr->nsPtr->parentPtr ? "::" : ""), - nsCmdName, NULL); - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - break; - } - } - } + TclFillTableWithExports(ensemblePtr->nsPtr, hash); } if (hash->numEntries == 0) { ensemblePtr->subcommandArrayPtr = NULL; return; @@ -3172,11 +3126,11 @@ { int result, i; Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; - int savedAuxDataArrayNext = envPtr->auxDataArrayNext; + size_t savedAuxDataSize = BA_AuxData_Size(envPtr->auxData); int savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG int savedExceptDepth = envPtr->exceptDepth; #endif DefineLineInformation; @@ -3249,25 +3203,17 @@ } auxPtr++; } envPtr->exceptArrayNext = savedExceptArrayNext; - if (savedAuxDataArrayNext != envPtr->auxDataArrayNext) { - AuxData *auxDataPtr = envPtr->auxDataArrayPtr; - AuxData *auxDataEnd = auxDataPtr; - - auxDataPtr += savedAuxDataArrayNext; - auxDataEnd += envPtr->auxDataArrayNext; - - while (auxDataPtr < auxDataEnd) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; - } - envPtr->auxDataArrayNext = savedAuxDataArrayNext; - } + while (savedAuxDataSize < BA_AuxData_Size(envPtr->auxData)) { + AuxData *auxDataPtr = BA_AuxData_Detach(envPtr->auxData); + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + } + envPtr->currStackDepth = savedStackDepth; envPtr->codeNext = envPtr->codeStart + savedCodeNext; #ifdef TCL_COMPILE_DEBUG } else { /* @@ -3387,11 +3333,11 @@ { Tcl_Obj *objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, + (void) TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, parsePtr->numWords, envPtr); Tcl_DecrRefCount(objPtr); return TCL_OK; } Index: generic/tclEnv.c ================================================================== --- generic/tclEnv.c +++ generic/tclEnv.c @@ -12,17 +12,19 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" +#include "tclBrodnik.h" + +typedef char * pchar; +TclBrodnikArray(pchar); TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */ static struct { - int cacheSize; /* Number of env strings in cache. */ - char **cache; /* Array containing all of the environment - * strings that Tcl has allocated. */ + BA_pchar *cachePtr; /* Cache of the env strings we alloc'd */ #ifndef USE_PUTENV char **ourEnviron; /* Cache of the array that we allocate. We * need to track this in case another * subsystem swaps around the environ array * like we do. */ @@ -647,54 +649,42 @@ static void ReplaceString( const char *oldStr, /* Old environment string. */ char *newStr) /* New environment string. */ { - int i; - - /* - * Check to see if the old value was allocated by Tcl. If so, it needs to - * be deallocated to avoid memory leaks. Note that this algorithm is O(n), - * not O(1). This will result in n-squared behavior if lots of environment - * changes are being made. - */ - - for (i = 0; i < env.cacheSize; i++) { - if (env.cache[i]==oldStr || env.cache[i]==NULL) { - break; - } - } - if (i < env.cacheSize) { - /* - * Replace or delete the old value. - */ - - if (env.cache[i]) { - ckfree(env.cache[i]); - } - - if (newStr) { - env.cache[i] = newStr; - } else { - for (; i < env.cacheSize-1; i++) { - env.cache[i] = env.cache[i+1]; - } - env.cache[env.cacheSize-1] = NULL; - } - } else { - /* - * We need to grow the cache in order to hold the new string. - */ - - const int growth = 5; - - env.cache = ckrealloc(env.cache, - (env.cacheSize + growth) * sizeof(char *)); - env.cache[env.cacheSize] = newStr; - (void) memset(env.cache+env.cacheSize+1, 0, - (size_t) (growth-1) * sizeof(char *)); - env.cacheSize += growth; + if (env.cachePtr == NULL) { + env.cachePtr = BA_pchar_Create(); + } + + if (oldStr) { + BP_pchar ptr; + pchar *p = BA_pchar_First(env.cachePtr, &ptr); + + while (p) { + if (*p == oldStr) { + pchar *lastPtr; + + ckfree(*p); + + if (newStr) { + *p = newStr; + return; + } + + lastPtr = BA_pchar_Detach(env.cachePtr); + if (p != lastPtr) { + *p = *lastPtr; + } + return; + } + p = BP_pchar_Next(&ptr); + } + } + + if (newStr) { + pchar *newPtr = BA_pchar_Append(env.cachePtr); + *newPtr = newStr; } } /* *---------------------------------------------------------------------- @@ -723,22 +713,25 @@ * of the strings may no longer be in the environment. However, * determining which ones are ok to delete is n-squared, and is pretty * unlikely, so we don't bother. */ - if (env.cache) { - ckfree(env.cache); - env.cache = NULL; - env.cacheSize = 0; + if (env.cachePtr) { + BA_pchar_Destroy(env.cachePtr); + env.cachePtr = NULL; + } #ifndef USE_PUTENV - env.ourEnvironSize = 0; -#endif + if (env.ourEnviron && (env.ourEnviron != environ)) { + ckfree(env.ourEnviron); } + env.ourEnviron = NULL; + env.ourEnvironSize = 0; +#endif } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -4444,11 +4444,11 @@ * Jump to location looked up in a hashtable; fall through to next * instr if lookup fails. */ opnd = TclGetInt4AtPtr(pc+1); - jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; + jtPtr = BA_AuxData_At(codePtr->auxData, opnd)->clientData; TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); if (hPtr != NULL) { int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); @@ -6734,11 +6734,11 @@ * Initialize the temporary local var that holds the count of the * number of iterations of the loop body to -1. */ opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + infoPtr = BA_AuxData_At(codePtr->auxData, opnd)->clientData; iterTmpIndex = infoPtr->loopCtTemp; iterVarPtr = LOCAL(iterTmpIndex); oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { @@ -6768,11 +6768,11 @@ * the next value list element to each loop var. */ opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); - infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + infoPtr = BA_AuxData_At(codePtr->auxData, opnd)->clientData; numLists = infoPtr->numLists; /* * Increment the temp holding the loop iteration number. */ @@ -6897,11 +6897,11 @@ * Initialize the data for the looping construct, pushing the * corresponding Tcl_Objs to the stack. */ opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + infoPtr = BA_AuxData_At(codePtr->auxData, opnd)->clientData; numLists = infoPtr->numLists; TRACE(("%u => ", opnd)); /* * Compute the number of iterations that will be run: iterMax @@ -7539,11 +7539,11 @@ case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); TRACE(("%u => ", opnd)); varPtr = LOCAL(opnd); - duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; + duiPtr = BA_AuxData_At(codePtr->auxData, opnd2)->clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; @@ -7599,11 +7599,11 @@ case INST_DICT_UPDATE_END: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); TRACE(("%u => ", opnd)); varPtr = LOCAL(opnd); - duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; + duiPtr = BA_AuxData_At(codePtr->auxData, opnd2)->clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; @@ -9526,10 +9526,11 @@ register ByteCode *codePtr) /* The bytecode whose summary is printed to * stdout. */ { Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; + int numAuxDataItems = codePtr->auxData?BA_AuxData_Size(codePtr->auxData):0; fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); @@ -9537,11 +9538,11 @@ TclPrintSource(stdout, codePtr->source, 60); fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", codePtr->numCommands, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, - codePtr->numAuxDataItems, codePtr->maxStackDepth, + numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS codePtr->numSrcBytes? ((float)codePtr->structureSize)/codePtr->numSrcBytes : #endif 0.0); @@ -9551,11 +9552,11 @@ (unsigned long) codePtr->structureSize, (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)), codePtr->numCodeBytes, (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + (unsigned long) (numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, " Proc 0x%p, refCt %d, args %d, compiled locals %d\n", @@ -10110,18 +10111,14 @@ int TclLog2( register int value) /* The integer for which to compute the log * base 2. */ { - register int n = value; - register int result = 0; - - while (n > 1) { - n = n >> 1; - result++; - } - return result; + if (value == 0) { + return 0; + } + return TclMSB(value); } /* *---------------------------------------------------------------------- * ADDED generic/tclHAMT.c Index: generic/tclHAMT.c ================================================================== --- /dev/null +++ generic/tclHAMT.c @@ -0,0 +1,572 @@ +/* + * tclHAMT.c -- + * + * This file contains an implementation of a hash array mapped trie + * (HAMT). In the first draft, it is just an alternative hash table + * implementation, but later revisions may support concurrency much + * better. + * + * Contributions from Don Porter, NIST, 2015. (not subject to US copyright) + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclHAMT.h" +#include + +#if defined(HAVE_INTRIN_H) +# include +#endif + +/* These are values for 64-bit size_t */ +#define LEAF_SHIFT 4 +#define BRANCH_SHIFT 6 +/* Alternate values for 32-bit: +#define LEAF_SHIFT 2 +#define BRANCH_SHIFT 5 +*/ + +#define LEAF_MASK ~(((size_t)1 << (LEAF_SHIFT - 1)) - 1) +#define BRANCH_MASK (((size_t)1<= 2)) + return __builtin_popcountll((long long)value); +#else +#error NumBits not implemented! +#endif +} + +/* + *---------------------------------------------------------------------- + * + * GetSet -- + * + * This is the central trie-traversing routine that is the core of + * all insert, delete, and fetch operations on a HAMT. Look in + * the ArrayMap indicated by amPtr for the key. The operation to + * perform is encoded in the values of value and valuePtr. When + * both are NULL, we are to delete anything stored under the key. + * When value is NULL, but valuePtr is non-NULL, we are to fetch + * the value associated with key and write it to *valuePtr. When + * value is non-NULL, we are to store it associated with the key. + * If valuePtr is also non-NULL, we write to it any old value that + * was associated with the key that we are now overwriting. Whenever + * valuePtr is non-NULL and the key is not in the ArrayMap at the + * start of the operation, a NULL value is written to *valuePtr. + * + * Results: + * Pointer to the ArrayMap -- possibly revised -- after the requested + * operation is complete. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static ArrayMap * +GetSet( + ArrayMap *amPtr, + const size_t *hashPtr, + const TclHAMTKeyType *ktPtr, + const ClientData key, + const TclHAMTValType *vtPtr, + const ClientData value, + ClientData *valuePtr) +{ + size_t hash; + + if (amPtr == NULL) { + /* Empty array map */ + + if (valuePtr != NULL) { + *valuePtr = NULL; + } + if (value == NULL) { + return amPtr; + } + } + + if (hashPtr) { + hash = *hashPtr; + } else { + if (ktPtr && ktPtr->hashProc) { + hash = ktPtr->hashProc(key); + } else { + hash = (size_t) key; + } + hashPtr = &hash; + } + + if (amPtr == NULL) { + return MakeLeafMap(hash, ktPtr, key, vtPtr, value); + } + + if ((hash & (amPtr->mask << 1)) != amPtr->id) { + /* Key doesn't belong in this array map */ + + if (valuePtr != NULL) { + *valuePtr = NULL; + } + if (value == NULL) { + return amPtr; + } else { + /* Make the map where the key does belong */ + ArrayMap *newPtr = MakeLeafMap(hash, ktPtr, key, vtPtr, value); + + /* Then connect it up to amPtr; Need common parent. */ + ArrayMap *parentPtr = ckalloc(AM_SIZE(2)); + ArrayMap **child = (ArrayMap **) &(parentPtr->children); + size_t mask = (~( + (1 << + (( (TclMSB(hash ^ amPtr->id) - LEAF_SHIFT) + / BRANCH_SHIFT) * BRANCH_SHIFT) + ) - 1)) << (LEAF_SHIFT - 1); + int shift = TclMSB(~mask) - LEAF_SHIFT; + size_t id = hash & (parentPtr->mask << 1); + + assert(id == (mask << 1) && amPtr->id); + + if (newPtr->id < amPtr->id) { + child[0] = newPtr; + child[1] = amPtr; + } else { + child[0] = amPtr; + child[1] = newPtr; + } + + parentPtr->mask = mask; + parentPtr->id = id; + parentPtr->map = ((size_t)1 << ((amPtr->id >> shift) + & BRANCH_MASK)) | ((size_t)1 << ((newPtr->id >> shift) + & BRANCH_MASK)); + + return parentPtr; + } + } + + /* hash & (amPtr->mask << 1) == amPtr->id */ + /* Key goes into this array map ...*/ + + if (amPtr->mask == LEAF_MASK) { + /* ... and this is a leaf array map */ + KeyValue **src = (KeyValue **)&(amPtr->children); + int size = NumBits(amPtr->map); + int slot = hash & (~(LEAF_MASK << 1)); + size_t tally = (size_t)1 << slot; + int idx = NumBits(amPtr->map & (tally - 1)); + + if (tally & amPtr->map) { + /* Slot is already occupied. Hash is right, but must check key. */ + KeyValue *kvPtr = src[idx]; + do { + if (ktPtr && ktPtr->isEqualProc) { + if (ktPtr->isEqualProc(key, kvPtr->key)) { + break; + } + } else { + if (key == kvPtr->key) { + break; + } + } + kvPtr = kvPtr->nextPtr; + } while (kvPtr); + + if (kvPtr) { + /* The key matches. */ + if (valuePtr != NULL) { + if (vtPtr && vtPtr->makeRefProc) { + *valuePtr = vtPtr->makeRefProc(kvPtr->value); + } else { + *valuePtr = kvPtr->value; + } + } + if (value == NULL) { + if (valuePtr != NULL) { + /* No destructive fetch */ + return amPtr; + } + + if (src[idx] == kvPtr) { + src[idx] = kvPtr->nextPtr; + } else { + KeyValue *ptr = src[idx]; + while (ptr->nextPtr != kvPtr) { + ptr = ptr->nextPtr; + } + ptr->nextPtr = kvPtr->nextPtr; + } + DeleteKeyValue(ktPtr, vtPtr, kvPtr); + + if (src[idx]) { + /* TODO: Persistence */ + return amPtr; + } else { + ArrayMap *shrinkPtr = ckalloc(AM_SIZE(size - 1)); + KeyValue **dst = (KeyValue **)&(shrinkPtr->children); + + memcpy(src, dst, idx*sizeof(KeyValue *)); + memcpy(src+idx+1, dst+idx, + (size - idx -1)*sizeof(KeyValue *)); + + ckfree(amPtr); + return shrinkPtr; + } + + } else { + /* Overwrite insertion */ + if (vtPtr && vtPtr->dropRefProc) { + vtPtr->dropRefProc(kvPtr->value); + } + if (vtPtr && vtPtr->makeRefProc) { + kvPtr->value = vtPtr->makeRefProc(value); + } else { + kvPtr->value = value; + } + /* TODO: Persistence! */ + return amPtr; + } + } else { + if (valuePtr != NULL) { + *valuePtr = NULL; + } + if (value == NULL) { + return amPtr; + } else { + /* Insert colliding key */ + KeyValue *newPtr = MakeKeyValue(ktPtr, key, vtPtr, value); + + newPtr->nextPtr = src[idx]; + src[idx] = newPtr; + /* TODO: Persistence! */ + return amPtr; + } + } + } else { + /* Slot is empty */ + + if (valuePtr != NULL) { + *valuePtr = NULL; + } + if (value == NULL) { + return amPtr; + } else { + ArrayMap *growPtr = ckalloc(AM_SIZE(size + 1)); + KeyValue **dst = (KeyValue **)&(growPtr->children); + + memcpy(src, dst, idx*sizeof(KeyValue *)); + dst[idx] = MakeKeyValue(ktPtr, key, vtPtr, value); + memcpy(src+idx, dst+idx+1, (size-idx)*sizeof(KeyValue *)); + + ckfree(amPtr); + return growPtr; + } + } + } else { + /* ... and this is a branch array map */ + ArrayMap **src = (ArrayMap **)&(amPtr->children); + int shift = TclMSB(~amPtr->mask) - LEAF_SHIFT; + int slot = (hash >> shift) & BRANCH_MASK; + size_t tally = (size_t)1 << slot; + int idx = NumBits(amPtr->map & (tally - 1)); + + if (tally & amPtr->map) { + /* Slot is already occupied. */ + + /* TODO: Persistence */ + src[idx] = GetSet(src[idx], hashPtr, ktPtr, key, + vtPtr, value, valuePtr); + return amPtr; + } else { + int size = NumBits(amPtr->map); + ArrayMap *growPtr = ckalloc(AM_SIZE(size + 1)); + ArrayMap **dst = (ArrayMap **)&(growPtr->children); + + memcpy(src, dst, idx*sizeof(KeyValue *)); + dst[idx] = GetSet(NULL, hashPtr, ktPtr, key, + vtPtr, value, valuePtr); + memcpy(src+idx, dst+idx+1, (size-idx)*sizeof(KeyValue *)); + + ckfree(amPtr); + return growPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclHAMTRemove-- + * + * Results: + * New revised TclHAMT. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclHAMT +TclHAMTRemove( + TclHAMT hamt, + ClientData key, + ClientData *valuePtr) +{ + HAMT *hamtPtr = hamt; + ClientData value; + + hamtPtr->amPtr = GetSet(hamtPtr->amPtr, NULL, + hamtPtr->keyTypePtr, key, + hamtPtr->valTypePtr, NULL, &value); + hamtPtr->amPtr = GetSet(hamtPtr->amPtr, NULL, + hamtPtr->keyTypePtr, key, + hamtPtr->valTypePtr, NULL, NULL); + if (valuePtr) { + *valuePtr = value; + } + return hamtPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclHAMTFetch -- + * + * Results: + * New revised TclHAMT. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +TclHAMTFetch( + TclHAMT hamt, + ClientData key) +{ + HAMT *hamtPtr = hamt; + ClientData value; + + hamtPtr->amPtr = GetSet(hamtPtr->amPtr, NULL, + hamtPtr->keyTypePtr, key, + hamtPtr->valTypePtr, NULL, &value); + return value; +} + +/* + *---------------------------------------------------------------------- + * + * TclHAMTInsert-- + * + * Results: + * New revised TclHAMT. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclHAMT +TclHAMTInsert( + TclHAMT hamt, + ClientData key, + ClientData value, + ClientData *valuePtr) +{ + HAMT *hamtPtr = hamt; + + /* TODO: Persistence */ + hamtPtr->amPtr = GetSet(hamtPtr->amPtr, NULL, + hamtPtr->keyTypePtr, key, + hamtPtr->valTypePtr, value, valuePtr); + return hamtPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclHAMTCreate -- + * + * Create and return a new empty TclHAMT, with key operations + * governed by the TclHAMTType struct pointed to by hktPtr. + * + * Results: + * A new empty TclHAMT. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclHAMT +TclHAMTCreate( + const TclHAMTKeyType *ktPtr, /* Custom key handling functions */ + const TclHAMTValType *vtPtr) /* Custom value handling functions */ +{ + HAMT *hamtPtr = ckalloc(sizeof(HAMT)); + + hamtPtr->keyTypePtr = ktPtr; + hamtPtr->valTypePtr = vtPtr; + hamtPtr->amPtr = NULL; + return hamtPtr; +} + +/* + *---------------------------------------------------------------------- + * + * MakeLeafMap -- + * + * Make an ArrayMap that sits among the leaves of the tree. Make + * the leaf suitable for the hash value, and create, store and + * return a pointer to a new KeyValue to store key. + * + * Results: + * Pointer to the new leaf ArrayMap. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static ArrayMap * +MakeLeafMap( + const size_t hash, + const TclHAMTKeyType *ktPtr, + const ClientData key, + const TclHAMTValType *vtPtr, + const ClientData value) +{ + ArrayMap *amPtr = ckalloc(AM_SIZE(1)); + + amPtr->mask = LEAF_MASK; + amPtr->id = hash & (LEAF_MASK << 1); + amPtr->map = 1 << (hash & ~(LEAF_MASK << 1)); + + /* child[0] */ + amPtr->children = MakeKeyValue(ktPtr, key, vtPtr, value); + return amPtr; +} + +/* + *---------------------------------------------------------------------- + * + * MakeKeyValue -- + * + * Make a KeyValue struct to hold key value pair. + * + * Results: + * Pointer to the new KeyValue struct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static KeyValue * +MakeKeyValue( + const TclHAMTKeyType *ktPtr, + const ClientData key, + const TclHAMTValType *vtPtr, + const ClientData value) +{ + KeyValue *kvPtr = ckalloc(sizeof(KeyValue)); + + kvPtr->nextPtr = NULL; + if (ktPtr && ktPtr->makeRefProc) { + kvPtr->key = ktPtr->makeRefProc(key); + } else { + kvPtr->key = key; + } + if (vtPtr && vtPtr->makeRefProc) { + kvPtr->value = vtPtr->makeRefProc(value); + } else { + kvPtr->value = value; + } + return kvPtr; +} + +static void +DeleteKeyValue( + const TclHAMTKeyType *ktPtr, + const TclHAMTValType *vtPtr, + KeyValue *kvPtr) +{ + if (ktPtr && ktPtr->dropRefProc) { + ktPtr->dropRefProc(kvPtr->key); + } + if (vtPtr && vtPtr->dropRefProc) { + vtPtr->dropRefProc(kvPtr->value); + } + ckfree(kvPtr); +} +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ ADDED generic/tclHAMT.h Index: generic/tclHAMT.h ================================================================== --- /dev/null +++ generic/tclHAMT.h @@ -0,0 +1,62 @@ +/* + * tclHAMT.h -- + * + * This file contains the declarations of the types and routines + * of the hash array map trie . + * + * Contributions from Don Porter, NIST, 2015. (not subject to US copyright) + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef TCL_HAMT_H +#define TCL_HAMT_H + +#include "tclInt.h" + +/* + * Opaque pointers to define the protoypes. + */ + +typedef struct HAMT *TclHAMT; + +typedef size_t (TclHashProc) (ClientData key); +typedef int (TclIsEqualProc) (ClientData x, ClientData y); +typedef ClientData (TclMakeRefProc) (ClientData value); +typedef void (TclDropRefProc) (ClientData value); + +typedef struct { + TclHashProc *hashProc; + TclIsEqualProc *isEqualProc; + TclMakeRefProc *makeRefProc; + TclDropRefProc *dropRefProc; +} TclHAMTKeyType; + +typedef struct { + TclMakeRefProc *makeRefProc; + TclDropRefProc *dropRefProc; +} TclHAMTValType; + +/* + * Interface procedure declarations. + */ + +MODULE_SCOPE TclHAMT TclHAMTCreate(const TclHAMTKeyType *ktPtr, + const TclHAMTValType *vtPtr); +MODULE_SCOPE void TclHAMTDelete(TclHAMT hamt); +MODULE_SCOPE TclHAMT TclHAMTInsert(TclHAMT hamt, ClientData key, + ClientData value, ClientData *valuePtr); +MODULE_SCOPE TclHAMT TclHAMTRemove(TclHAMT hamt, ClientData key, + ClientData *valuePtr); +MODULE_SCOPE ClientData TclHAMTFetch(TclHAMT hamt, ClientData key); + +#endif /* TCL_HAMT_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclIOUtil.c ================================================================== --- generic/tclIOUtil.c +++ generic/tclIOUtil.c @@ -1712,11 +1712,11 @@ Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution * will be performed on this name. */ const char *encodingName) /* If non-NULL, then use this encoding for the * file. NULL means use the system encoding. */ { - int length, result = TCL_ERROR; + int result = TCL_ERROR; Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile; Interp *iPtr; const char *string; Tcl_Channel chan; @@ -1798,18 +1798,17 @@ iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); - string = TclGetStringFromObj(objPtr, &length); /* * TIP #280 Force the evaluator to open a frame for a sourced file. */ iPtr->evalFlags |= TCL_EVAL_FILE; - result = TclEvalEx(interp, string, length, 0, 1, NULL, string); + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); /* * Now we have to be careful; the script may have changed the * iPtr->scriptFile value, so we must reset it without assuming it still * points to 'pathPtr'. @@ -1825,10 +1824,11 @@ } else if (result == TCL_ERROR) { /* * Record information telling where the error occurred. */ + int length; const char *pathString = TclGetStringFromObj(pathPtr, &length); int limit = 150; int overflow = (length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -32,10 +32,11 @@ * greater modularity. The order of the three groups of #includes is * important. For example, stdio.h is needed by tcl.h. */ #include "tclPort.h" +#include "tclBrodnik.h" #include #include #ifdef NO_STDLIB_H @@ -182,10 +183,18 @@ * (Bug #835020) */ #define TCL_AVOID_RESOLVERS 0x40000 +/* + *---------------------------------------------------------------- + * Declarations for the HAMT interface routines. + *---------------------------------------------------------------- + */ + +#include "tclHAMT.h" + /* *---------------------------------------------------------------- * Data structures related to namespaces. *---------------------------------------------------------------- */ @@ -273,21 +282,14 @@ * structure in the source namespace's command * table. */ TclVarHashTable varTable; /* Contains all the (global) variables * currently in this namespace. Indexed by * strings; values have type (Var *). */ - char **exportArrayPtr; /* Points to an array of string patterns - * specifying which commands are exported. A - * pattern may include "string match" style - * wildcard characters to specify multiple - * commands; however, no namespace qualifiers - * are allowed. NULL if no export patterns are - * registered. */ - int numExportPatterns; /* Number of export patterns currently - * registered using "namespace export". */ - int maxExportPatterns; /* Mumber of export patterns for which space - * is currently allocated. */ + Tcl_Obj *exportPatternList; + /* Set of "string match" style patterns that + * specify which commands are exported. + * No namespace qualifiers are allowed. */ int cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ @@ -2544,10 +2546,50 @@ */ typedef Tcl_CmdProc *TclCmdProcType; typedef Tcl_ObjCmdProc *TclObjCmdProcType; +/* + *---------------------------------------------------------------- + * Internal definitions related to parsing, substitution, evaluation + *---------------------------------------------------------------- + */ + +/* + * New internal Tcl_Token types. + * + * TCL_TOKEN_SCRIPT - Leading Tcl_Token type for an entire script. + * The numComponents field stores the number of + * commands in the script. + * TCL_TOKEN_SCRIPT_SUBST - So-called "command substituion" in Tcl is + * really "script substitution" and this internal + * Tcl_Token type indicates it. Unlike + * the TCL_TOKEN_COMMAND type, which also denotes + * "command substitution", the numComponents field + * is *not* always 0, so we can store the results + * of nested parsing, and avoid reparsing the + * same string again and again. The numComponents + * field stores the number of following Tcl_Tokens + * that are parsed from the nested script. The + * numComponents value is always at least 1, for + * the TCL_TOKEN_SCRIPT token that follows. + * TCL_TOKEN_CMD - Leading Tcl_Token type for a parsed Tcl command. * There will be one of these tokens for each + * command in a script. The numComponents field + * stores the number of words in the command. + * TCL_TOKEN_ERROR - This Tcl_Token type is used to represent a + * parse error. It may appear following all + * the commands that follow a TCL_TOKEN_SCRIPT + * token. The TCL_TOKEN_ERROR token represents + * the remainder of the original string that + * could not be parsed into commands. + */ + +#define TCL_TOKEN_SCRIPT 512 +#define TCL_TOKEN_SCRIPT_SUBST 1024 +#define TCL_TOKEN_CMD 2048 +#define TCL_TOKEN_ERROR 4096 + /* *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ @@ -2691,10 +2733,46 @@ */ MODULE_SCOPE char * tclEmptyStringRep; MODULE_SCOPE char tclEmptyString; +/* + * Flags used to control details of parsing. + * The first three are #define'd in tcl.h, so that may be set by callers + * of Tcl_SubstObj(). See the docs for what they do. + * + * #define TCL_SUBST_COMMANDS 001 + * #define TCL_SUBST_VARIABLES 002 + * #define TCL_SUBST_BACKSLASHES 004 + * + * tcl.h also #define's their combination for brevity: + * + * #define TCL_SUBST_ALL 007 + * + * The other flag values that control parsing are: + * + * PARSE_NESTED - Passed to ParseCommand to indicate that the + * close bracket character should be treated as + * a command terminator, as well as newlines, + * semi-colons, and end of string. + * + * PARSE_APPEND - Passed throughout the Parse routines to + * indicate that parsing should append to the + * Tcl_Parse structure passed in (by reference). + * If this flag is not set, some routines will + * re-initialize the Tcl_Parse structure. + * + * PARSE_USE_INTERNAL_TOKENS - Passed throughout the Parse routines to + * indicate the parse is being done for Tcl's + * internal use, so it is acceptable to use + * Tcl_Token types that are known only internally. + */ + +#define PARSE_NESTED 010 +#define PARSE_APPEND 020 +#define PARSE_USE_INTERNAL_TOKENS 040 + /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world, * introduced by/for NRE. *---------------------------------------------------------------- @@ -2821,10 +2899,13 @@ CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj); +MODULE_SCOPE void TclBAConvertIndices(size_t index, unsigned int *hiPtr, + unsigned int *loPtr); +MODULE_SCOPE size_t TclBAInvertIndices(unsigned int hi, unsigned int lo); MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, int strLen, const unsigned char *pattern, int ptnLen, int flags); MODULE_SCOPE double TclCeil(const mp_int *a); @@ -2850,10 +2931,14 @@ int *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evulation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); +MODULE_SCOPE int TclEvalScriptTokens(Tcl_Interp *interp, + Tcl_Token *tokenPtr, int length, int flags, + int line, int* clNextOuter, + const char* outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd; @@ -2869,10 +2954,12 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); +MODULE_SCOPE void TclFillTableWithExports(Namespace *nsPtr, + Tcl_HashTable *hash); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); MODULE_SCOPE void TclFinalizeEnvironment(void); @@ -2915,10 +3002,12 @@ MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, unsigned int *sizePtr); +MODULE_SCOPE Tcl_Token *TclGetTokensFromObj(Tcl_Obj *objPtr, + Tcl_Token **lastTokenPtrPtr); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); MODULE_SCOPE int TclInfoExistsCmd(ClientData dummy, Tcl_Interp *interp, @@ -2968,10 +3057,11 @@ MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); +MODULE_SCOPE int TclMSB(size_t n); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, @@ -2981,17 +3071,31 @@ Tcl_Namespace *nsPtr, int flags); MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); MODULE_SCOPE int TclParseBackslash(const char *src, int numBytes, int *readPtr, char *dst); +MODULE_SCOPE int TclParseCommand(Tcl_Interp *interp, const char *start, + int numBytes, int flags, Tcl_Parse *parsePtr); MODULE_SCOPE int TclParseHex(const char *src, int numBytes, int *resultPtr); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, int numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, int numBytes, Tcl_Parse *parsePtr); + +MODULE_SCOPE int TclParseQuotedString(Tcl_Interp *interp, + const char *start, int numBytes, + Tcl_Parse *parsePtr, int flags, + const char **termPtr); +MODULE_SCOPE Tcl_Token *TclParseScript(Tcl_Interp *interp, const char *script, + int numBytes, int flags, + Tcl_Token **lastTokenPtrPtr, const char **termPtr); +MODULE_SCOPE int TclParseScriptSubst(const char *src, int numBytes, + Tcl_Parse *parsePtr, int flags); +MODULE_SCOPE int TclParseVarName(Tcl_Interp *interp, const char *start, + int numBytes, Tcl_Parse *parsePtr, int flags); MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); @@ -3084,15 +3188,16 @@ int numBytes, int flags, int line, struct CompileEnv *envPtr); MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts, Tcl_Obj *const opts[], int *flagPtr); MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, - int numBytes, int flags, Tcl_Parse *parsePtr, - Tcl_InterpState *statePtr); + int numBytes, int flags, Tcl_Parse *parsePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line, - int *clNextOuter, const char *outerScript); + int* clNextOuter, const char* outerScript, + int flags); +MODULE_SCOPE Tcl_Obj * TclTokensCopy(Tcl_Obj *objPtr); MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); @@ -4393,11 +4498,11 @@ * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); *---------------------------------------------------------------- */ #define TclInvalidateNsCmdLookup(nsPtr) \ - if ((nsPtr)->numExportPatterns) { \ + if ((nsPtr)->exportPatternList) { \ (nsPtr)->exportLookupEpoch++; \ } \ if ((nsPtr)->commandPathLength) { \ (nsPtr)->cmdRefEpoch++; \ } Index: generic/tclLiteral.c ================================================================== --- generic/tclLiteral.c +++ generic/tclLiteral.c @@ -26,12 +26,13 @@ /* * Function prototypes for static functions in this file: */ -static int AddLocalLiteralEntry(CompileEnv *envPtr, - Tcl_Obj *objPtr, int localHash); +static Tcl_Obj * CreateLiteral(Interp *iPtr, const char *bytes, int length, + int *newPtr, Namespace *nsPtr, int flags, + LiteralEntry **globalPtrPtr); static void ExpandLocalLiteralArray(CompileEnv *envPtr); static unsigned HashString(const char *string, int length); #ifdef TCL_COMPILE_DEBUG static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -154,12 +155,11 @@ * table that has a string representation matching the argument * string. If nsPtr!=NULL then only literals stored for the namespace are * considered. * * Results: - * The literal object. If it was created in this call *newPtr is set to - * 1, else 0. NULL is returned if newPtr==NULL and no literal is found. + * The literal object. * * Side effects: * Increments the ref count of the global LiteralEntry since the caller * now holds a reference. If LITERAL_ON_HEAP is set in flags, this * function is given ownership of the string: if an object is created @@ -174,13 +174,22 @@ Tcl_Obj * TclCreateLiteral( Interp *iPtr, const char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ - size_t length, /* Number of bytes in the string. */ - TCL_HASH_TYPE hash, /* The string's hash. If -1, it will be - * computed here. */ + int length) /* Number of bytes in the string. */ +{ + int new; + return CreateLiteral(iPtr, bytes, length, &new, NULL, 0, NULL); +} + +static Tcl_Obj * +CreateLiteral( + Interp *iPtr, + const char *bytes, /* The start of the string. Note that this is + * not a NUL-terminated string. */ + int length, /* Number of bytes in the string. */ int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr) { @@ -191,39 +200,47 @@ /* * Is it in the interpreter's global literal table? */ - if (hash == (TCL_HASH_TYPE) -1) { - hash = HashString(bytes, length); + if (length < 0) { + length = strlen(bytes); } - globalHash = (hash & globalTablePtr->mask); + globalHash = (HashString(bytes, length) & globalTablePtr->mask); for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL; globalPtr = globalPtr->nextPtr) { objPtr = globalPtr->objPtr; if ((globalPtr->nsPtr == nsPtr) - && ((size_t)objPtr->length == length) && ((length == 0) + && (objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, length) == 0)))) { /* * A literal was found: return it */ if (newPtr) { *newPtr = 0; } - if (globalPtrPtr) { - *globalPtrPtr = globalPtr; - } if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } - globalPtr->refCount++; + if (globalPtrPtr) { + *globalPtrPtr = globalPtr; + } else { + globalPtr->refCount++; +#ifdef TCL_COMPILE_DEBUG + if (globalPtr->refCount < 1) { + Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", + "TclRegisterLiteral", (length>60? 60 : length), bytes, + globalPtr->refCount); + } +#endif + } return objPtr; } } - if (!newPtr) { + if (newPtr == NULL) { if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } return NULL; } @@ -310,11 +327,11 @@ iPtr->stats.literalCount[TclLog2(length)]++; #endif /*TCL_COMPILE_STATS*/ if (globalPtrPtr) { *globalPtrPtr = globalPtr; - } + } *newPtr = 1; return objPtr; } /* @@ -339,11 +356,11 @@ * by prior call to TclRegisterLiteral() */ { if (index >= (unsigned int) envPtr->literalArrayNext) { return NULL; } - return envPtr->literalArrayPtr[index].objPtr; + return envPtr->literalArrayPtr[index]; } /* *---------------------------------------------------------------------- * @@ -387,80 +404,44 @@ * the literal should not be shared accross * namespaces. */ { CompileEnv *envPtr = ePtr; Interp *iPtr = envPtr->iPtr; - LiteralTable *localTablePtr = &envPtr->localLitTable; - LiteralEntry *globalPtr, *localPtr; + Namespace *nsPtr = NULL; Tcl_Obj *objPtr; - unsigned hash; - int localHash, objIndex, new; - Namespace *nsPtr; - - if (length < 0) { - length = (bytes ? strlen(bytes) : 0); - } - hash = HashString(bytes, length); - - /* - * Is the literal already in the CompileEnv's local literal array? If so, - * just return its index. - */ - - localHash = (hash & localTablePtr->mask); - for (localPtr=localTablePtr->buckets[localHash] ; localPtr!=NULL; - localPtr = localPtr->nextPtr) { - objPtr = localPtr->objPtr; - if ((objPtr->length == length) && ((length == 0) - || ((objPtr->bytes[0] == bytes[0]) - && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { - if ((flags & LITERAL_ON_HEAP)) { - ckfree(bytes); - } - objIndex = (localPtr - envPtr->literalArrayPtr); -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(envPtr); -#endif /*TCL_COMPILE_DEBUG*/ - - return objIndex; - } - } - - /* - * The literal is new to this CompileEnv. If it is a command name, avoid - * sharing it accross namespaces, and try not to share it with non-cmd - * literals. Note that FQ command names can be shared, so that we register - * the namespace as the interp's global NS. + LiteralEntry *globalPtr; + Tcl_HashEntry *hePtr; + int objIndex, globalNew, new = 0; + + /* + * If the literal is a command name, avoid sharing it across namespaces, + * and try not to share it with non-cmd literals. Note that FQ command + * names can be shared, so that we register the namespace as the + * interp's global NS. */ if ((flags & LITERAL_CMD_NAME)) { if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) { nsPtr = iPtr->globalNsPtr; } else { nsPtr = iPtr->varFramePtr->nsPtr; } + } + + objPtr = CreateLiteral(iPtr, bytes, length, &globalNew, nsPtr, + flags, &globalPtr); + + hePtr = Tcl_CreateHashEntry(&envPtr->litMap, objPtr, &new); + if (new) { + objIndex = TclAddLiteralObj(envPtr, objPtr, NULL); + Tcl_SetHashValue(hePtr, INT2PTR(objIndex)); + if (!globalNew && globalPtr) { + globalPtr->refCount++; + } } else { - nsPtr = NULL; - } - - /* - * Is it in the interpreter's global literal table? If not, create it. - */ - - globalPtr = NULL; - objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags, - &globalPtr); - objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash); - -#ifdef TCL_COMPILE_DEBUG - if (globalPtr != NULL && globalPtr->refCount < 1) { - Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", - "TclRegisterLiteral", (length>60? 60 : length), bytes, - globalPtr->refCount); - } - TclVerifyLocalLiteralTable(envPtr); -#endif /*TCL_COMPILE_DEBUG*/ + objIndex = PTR2INT(Tcl_GetHashValue(hePtr)); + } return objIndex; } #ifdef TCL_COMPILE_DEBUG /* @@ -533,15 +514,13 @@ register CompileEnv *envPtr,/* Points to CompileEnv whose literal array * contains the entry being hidden. */ int index) /* The index of the entry in the literal * array. */ { - LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; - LiteralTable *localTablePtr = &envPtr->localLitTable; - int localHash, length; - const char *bytes; + Tcl_Obj **lPtr; Tcl_Obj *newObjPtr; + Tcl_HashEntry *hePtr; lPtr = &envPtr->literalArrayPtr[index]; /* * To avoid unwanted sharing we need to copy the object and remove it from @@ -548,28 +527,19 @@ * the local and global literal tables. It still has a slot in the literal * array so it can be referred to by byte codes, but it will not be * matched by literal searches. */ - newObjPtr = Tcl_DuplicateObj(lPtr->objPtr); + hePtr = Tcl_FindHashEntry(&envPtr->litMap, *lPtr); + if (hePtr) { + Tcl_DeleteHashEntry(hePtr); + } + + newObjPtr = Tcl_DuplicateObj(*lPtr); Tcl_IncrRefCount(newObjPtr); - TclReleaseLiteral(interp, lPtr->objPtr); - lPtr->objPtr = newObjPtr; - - bytes = TclGetStringFromObj(newObjPtr, &length); - localHash = (HashString(bytes, length) & localTablePtr->mask); - nextPtrPtr = &localTablePtr->buckets[localHash]; - - for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { - if (entryPtr == lPtr) { - *nextPtrPtr = lPtr->nextPtr; - lPtr->nextPtr = NULL; - localTablePtr->numEntries--; - break; - } - nextPtrPtr = &entryPtr->nextPtr; - } + TclReleaseLiteral(interp, *lPtr); + *lPtr = newObjPtr; } /* *---------------------------------------------------------------------- * @@ -579,12 +549,11 @@ * not add the literal to the local or global literal tables. The caller * is expected to add the entry to whatever tables are appropriate. * * Results: * The index in the CompileEnv's literal array that references the - * literal. Stores the pointer to the new literal entry in the location - * referenced by the localPtrPtr argument. + * literal. * * Side effects: * Expands the literal array if necessary. Increments the refcount on the * literal object. * @@ -594,107 +563,24 @@ int TclAddLiteralObj( register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ Tcl_Obj *objPtr, /* The object to insert into the array. */ - LiteralEntry **litPtrPtr) /* The location where the pointer to the new - * literal entry should be stored. May be - * NULL. */ + LiteralEntry **litPtrPtr) /* UNUSED. Still in place due to publication + * in the internal stubs table, and use by + * tclcompiler. */ { - register LiteralEntry *lPtr; int objIndex; if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { ExpandLocalLiteralArray(envPtr); } objIndex = envPtr->literalArrayNext; envPtr->literalArrayNext++; - lPtr = &envPtr->literalArrayPtr[objIndex]; - lPtr->objPtr = objPtr; + envPtr->literalArrayPtr[objIndex] = objPtr; Tcl_IncrRefCount(objPtr); - lPtr->refCount = -1; /* i.e., unused */ - lPtr->nextPtr = NULL; - - if (litPtrPtr) { - *litPtrPtr = lPtr; - } - - return objIndex; -} - -/* - *---------------------------------------------------------------------- - * - * AddLocalLiteralEntry -- - * - * Insert a new literal into a CompileEnv's local literal array. - * - * Results: - * The index in the CompileEnv's literal array that references the - * literal. - * - * Side effects: - * Expands the literal array if necessary. May rebuild the hash bucket - * array of the CompileEnv's literal array if it becomes too large. - * - *---------------------------------------------------------------------- - */ - -static int -AddLocalLiteralEntry( - register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array - * the object is to be inserted. */ - Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */ - int localHash) /* Hash value for the literal's string. */ -{ - register LiteralTable *localTablePtr = &envPtr->localLitTable; - LiteralEntry *localPtr; - int objIndex; - - objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr); - - /* - * Add the literal to the local table. - */ - - localPtr->nextPtr = localTablePtr->buckets[localHash]; - localTablePtr->buckets[localHash] = localPtr; - localTablePtr->numEntries++; - - /* - * If the CompileEnv's local literal table has exceeded a decent size, - * rebuild it with more buckets. - */ - - if (localTablePtr->numEntries >= localTablePtr->rebuildSize) { - RebuildLiteralTable(localTablePtr); - } - -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(envPtr); - { - char *bytes; - int length, found, i; - - found = 0; - for (i=0 ; inumBuckets ; i++) { - for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ; - localPtr=localPtr->nextPtr) { - if (localPtr->objPtr == objPtr) { - found = 1; - } - } - } - - if (!found) { - bytes = TclGetStringFromObj(objPtr, &length); - Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", - "AddLocalLiteralEntry", (length>60? 60 : length), bytes); - } - } -#endif /*TCL_COMPILE_DEBUG*/ return objIndex; } /* @@ -725,16 +611,14 @@ /* * The current allocated local literal entries are stored between elements * 0 and (envPtr->literalArrayNext - 1) [inclusive]. */ - LiteralTable *localTablePtr = &envPtr->localLitTable; int currElems = envPtr->literalArrayNext; - size_t currBytes = (currElems * sizeof(LiteralEntry)); - LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; - LiteralEntry *newArrayPtr; - int i; + size_t currBytes = (currElems * sizeof(Tcl_Obj *)); + Tcl_Obj **currArrayPtr = envPtr->literalArrayPtr; + Tcl_Obj **newArrayPtr; unsigned int newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; if (currBytes == newSize) { Tcl_Panic("max size of Tcl literal array (%d literals) exceeded", currElems); @@ -749,29 +633,10 @@ */ newArrayPtr = ckalloc(newSize); memcpy(newArrayPtr, currArrayPtr, currBytes); envPtr->mallocedLiteralArray = 1; - } - - /* - * Update the local literal table's bucket array. - */ - - if (currArrayPtr != newArrayPtr) { - for (i=0 ; inumBuckets ; i++) { - if (localTablePtr->buckets[i] != NULL) { - localTablePtr->buckets[i] = newArrayPtr - + (localTablePtr->buckets[i] - currArrayPtr); - } - } } envPtr->literalArrayPtr = newArrayPtr; envPtr->literalArrayEnd = newSize / sizeof(LiteralEntry); } @@ -1039,20 +904,15 @@ * name. */ Namespace *nsPtr) /* The namespace for which to lookup and * invalidate a cmd literal. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name, - strlen(name), -1, NULL, nsPtr, 0, NULL); - - if (literalObjPtr != NULL) { - if (literalObjPtr->typePtr == &tclCmdNameType) { - TclFreeIntRep(literalObjPtr); - } - /* Balance the refcount effects of TclCreateLiteral() above */ - Tcl_IncrRefCount(literalObjPtr); - TclReleaseLiteral(interp, literalObjPtr); + Tcl_Obj *literalObjPtr = CreateLiteral(iPtr, name, strlen(name), + NULL, nsPtr, 0, NULL); + + if (literalObjPtr && (literalObjPtr->typePtr == &tclCmdNameType)) { + TclFreeIntRep(literalObjPtr); } } #ifdef TCL_COMPILE_STATS /* @@ -1149,37 +1009,22 @@ void TclVerifyLocalLiteralTable( CompileEnv *envPtr) /* Points to CompileEnv whose literal table is * to be validated. */ { - register LiteralTable *localTablePtr = &envPtr->localLitTable; - register LiteralEntry *localPtr; - char *bytes; - register int i; - int length, count; - - count = 0; - for (i=0 ; inumBuckets ; i++) { - for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - count++; - if (localPtr->refCount != -1) { - bytes = TclGetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", - "TclVerifyLocalLiteralTable", - (length>60? 60 : length), bytes, localPtr->refCount); - } - if (localPtr->objPtr->bytes == NULL) { - Tcl_Panic("%s: literal has NULL string rep", - "TclVerifyLocalLiteralTable"); - } - } - } - if (count != localTablePtr->numEntries) { - Tcl_Panic("%s: local literal table had %d entries, should be %d", - "TclVerifyLocalLiteralTable", count, - localTablePtr->numEntries); + Tcl_HashTable *mapPtr = &envPtr->litMap; + Tcl_HashSearch search; + Tcl_HashEntry *hePtr = Tcl_FirstHashEntry(mapPtr, &search); + + while (hePtr) { + Tcl_Obj *objPtr = Tcl_GetHashKey(mapPtr, hePtr); + + if (objPtr->bytes == NULL) { + Tcl_Panic("%s: literal has NULL string rep", + "TclVerifyLocalLiteralTable"); + } + hePtr = Tcl_NextHashEntry(&search); } } /* *---------------------------------------------------------------------- Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -782,13 +782,11 @@ nsPtr->flags = 0; nsPtr->activationCount = 0; nsPtr->refCount = 0; Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); TclInitVarHashTable(&nsPtr->varTable, nsPtr); - nsPtr->exportArrayPtr = NULL; - nsPtr->numExportPatterns = 0; - nsPtr->maxExportPatterns = 0; + nsPtr->exportPatternList = NULL; nsPtr->cmdRefEpoch = 0; nsPtr->resolverEpoch = 0; nsPtr->cmdResProc = NULL; nsPtr->varResProc = NULL; nsPtr->compiledVarResProc = NULL; @@ -1236,18 +1234,13 @@ /* * Free the namespace's export pattern array. */ - if (nsPtr->exportArrayPtr != NULL) { - for (i = 0; i < nsPtr->numExportPatterns; i++) { - ckfree(nsPtr->exportArrayPtr[i]); - } - ckfree(nsPtr->exportArrayPtr); - nsPtr->exportArrayPtr = NULL; - nsPtr->numExportPatterns = 0; - nsPtr->maxExportPatterns = 0; + if (nsPtr->exportPatternList != NULL) { + Tcl_DecrRefCount(nsPtr->exportPatternList); + nsPtr->exportPatternList = NULL; } /* * Free any client data associated with the namespace. */ @@ -1359,16 +1352,13 @@ * namespace qualifiers; only commands in the * specified namespace may be exported. */ int resetListFirst) /* If nonzero, resets the namespace's export * list before appending. */ { -#define INIT_EXPORT_PATTERNS 5 Namespace *nsPtr, *exportNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); const char *simplePattern; - char *patternCpy; - int neededElems, len, i; /* * If the specified namespace is NULL, use the current namespace. */ @@ -1381,21 +1371,14 @@ /* * If resetListFirst is true (nonzero), clear the namespace's export * pattern list. */ - if (resetListFirst) { - if (nsPtr->exportArrayPtr != NULL) { - for (i = 0; i < nsPtr->numExportPatterns; i++) { - ckfree(nsPtr->exportArrayPtr[i]); - } - ckfree(nsPtr->exportArrayPtr); - nsPtr->exportArrayPtr = NULL; - TclInvalidateNsCmdLookup(nsPtr); - nsPtr->numExportPatterns = 0; - nsPtr->maxExportPatterns = 0; - } + if (resetListFirst && nsPtr->exportPatternList) { + TclInvalidateNsCmdLookup(nsPtr); + Tcl_DecrRefCount(nsPtr->exportPatternList); + nsPtr->exportPatternList = NULL; } /* * Check that the pattern doesn't have namespace qualifiers. */ @@ -1412,45 +1395,34 @@ /* * Make sure that we don't already have the pattern in the array */ - if (nsPtr->exportArrayPtr != NULL) { - for (i = 0; i < nsPtr->numExportPatterns; i++) { - if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) { + if (nsPtr->exportPatternList != NULL) { + int objc; + Tcl_Obj **objv; + + Tcl_ListObjGetElements(NULL, nsPtr->exportPatternList, &objc, &objv); + while (objc--) { + if (strcmp(pattern, Tcl_GetString(*objv++)) == 0) { /* * The pattern already exists in the list. */ return TCL_OK; } } - } - - /* - * Make sure there is room in the namespace's pattern array for the new - * pattern. - */ - - neededElems = nsPtr->numExportPatterns + 1; - if (neededElems > nsPtr->maxExportPatterns) { - nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? - 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; - nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr, - sizeof(char *) * nsPtr->maxExportPatterns); - } - - /* - * Add the pattern to the namespace's array of export patterns. - */ - - len = strlen(pattern); - patternCpy = ckalloc(len + 1); - memcpy(patternCpy, pattern, (unsigned) len + 1); - - nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; - nsPtr->numExportPatterns++; + } else { + nsPtr->exportPatternList = Tcl_NewObj(); + } + + /* + * Add the pattern to the namespace's list of export patterns. + */ + + Tcl_ListObjAppendElement(NULL, nsPtr->exportPatternList, + Tcl_NewStringObj(pattern, -1)); /* * The list of commands actually exported from the namespace might have * changed (probably will have!) However, we do not need to recompute this * just yet; next time we need the info will be soon enough. @@ -1457,11 +1429,10 @@ */ TclInvalidateNsCmdLookup(nsPtr); return TCL_OK; -#undef INIT_EXPORT_PATTERNS } /* *---------------------------------------------------------------------- * @@ -1491,11 +1462,10 @@ * for the current namespace. */ Tcl_Obj *objPtr) /* Points to the Tcl object onto which the * export pattern list is appended. */ { Namespace *nsPtr; - int i, result; /* * If the specified namespace is NULL, use the current namespace. */ @@ -1507,18 +1477,85 @@ /* * Append the export pattern list onto objPtr. */ - for (i = 0; i < nsPtr->numExportPatterns; i++) { - result = Tcl_ListObjAppendElement(interp, objPtr, - Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1)); - if (result != TCL_OK) { - return result; + if (nsPtr->exportPatternList == NULL) { + return TCL_OK; + } + return Tcl_ListObjAppendList(interp, objPtr, nsPtr->exportPatternList); +} + +/* + *---------------------------------------------------------------------- + * + * TclFillTableWithExports -- + * + * Discover what commands are actually exported by *nsPtr. + * What we have is an array of patterns and a hash table whose keys + * are the command names defined in the namespace (the contents do + * not matter here.) We must find out what commands are actually + * exported by filtering each command in the namespace against each of + * the patterns in the export list. Store the exported command + * set in hash, with fully qualified command prefix as value. + * + * Suggestion for future enhancement: compute the unique prefixes and + * place them in the hash too, which should make for even faster + * matching. + * + * Results: + * + * Side effects: + * + *---------------------------------------------------------------------- + */ + +void +TclFillTableWithExports( + Namespace *nsPtr, + Tcl_HashTable *hash) +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + + if (nsPtr->exportPatternList == NULL) { + return; + } + + hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + int objc; + Tcl_Obj **objv; + char *nsCmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); + + Tcl_ListObjGetElements(NULL, nsPtr->exportPatternList, &objc, &objv); + while (objc--) { + if (Tcl_StringMatch(nsCmdName, Tcl_GetString(*objv++))) { + int isNew; + Tcl_HashEntry *exportPtr = Tcl_CreateHashEntry(hash, + nsCmdName, &isNew); + + /* + * Remember, hash entries have a full reference to the + * substituted part of the command (as a list) as their + * content! + */ + + if (isNew) { + Tcl_Obj *cmdObj, *cmdPrefixObj; + + TclNewObj(cmdObj); + Tcl_AppendStringsToObj(cmdObj, nsPtr->fullName, + (nsPtr->parentPtr ? "::" : ""), nsCmdName, NULL); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(exportPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + break; + } } } - return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -1693,21 +1730,26 @@ const char *cmdName, const char *pattern, Namespace *importNsPtr, int allowOverwrite) { - int i = 0, exported = 0; + int objc, exported = 0; + Tcl_Obj **objv; Tcl_HashEntry *found; /* * The command cmdName in the source namespace matches the pattern. Check * whether it was exported. If it wasn't, we ignore it. */ - while (!exported && (i < importNsPtr->numExportPatterns)) { - exported |= Tcl_StringMatch(cmdName, - importNsPtr->exportArrayPtr[i++]); + if (importNsPtr->exportPatternList == NULL) { + return TCL_OK; + } + + Tcl_ListObjGetElements(NULL, importNsPtr->exportPatternList, &objc, &objv); + while (!exported && objc--) { + exported |= Tcl_StringMatch(cmdName, Tcl_GetString(*objv++)); } if (!exported) { return TCL_OK; } @@ -3493,11 +3535,14 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int firstArg, i; + Namespace *nsPtr; + Tcl_Obj *dict, *value; + int startSize, endSize, firstArg, i, changed = 0; + int code = TCL_OK; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?"); return TCL_ERROR; } @@ -3505,40 +3550,100 @@ /* * If no pattern arguments are given, and "-clear" isn't specified, return * the namespace's current export pattern list. */ + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); if (objc == 1) { - Tcl_Obj *listPtr = Tcl_NewObj(); - - (void) Tcl_AppendExportList(interp, NULL, listPtr); - Tcl_SetObjResult(interp, listPtr); + if (nsPtr->exportPatternList) { + Tcl_SetObjResult(interp, + TclListObjCopy(NULL, nsPtr->exportPatternList)); + } return TCL_OK; } /* * Process the optional "-clear" argument. */ firstArg = 1; if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { - Tcl_Export(interp, NULL, "::", 1); - Tcl_ResetResult(interp); + if (nsPtr->exportPatternList) { + Tcl_DecrRefCount(nsPtr->exportPatternList); + nsPtr->exportPatternList = NULL; + changed = 1; + } firstArg++; } /* * Add each pattern to the namespace's export pattern list. + * Use a dict as a simple way to screen out duplicates. */ + dict = Tcl_NewDictObj(); + value = Tcl_NewObj(); + Tcl_IncrRefCount(value); + if (nsPtr->exportPatternList) { + int epc; + Tcl_Obj **epv; + + Tcl_ListObjGetElements(NULL, nsPtr->exportPatternList, &epc, &epv); + while (epc--) { + Tcl_DictObjPut(NULL, dict, *epv++, value); + } + } + Tcl_DictObjSize(NULL, dict, &startSize); + for (i = firstArg; i < objc; i++) { - int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0); - if (result != TCL_OK) { - return result; + Namespace *exportNsPtr, *dummyPtr; + const char *simplePattern, *pattern = Tcl_GetString(objv[i]); + + TclGetNamespaceForQualName(interp, pattern, nsPtr, + TCL_NAMESPACE_ONLY, &exportNsPtr, &dummyPtr, &dummyPtr, + &simplePattern); + + if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern" + " \"%s\": pattern can't specify a namespace", pattern)); + Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); + code = TCL_ERROR; + break; + } + + Tcl_DictObjPut(NULL, dict, objv[i], value); + } + Tcl_DictObjSize(NULL, dict, &endSize); + changed |= (endSize > startSize); + + if (endSize > startSize) { + int done; + Tcl_Obj *ep; + Tcl_DictSearch search; + + if (nsPtr->exportPatternList == NULL) { + nsPtr->exportPatternList = Tcl_NewObj(); + Tcl_IncrRefCount(nsPtr->exportPatternList); + } + + i = 0; + Tcl_DictObjFirst(NULL, dict, &search, &ep, NULL, &done); + for (; !done; i++, Tcl_DictObjNext(&search, &ep, NULL, &done)) { + if (i < startSize) { + continue; + } + Tcl_ListObjAppendElement(NULL, nsPtr->exportPatternList, ep); } + Tcl_DictObjDone(&search); + } + Tcl_DecrRefCount(value); + Tcl_DecrRefCount(dict); + + if (changed) { + TclInvalidateNsCmdLookup(nsPtr); } - return TCL_OK; + return code; } /* *---------------------------------------------------------------------- * Index: generic/tclOptimize.c ================================================================== --- generic/tclOptimize.c +++ generic/tclOptimize.c @@ -63,12 +63,11 @@ /* * The starts of commands represent target addresses. */ for (i=0 ; inumCommands ; i++) { - DefineTargetAddress(tablePtr, - envPtr->codeStart + envPtr->cmdMapPtr[i].codeOffset); + DefineTargetAddress(tablePtr, TclCmdStartAddress(envPtr, i)); } /* * Find places where we should be careful about replacing instructions * because they are the targets of various types of jumps. Index: generic/tclParse.c ================================================================== --- generic/tclParse.c +++ generic/tclParse.c @@ -154,23 +154,455 @@ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, }; +/* Set of parsing error messages */ + +static const char *parseErrorMsg[] = { + "", + "extra characters after close-quote", + "extra characters after close-brace", + "missing close-brace", + "missing close-bracket", + "missing )", + "missing \"", + "missing close-brace for variable name", + "syntax error in expression", + "bad number in expression" +}; + /* * Prototypes for local functions defined in this file: */ static inline int CommandComplete(const char *script, int numBytes); +static int ParseBraces(Tcl_Interp *interp, const char *start, + int numBytes, Tcl_Parse *parsePtr, int flags, + const char **termPtr); static int ParseComment(const char *src, int numBytes, Tcl_Parse *parsePtr); +void ParseScript(const char *script, int numBytes, + int flags, Tcl_Parse *parsePtr); static int ParseTokens(const char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr); static int ParseWhiteSpace(const char *src, int numBytes, int *incompletePtr, char *typePtr); static int ParseAllWhiteSpace(const char *src, int numBytes, int *incompletePtr); + +/* + * Prototypes for the Tokens object type. + */ + +static void DupTokensInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); +static void FreeTokensInternalRep(Tcl_Obj *objPtr); +static int SetTokensFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfTokens(Tcl_Obj *objPtr); + +/* + * The structure below defines the "tokens" Tcl object type. + */ + +static Tcl_ObjType tokensType = { + "tokens", /* name */ + FreeTokensInternalRep, /* freeIntRepProc */ + DupTokensInternalRep, /* dupIntRepProc */ + UpdateStringOfTokens, /* updateStringProc */ + SetTokensFromAny /* setFromAnyProc */ +}; + +/* Structure to hold the data of the "tokens" internal rep */ +typedef struct TokenIntRep { + int refCount; + Tcl_Obj * scriptObjPtr; + Tcl_Token * tokenPtr; + Tcl_Token * lastTokenPtr; +} TokenIntRep; + +/* + *---------------------------------------------------------------------- + * + * FreeTokensInternalRep -- + * + * Frees the resources associated with a tokens object's internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Frees the cached Tcl_Token array. + * + *---------------------------------------------------------------------- + */ + +static void +FreeTokensInternalRep(objPtr) + Tcl_Obj *objPtr; +{ + TokenIntRep *tirPtr = objPtr->internalRep.otherValuePtr; + + if (tirPtr->refCount) { + tirPtr->refCount--; + + if (tirPtr->refCount == 0) { + /* Only one holder left. + * If it's the original, break the reference cycle. */ + if (tirPtr->scriptObjPtr == objPtr) { + + /* Make direct change to refCount. Don't call + * Tcl_DecrRefCount() so we avoid freeing the value + * when dropping from refCount 1 to refCount 0. + */ + objPtr->refCount--; + tirPtr->scriptObjPtr = NULL; + } + } + return; + } + + if (tirPtr->scriptObjPtr) { + Tcl_DecrRefCount(tirPtr->scriptObjPtr); + } + ckfree(tirPtr->tokenPtr); + ckfree(tirPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DupTokensInternalRep -- + * + * Do not copy the internal Tcl_Token array, because it contains + * pointers into the original string rep. Instead, leave the copied + * Tcl_Obj untyped with only the string value. If the new copied + * value gets used as a script, new parsing will be done to produce + * a new Tcl_Token array intrep tied to the copied string. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +DupTokensInternalRep(srcPtr, dupPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + Tcl_Obj *dupPtr; /* Object with internal rep to set. */ +{ + TokenIntRep *tirPtr = srcPtr->internalRep.otherValuePtr; + + if (tirPtr->refCount == 0) { + tirPtr->scriptObjPtr = srcPtr; + Tcl_IncrRefCount(srcPtr); + } + tirPtr->refCount++; + dupPtr->internalRep.otherValuePtr = tirPtr; + dupPtr->typePtr = &tokensType; + return; +} + +/* + *---------------------------------------------------------------------- + * + * SetTokensFromAny -- + * + * Generates an internal representation, an array of Tcl_Token's, + * by parsing the string representation as a Tcl script. + * + * Results: + * Returns TCL_OK. (Parsing always succeeds, in the sense that + * a sequence of Tcl_Token's is always generated. Parse errors + * get represented by a special Tcl_Token type.) + * + * Side effects: + * Frees the old internal representation. Sets the first pointer + * of the twoPtrValue field of the internal rep to a (Tcl_Token *) + * pointing to an array of Tcl_Token's from the parse, and the + * second pointer to point to the last token in the array. + * + *---------------------------------------------------------------------- + */ + +static int +SetTokensFromAny (interp, objPtr) + Tcl_Interp *interp; /* Not used. */ + Tcl_Obj *objPtr; /* Value for which to generate Tcl_Token array by + * parsing the string value */ +{ + int numBytes; + const char *script = Tcl_GetStringFromObj(objPtr, &numBytes); + TokenIntRep *tirPtr = ckalloc(sizeof(TokenIntRep)); + + /* + * Free the old internal rep, parse the string as a Tcl script, and + * save the Tcl_Token array as the new internal rep + */ + + TclFreeIntRep(objPtr); + tirPtr->tokenPtr = TclParseScript(interp, script, numBytes, 0, + &(tirPtr->lastTokenPtr), NULL); + tirPtr->scriptObjPtr = NULL; + tirPtr->refCount = 0; + objPtr->internalRep.otherValuePtr = tirPtr; + objPtr->typePtr = &tokensType; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfTokens -- + * + * The Tcl_Obj returned by TclTokensCopy is pure -- it has no valid + * string rep. When we have to have one, this routine generates it. + * + * Results: + * Returns TCL_OK. + * + * Side effects: + * Allocates new string rep to hold copy of the original string + * parsed to make the tokens. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfTokens( + Tcl_Obj *objPtr) +{ + TokenIntRep *tirPtr = objPtr->internalRep.otherValuePtr; + int length; + char *bytes; + + if (tirPtr->scriptObjPtr == NULL) { + Tcl_Panic("Lost scriptObjPtr in tokens value"); + } + bytes = Tcl_GetStringFromObj(tirPtr->scriptObjPtr, &length); + TclInitStringRep(objPtr, bytes, length); +} + +/* + *---------------------------------------------------------------------- + * + * TclTokensCopy -- + * + * Make a pure copy of a list value. Cheap operation so caller can + * call TclGetTokensFromObj without fear of shimmering. + * + * Results: + * Returns pointer to new Tcl_Obj with refCount zero. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclTokensCopy( + Tcl_Obj *objPtr) +{ + Tcl_Obj *copyPtr; + + if (objPtr->typePtr != &tokensType) { + SetTokensFromAny(NULL, objPtr); + } + + TclNewObj(copyPtr); + TclInvalidateStringRep(copyPtr); + DupTokensInternalRep(objPtr, copyPtr); + return copyPtr; +} + +/* + *------------------------------------------------------------------------- + * + * TclGetTokensFromObj -- + * + * Returns a Tcl_Token sequence derived from parsing a Tcl_Obj. + * + * Results: + * Parses the string rep of the Tcl_Obj, if not already done. + * + * Side effects: + * Initializes the table of defined object types "typeTable" with + * builtin object types defined in this file. + * + *------------------------------------------------------------------------- + */ + +Tcl_Token * +TclGetTokensFromObj(objPtr,lastTokenPtrPtr) + Tcl_Obj *objPtr; /* Value to parse and return tokens for */ + Tcl_Token **lastTokenPtrPtr; /* If not NULL, fill with pointer to last + * token in the token array */ +{ + TokenIntRep *tirPtr; + + if (objPtr->typePtr != &tokensType) { + SetTokensFromAny(NULL, objPtr); + } + tirPtr = objPtr->internalRep.otherValuePtr; + if (lastTokenPtrPtr != NULL) { + *lastTokenPtrPtr = tirPtr->lastTokenPtr; + } + return tirPtr->tokenPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclParseScript -- + * + * Results: + * + * Side effects: + * + *---------------------------------------------------------------------- + */ + +Tcl_Token * +TclParseScript(interp, script, numBytes, flags, lastTokenPtrPtr, termPtr) + Tcl_Interp *interp; + const char *script; /* The string to parse */ + int numBytes; /* Length of string in bytes */ + int flags; /* Bit flags that control parsing details. */ + Tcl_Token **lastTokenPtrPtr;/* Return pointer to last token */ + const char **termPtr; /* Return the terminating character in string */ +{ + Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Token *result; + + if (numBytes < 0) { + numBytes = strlen(script); + } + TclParseInit(NULL, script, numBytes, parsePtr); + ParseScript(script, numBytes, flags, parsePtr); + + if (termPtr != NULL) { + *termPtr = parsePtr->term; + } + /* + * Note no call to Tcl_FreeParse(). + * We'll transfer the tokens to the caller. + */ + if (parsePtr->tokenPtr != parsePtr->staticTokens) { + result = ckrealloc(parsePtr->tokenPtr, + parsePtr->numTokens * sizeof(Tcl_Token)); + } else { + result = ckalloc(parsePtr->numTokens * sizeof(Tcl_Token)); + memcpy(result, parsePtr->tokenPtr, + (size_t) (parsePtr->numTokens * sizeof(Tcl_Token))); + } + + if (lastTokenPtrPtr != NULL) { + *lastTokenPtrPtr = &(result[parsePtr->numTokens - 1]); + } + TclStackFree(interp, parsePtr); + return result; +} + +void +ParseScript(script, numBytes, flags, parsePtr) + const char *script; /* The string to parse */ + int numBytes; /* Length of string in bytes */ + int flags; /* Bit flags that control parsing details. */ + Tcl_Parse *parsePtr; +{ + const char *p, *end; + int nested = (flags & PARSE_NESTED); + int scriptToken, numValidTokens; + Tcl_Token *scriptTokenPtr; + + TclGrowParseTokenArray(parsePtr, 1); + scriptToken = parsePtr->numTokens++; + scriptTokenPtr = &parsePtr->tokenPtr[scriptToken]; + scriptTokenPtr->type = TCL_TOKEN_SCRIPT; + scriptTokenPtr->start = script; + scriptTokenPtr->size = numBytes; + scriptTokenPtr->numComponents = 0; + + p = script; + end = p + numBytes; + numValidTokens = parsePtr->numTokens; + + while (p < end) { + int cmdToken; + Tcl_Token *cmdTokenPtr; + + TclGrowParseTokenArray(parsePtr, 1); + cmdToken = parsePtr->numTokens++; + + parsePtr->errorType = TCL_PARSE_SUCCESS; + parsePtr->term = parsePtr->end; + if (TCL_OK != TclParseCommand(parsePtr->interp, p, (int) (end - p), + flags | PARSE_APPEND | PARSE_USE_INTERNAL_TOKENS, parsePtr)) { + break; + } + + p = parsePtr->commandStart + parsePtr->commandSize; + + /* + * Check for missing close-brace for nested script substitution. + * If close-brace is missing, blame it on the last command parsed, + * and do not add it to the token array. + */ + + if (nested && (parsePtr->term >= end)) { + break; + } + + cmdTokenPtr = &parsePtr->tokenPtr[cmdToken]; + cmdTokenPtr->type = TCL_TOKEN_CMD; + cmdTokenPtr->start = parsePtr->commandStart; + if (parsePtr->commandStart + parsePtr->commandSize == parsePtr->term) { + cmdTokenPtr->size = parsePtr->commandSize; + } else { + cmdTokenPtr->size = parsePtr->commandSize - 1; + } + cmdTokenPtr->numComponents = parsePtr->numWords; + + scriptTokenPtr = &parsePtr->tokenPtr[scriptToken]; + scriptTokenPtr->numComponents++; /* Another command parsed */ + numValidTokens = parsePtr->numTokens; + + if (nested && (parsePtr->term < end) && (*parsePtr->term == ']')) { + scriptTokenPtr->size = parsePtr->term - scriptTokenPtr->start; + break; + } + } + /* Check all cases that indicate missing ] */ + if (nested && (p >= end) && ((parsePtr->term >= parsePtr->end) + || (*parsePtr->term != ']'))) { + parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; + parsePtr->term = script - 1; + parsePtr->incomplete = 1; + if (parsePtr->interp != NULL) { + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + parseErrorMsg[parsePtr->errorType], -1)); + } + } + + parsePtr->numTokens = numValidTokens; + + if ((parsePtr->errorType != TCL_PARSE_SUCCESS)) { + int errorToken; + Tcl_Token *errorTokenPtr; + + TclGrowParseTokenArray(parsePtr, 1); + errorToken = parsePtr->numTokens++; + errorTokenPtr = &parsePtr->tokenPtr[errorToken]; + errorTokenPtr->type = TCL_TOKEN_ERROR; + errorTokenPtr->start = parsePtr->commandStart; + errorTokenPtr->size = parsePtr->term + 1 - parsePtr->commandStart; + errorTokenPtr->numComponents = parsePtr->errorType; + } +} /* *---------------------------------------------------------------------- * * TclParseInit -- @@ -230,21 +662,40 @@ *---------------------------------------------------------------------- */ int Tcl_ParseCommand( + Tcl_Interp *interp, /* See TclParseCommand */ + const char *start, /* See TclParseCommand */ + register int numBytes, /* See TclParseCommand */ + int nested, /* Non-zero means this is a nested command: + * close bracket should be considered + * a command terminator. If zero, then close + * bracket has no special meaning. */ + register Tcl_Parse *parsePtr) + /* See TclParseCommand */ +{ + int code = TclParseCommand(interp, start, numBytes, + (nested != 0) ? PARSE_NESTED : 0, parsePtr); + if (code == TCL_ERROR) { + Tcl_FreeParse(parsePtr); + } + return code; +} + +int +TclParseCommand( Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* First character of string containing one or * more Tcl commands. */ register int numBytes, /* Total number of bytes in string. If < 0, * the script consists of all bytes up to the * first null character. */ - int nested, /* Non-zero means this is a nested command: - * close bracket should be considered a - * command terminator. If zero, then close - * bracket has no special meaning. */ + int flags, /* Bit flags to control details of the parsing. + * Only the PARSE_NESTED flag has an effect + * here. Other flags are passed along. */ register Tcl_Parse *parsePtr) /* Structure to fill in with information about * the parsed command; any previous * information in the structure is ignored. */ { @@ -256,10 +707,14 @@ int terminators; /* CHAR_TYPE bits that indicate the end of a * command. */ const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to * point to char after terminating one. */ int scanned; + int nested = (flags & PARSE_NESTED); + int append = (flags & PARSE_APPEND); + const char *commandStart; + int numWords = 0; if ((start == NULL) && (numBytes != 0)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't parse a NULL pointer", -1)); @@ -267,15 +722,17 @@ return TCL_ERROR; } if (numBytes < 0) { numBytes = strlen(start); } - TclParseInit(interp, start, numBytes, parsePtr); - parsePtr->commentStart = NULL; - parsePtr->commentSize = 0; - parsePtr->commandStart = NULL; - parsePtr->commandSize = 0; + if (!append) { + TclParseInit(interp, start, numBytes, parsePtr); + parsePtr->commentStart = NULL; + parsePtr->commentSize = 0; + parsePtr->commandStart = NULL; + parsePtr->commandSize = 0; + } if (nested != 0) { terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK; } else { terminators = TYPE_COMMAND_END; } @@ -297,44 +754,44 @@ /* * The following loop parses the words of the command, one word in each * iteration through the loop. */ - parsePtr->commandStart = src; + commandStart = parsePtr->commandStart = src; type = CHAR_TYPE(*src); scanned = 1; /* Can't have missing whitepsace before first word. */ while (1) { int expandWord = 0; /* Are we at command termination? */ if ((numBytes == 0) || (type & terminators) != 0) { parsePtr->term = src; + parsePtr->numWords = numWords; + parsePtr->commandStart = commandStart; + parsePtr->commandSize = src - parsePtr->commandStart; parsePtr->commandSize = src + (numBytes != 0) - parsePtr->commandStart; return TCL_OK; } /* Are we missing white space after previous word? */ if (scanned == 0) { if (src[-1] == '"') { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-quote", -1)); - } parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; } else { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-brace", -1)); - } parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; } + if (parsePtr->interp != NULL) { + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + parseErrorMsg[parsePtr->errorType], -1)); + } parsePtr->term = src; error: - Tcl_FreeParse(parsePtr); + parsePtr->numWords = numWords; + parsePtr->commandStart = commandStart; parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; return TCL_ERROR; } /* @@ -346,32 +803,32 @@ tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->type = TCL_TOKEN_WORD; tokenPtr->start = src; parsePtr->numTokens++; - parsePtr->numWords++; + numWords++; /* * At this point the word can have one of four forms: something * enclosed in quotes, something enclosed in braces, and expanding * word, or an unquoted word (anything else). */ parseWord: if (*src == '"') { - if (Tcl_ParseQuotedString(interp, src, numBytes, parsePtr, 1, - &termPtr) != TCL_OK) { + if (TclParseQuotedString(NULL, src, numBytes, parsePtr, + flags | PARSE_APPEND, &termPtr) != TCL_OK) { goto error; } src = termPtr; numBytes = parsePtr->end - src; } else if (*src == '{') { int expIdx = wordIndex + 1; Tcl_Token *expPtr; - if (Tcl_ParseBraces(interp, src, numBytes, parsePtr, 1, - &termPtr) != TCL_OK) { + if (ParseBraces(NULL, src, numBytes, parsePtr, + flags | PARSE_APPEND, &termPtr) != TCL_OK) { goto error; } src = termPtr; numBytes = parsePtr->end - src; @@ -402,11 +859,11 @@ * This is an unquoted word. Call ParseTokens and let it do all of * the work. */ if (ParseTokens(src, numBytes, TYPE_SPACE|terminators, - TCL_SUBST_ALL, parsePtr) != TCL_OK) { + flags | TCL_SUBST_ALL, parsePtr) != TCL_OK) { goto error; } src = parsePtr->term; numBytes = parsePtr->end - src; } @@ -497,11 +954,11 @@ * the expanding word completely disappears, leaving no * word generated this pass through the loop. Adjust * accounting appropriately. */ - parsePtr->numWords--; + numWords--; parsePtr->numTokens = wordIndex; } else { /* * Recalculate the number of Tcl_Tokens needed to store * tokens representing the expanded list. @@ -509,11 +966,11 @@ const char *listStart; int growthNeeded = wordIndex + 2*elemCount - parsePtr->numTokens; - parsePtr->numWords += elemCount - 1; + numWords += elemCount - 1; if (growthNeeded > 0) { TclGrowParseTokenArray(parsePtr, growthNeeded); tokenPtr = &parsePtr->tokenPtr[wordIndex]; } parsePtr->numTokens = wordIndex + 2*elemCount; @@ -1092,10 +1549,11 @@ char type; int originalTokens; int noSubstCmds = !(flags & TCL_SUBST_COMMANDS); int noSubstVars = !(flags & TCL_SUBST_VARIABLES); int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES); + int useInternalTokens = (flags & PARSE_USE_INTERNAL_TOKENS); Tcl_Token *tokenPtr; /* * Each iteration through the following loop adds one token of type * TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or TCL_TOKEN_VARIABLE @@ -1139,12 +1597,12 @@ * This is a variable reference. Call Tcl_ParseVarName to do all * the dirty work of parsing the name. */ varToken = parsePtr->numTokens; - if (Tcl_ParseVarName(parsePtr->interp, src, numBytes, parsePtr, - 1) != TCL_OK) { + if (TclParseVarName(NULL, src, numBytes, parsePtr, + flags | PARSE_APPEND) != TCL_OK) { return TCL_ERROR; } src += parsePtr->tokenPtr[varToken].size; numBytes -= parsePtr->tokenPtr[varToken].size; } else if (*src == '[') { @@ -1159,20 +1617,31 @@ continue; } /* * Command substitution. Call Tcl_ParseCommand recursively (and - * repeatedly) to parse the nested command(s), then throw away the - * parse information. + * repeatedly) to parse the nested command(s). If internal tokens + * are acceptable, keep all the parsing information; otherwise, + * throw away the nested parse information. */ + + if (useInternalTokens) { + if (TclParseScriptSubst(src, numBytes, parsePtr, flags) + != TCL_OK) { + return TCL_ERROR; + } + src = parsePtr->term + 1; + numBytes = parsePtr->end - src; + continue; + } src++; numBytes--; nestedPtr = TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse)); while (1) { - if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1, - nestedPtr) != TCL_OK) { + if (TCL_OK != TclParseCommand(parsePtr->interp, src, numBytes, + (flags | PARSE_NESTED) & ~PARSE_APPEND, nestedPtr)) { parsePtr->errorType = nestedPtr->errorType; parsePtr->term = nestedPtr->term; parsePtr->incomplete = nestedPtr->incomplete; TclStackFree(parsePtr->interp, nestedPtr); return TCL_ERROR; @@ -1191,15 +1660,15 @@ && (*(nestedPtr->term) == ']') && !(nestedPtr->incomplete)) { break; } if (numBytes == 0) { + parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; if (parsePtr->interp != NULL) { Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "missing close-bracket", -1)); + parseErrorMsg[parsePtr->errorType], -1)); } - parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->term = tokenPtr->start; parsePtr->incomplete = 1; TclStackFree(parsePtr->interp, nestedPtr); return TCL_ERROR; } @@ -1319,10 +1788,50 @@ } /* *---------------------------------------------------------------------- * + * TclParseScriptSubst -- + * + * Given a string starting with a [ sign, parse the script substitution + * and return information about the parse. No more than numBytes bytes + * will be scanned. + * + * Results: + * + * Side effects: + * + *---------------------------------------------------------------------- + */ + +int +TclParseScriptSubst( + const char *src, + register int numBytes, + Tcl_Parse *parsePtr, + int flags) +{ + int scriptToken; + Tcl_Token *scriptTokenPtr; + + TclGrowParseTokenArray(parsePtr, 1); + scriptToken = parsePtr->numTokens++; + ParseScript(src+1, numBytes-1, flags | PARSE_NESTED, parsePtr); + scriptTokenPtr = &parsePtr->tokenPtr[scriptToken]; + scriptTokenPtr->type = TCL_TOKEN_SCRIPT_SUBST; + scriptTokenPtr->start = src; + scriptTokenPtr->size = parsePtr->term - src + 1; + scriptTokenPtr->numComponents = parsePtr->numTokens - scriptToken - 1; + if (parsePtr->errorType != TCL_PARSE_SUCCESS) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ParseVarName -- * * Given a string starting with a $ sign, parse off a variable name and * return information about the parse. No more than numBytes bytes will * be scanned. @@ -1345,28 +1854,47 @@ *---------------------------------------------------------------------- */ int Tcl_ParseVarName( + Tcl_Interp *interp, /* See TclParseVarName */ + const char *start, /* See TclParseVarName */ + register int numBytes, /* See TclParseVarName */ + Tcl_Parse *parsePtr, /* See TclParseVarName */ + int append) /* Non-zero means append tokens to existing + * information in parsePtr; zero means ignore + * existing tokens in parsePtr and reinitialize + * it. */ +{ + int code = TclParseVarName(interp, start, numBytes, parsePtr, + (append != 0) ? PARSE_APPEND : 0); + if (code == TCL_ERROR) { + Tcl_FreeParse(parsePtr); + } + return code; +} + +int +TclParseVarName( Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* Start of variable substitution string. * First character must be "$". */ register int numBytes, /* Total number of bytes in string. If < 0, * the string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr, /* Structure to fill in with information about * the variable name. */ - int append) /* Non-zero means append tokens to existing - * information in parsePtr; zero means ignore - * existing tokens in parsePtr and - * reinitialize it. */ + int flags) /* Bit flags to control details of the parsing. + * Only the PARSE_APPEND flag has an effect + * here. Other flags are passed along. */ { Tcl_Token *tokenPtr; register const char *src; int varIndex; unsigned array; + int append = (flags & PARSE_APPEND); if ((numBytes == 0) || (start == NULL)) { return TCL_ERROR; } if (numBytes < 0) { @@ -1425,15 +1953,15 @@ while (numBytes && (*src != '}')) { numBytes--; src++; } if (numBytes == 0) { + parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE; if (parsePtr->interp != NULL) { Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "missing close-brace for variable name", -1)); + parseErrorMsg[parsePtr->errorType], -1)); } - parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE; parsePtr->term = tokenPtr->start-1; parsePtr->incomplete = 1; goto error; } tokenPtr->size = src - tokenPtr->start; @@ -1479,19 +2007,19 @@ * recursively to parse the element name, since it could contain * any number of substitutions. */ if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, - TCL_SUBST_ALL, parsePtr)) { + flags | TCL_SUBST_ALL, parsePtr)) { goto error; } if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){ + parsePtr->errorType = TCL_PARSE_MISSING_PAREN; if (parsePtr->interp != NULL) { - Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "missing )", -1)); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + parseErrorMsg[parsePtr->errorType], -1)); } - parsePtr->errorType = TCL_PARSE_MISSING_PAREN; parsePtr->term = src; parsePtr->incomplete = 1; goto error; } src = parsePtr->term + 1; @@ -1514,11 +2042,15 @@ tokenPtr->size = 1; tokenPtr->numComponents = 0; return TCL_OK; error: - Tcl_FreeParse(parsePtr); + /* Convert variable substitution token to error token */ + tokenPtr = &parsePtr->tokenPtr[varIndex]; + tokenPtr->type = TCL_TOKEN_ERROR; + tokenPtr->numComponents = parsePtr->errorType; + tokenPtr->size = parsePtr->term + 1 - tokenPtr->start; return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -1552,11 +2084,13 @@ { register Tcl_Obj *objPtr; int code; Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); - if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) { + if (TCL_OK != TclParseVarName(interp, start, -1, parsePtr, + PARSE_USE_INTERNAL_TOKENS)) { + Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); return NULL; } if (termPtr != NULL) { @@ -1570,11 +2104,11 @@ TclStackFree(interp, parsePtr); return "$"; } code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, - NULL, 1, NULL, NULL); + NULL, 1, NULL, NULL, 0); Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); if (code != TCL_OK) { return NULL; } @@ -1623,10 +2157,32 @@ *---------------------------------------------------------------------- */ int Tcl_ParseBraces( + Tcl_Interp *interp, /* See ParseBraces */ + const char *start, /* See ParseBraces */ + register int numBytes, /* See ParseBraces */ + register Tcl_Parse *parsePtr, + /* See ParseBraces */ + int append, /* Non-zero means append tokens to existing + * information in parsePtr; zero means + * ignore existing tokens in parsePtr and + * reinitialize it. */ + const char **termPtr) /* See ParseBraces */ + +{ + int code = ParseBraces(interp, start, numBytes, parsePtr, + (append != 0) ? PARSE_APPEND : 0, termPtr); + if (code == TCL_ERROR) { + Tcl_FreeParse(parsePtr); + } + return code; +} + +static int +ParseBraces( Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* Start of string enclosed in braces. The * first character must be {'. */ register int numBytes, /* Total number of bytes in string. If < 0, @@ -1633,22 +2189,22 @@ * the string consists of all bytes up to the * first null character. */ register Tcl_Parse *parsePtr, /* Structure to fill in with information about * the string. */ - int append, /* Non-zero means append tokens to existing - * information in parsePtr; zero means ignore - * existing tokens in parsePtr and - * reinitialize it. */ + int flags, /* Bit flags to control details of the parsing. + * Only the PARSE_APPEND flag has an effect + * here. Other flags are passed along. */ const char **termPtr) /* If non-NULL, points to word in which to * store a pointer to the character just after * the terminating '}' if the parse was * successful. */ { Tcl_Token *tokenPtr; register const char *src; int startIndex, level, length; + int append = (flags & PARSE_APPEND); if ((numBytes == 0) || (start == NULL)) { return TCL_ERROR; } if (numBytes < 0) { @@ -1759,11 +2315,11 @@ goto error; } Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "missing close-brace", -1)); + parseErrorMsg[parsePtr->errorType], -1)); /* * Guess if the problem is due to comments by searching the source string * for a possible open brace within the context of a comment. Since we * aren't performing a full Tcl parse, just look for an open brace @@ -1791,11 +2347,10 @@ } } } error: - Tcl_FreeParse(parsePtr); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -1825,10 +2380,31 @@ *---------------------------------------------------------------------- */ int Tcl_ParseQuotedString( + Tcl_Interp *interp, /* See TclParseQuotedString */ + const char *start, /* See TclParseQuotedString */ + int numBytes, /* See TclParseQuotedString */ + Tcl_Parse *parsePtr, + /* See TclParseQuotedString */ + int append, /* Non-zero means append tokens to existing + * information in parsePtr; zero means + * ignore existing tokens in parsePtr and + * reinitialize it. */ + const char **termPtr) /* See TclParseQuotedString */ +{ + int code = TclParseQuotedString(interp, start, numBytes, parsePtr, + (append != 0) ? PARSE_APPEND : 0, termPtr); + if (code == TCL_ERROR) { + Tcl_FreeParse(parsePtr); + } + return code; +} + +int +TclParseQuotedString( Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* Start of the quoted string. The first * character must be '"'. */ register int numBytes, /* Total number of bytes in string. If < 0, @@ -1835,19 +2411,20 @@ * the string consists of all bytes up to the * first null character. */ register Tcl_Parse *parsePtr, /* Structure to fill in with information about * the string. */ - int append, /* Non-zero means append tokens to existing - * information in parsePtr; zero means ignore - * existing tokens in parsePtr and - * reinitialize it. */ + int flags, /* Bit flags to control details of the parsing. + * Only the PARSE_APPEND flag has an effect + * here. Other flags are passed along. */ const char **termPtr) /* If non-NULL, points to word in which to * store a pointer to the character just after * the quoted string's terminating close-quote * if the parse succeeds. */ { + int append = (flags & PARSE_APPEND); + if ((numBytes == 0) || (start == NULL)) { return TCL_ERROR; } if (numBytes < 0) { numBytes = strlen(start); @@ -1855,20 +2432,20 @@ if (!append) { TclParseInit(interp, start, numBytes, parsePtr); } - if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL, - parsePtr)) { + if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, + flags | TCL_SUBST_ALL, parsePtr)) { goto error; } if (*parsePtr->term != '"') { + parsePtr->errorType = TCL_PARSE_MISSING_QUOTE; if (parsePtr->interp != NULL) { Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "missing \"", -1)); + parseErrorMsg[parsePtr->errorType], -1)); } - parsePtr->errorType = TCL_PARSE_MISSING_QUOTE; parsePtr->term = start; parsePtr->incomplete = 1; goto error; } if (termPtr != NULL) { @@ -1875,11 +2452,10 @@ *termPtr = (parsePtr->term + 1); } return TCL_OK; error: - Tcl_FreeParse(parsePtr); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -1898,191 +2474,25 @@ * Side effects: * The Tcl_Parse struct '*parsePtr' is filled with parse results. * The caller is expected to eventually call Tcl_FreeParse() to properly * cleanup the value written there. * - * If a parse error occurs, the Tcl_InterpState value '*statePtr' is - * filled with the state created by that error. When *statePtr is written - * to, the caller is expected to make the required calls to either - * Tcl_RestoreInterpState() or Tcl_DiscardInterpState() to dispose of the - * value written there. - * *---------------------------------------------------------------------- */ void TclSubstParse( Tcl_Interp *interp, const char *bytes, int numBytes, int flags, - Tcl_Parse *parsePtr, - Tcl_InterpState *statePtr) -{ - int length = numBytes; - const char *p = bytes; - - TclParseInit(interp, p, length, parsePtr); - - /* - * First parse the string rep of objPtr, as if it were enclosed as a - * "-quoted word in a normal Tcl command. Honor flags that selectively - * inhibit types of substitution. - */ - - if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, parsePtr)) { - /* - * There was a parse error. Save the interpreter state for possible - * error reporting later. - */ - - *statePtr = Tcl_SaveInterpState(interp, TCL_ERROR); - - /* - * We need to re-parse to get the portion of the string we can [subst] - * before the parse error. Sadly, all the Tcl_Token's created by the - * first parse attempt are gone, freed according to the public spec - * for the Tcl_Parse* routines. The only clue we have is parse.term, - * which points to either the unmatched opener, or to characters that - * follow a close brace or close quote. - * - * Call ParseTokens again, working on the string up to parse.term. - * Keep repeating until we get a good parse on a prefix. - */ - - do { - parsePtr->numTokens = 0; - parsePtr->tokensAvailable = NUM_STATIC_TOKENS; - parsePtr->end = parsePtr->term; - parsePtr->incomplete = 0; - parsePtr->errorType = TCL_PARSE_SUCCESS; - } while (TCL_OK != - ParseTokens(p, parsePtr->end - p, 0, flags, parsePtr)); - - /* - * The good parse will have to be followed by {, (, or [. - */ - - switch (*(parsePtr->term)) { - case '{': - /* - * Parse error was a missing } in a ${varname} variable - * substitution at the toplevel. We will subst everything up to - * that broken variable substitution before reporting the parse - * error. Substituting the leftover '$' will have no side-effects, - * so the current token stream is fine. - */ - break; - - case '(': - /* - * Parse error was during the parsing of the index part of an - * array variable substitution at the toplevel. - */ - - if (*(parsePtr->term - 1) == '$') { - /* - * Special case where removing the array index left us with - * just a dollar sign (array variable with name the empty - * string as its name), instead of with a scalar variable - * reference. - * - * As in the previous case, existing token stream is OK. - */ - } else { - /* - * The current parse includes a successful parse of a scalar - * variable substitution where there should have been an array - * variable substitution. We remove that mistaken part of the - * parse before moving on. A scalar variable substitution is - * two tokens. - */ - - Tcl_Token *varTokenPtr = - parsePtr->tokenPtr + parsePtr->numTokens - 2; - - if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { - Tcl_Panic("TclSubstParse: programming error"); - } - if (varTokenPtr[1].type != TCL_TOKEN_TEXT) { - Tcl_Panic("TclSubstParse: programming error"); - } - parsePtr->numTokens -= 2; - } - break; - case '[': - /* - * Parse error occurred during parsing of a toplevel command - * substitution. - */ - - parsePtr->end = p + length; - p = parsePtr->term + 1; - length = parsePtr->end - p; - if (length == 0) { - /* - * No commands, just an unmatched [. As in previous cases, - * existing token stream is OK. - */ - } else { - /* - * We want to add the parsing of as many commands as we can - * within that substitution until we reach the actual parse - * error. We'll do additional parsing to determine what length - * to claim for the final TCL_TOKEN_COMMAND token. - */ - - Tcl_Token *tokenPtr; - const char *lastTerm = parsePtr->term; - Tcl_Parse *nestedPtr = - TclStackAlloc(interp, sizeof(Tcl_Parse)); - - while (TCL_OK == - 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 - * during substitution. - */ - - break; - } - lastTerm = nestedPtr->term; - } - TclStackFree(interp, nestedPtr); - - if (lastTerm == parsePtr->term) { - /* - * Parse error in first command. No commands to subst, add - * no more tokens. - */ - break; - } - - /* - * Create a command substitution token for whatever commands - * got parsed. - */ - - TclGrowParseTokenArray(parsePtr, 1); - tokenPtr = &(parsePtr->tokenPtr[parsePtr->numTokens]); - tokenPtr->start = parsePtr->term; - tokenPtr->numComponents = 0; - tokenPtr->type = TCL_TOKEN_COMMAND; - tokenPtr->size = lastTerm - tokenPtr->start + 1; - parsePtr->numTokens++; - } - break; - - default: - Tcl_Panic("bad parse in TclSubstParse: %c", p[length]); - } - } + Tcl_Parse *parsePtr) +{ + TclParseInit(interp, bytes, numBytes, parsePtr); + flags &= TCL_SUBST_ALL; + flags |= PARSE_USE_INTERNAL_TOKENS; + ParseTokens(bytes, numBytes, /* mask */ 0, flags, parsePtr); } /* *---------------------------------------------------------------------- * @@ -2117,11 +2527,11 @@ int *tokensLeftPtr, /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ int line, /* The line the script starts on. */ int *clNextOuter, /* Information about an outer context for */ - const char *outerScript) /* continuation line data. This is set by + const char *outerScript, /* continuation line data. This is set by * EvalEx() to properly handle [...]-nested * commands. The 'outerScript' refers to the * most-outer script containing the embedded * command, which is refered to by 'script'. * The 'clNextOuter' refers to the current @@ -2133,10 +2543,11 @@ * If outerScript == script, then this call is * for words in the outer-most script or * command. See Tcl_EvalEx and TclEvalObjEx * for the places generating arguments for * which this is true. */ + int flags) { Tcl_Obj *result; int code = TCL_OK; #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL, i, adjust; @@ -2234,10 +2645,16 @@ adjust++; } break; case TCL_TOKEN_COMMAND: { + /* + * This case exists only for the sake of the public routines + * Tcl_EvalTokens(Standard)(). All internal parsing avoids + * generation of the TCL_TOKEN_COMMAND token type. + */ + /* TIP #280: Transfer line information to nested command */ iPtr->numLevels++; code = TclInterpReady(interp); if (code == TCL_OK) { /* @@ -2248,11 +2665,11 @@ TclAdvanceContinuations(&line, &clNextOuter, tokenPtr->start - outerScript); theline = line + adjust; code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, - 0, theline, clNextOuter, outerScript); + flags, theline, clNextOuter, outerScript); TclAdvanceLines(&line, tokenPtr->start+1, tokenPtr->start + tokenPtr->size - 1); /* @@ -2272,26 +2689,31 @@ case TCL_TOKEN_VARIABLE: { Tcl_Obj *arrayIndex = NULL; Tcl_Obj *varName = NULL; + if (count <= tokenPtr->numComponents) { + Tcl_Panic("token components overflow token array"); + } if (tokenPtr->numComponents > 1) { /* * Subst the index part of an array variable reference. */ code = TclSubstTokens(interp, tokenPtr+2, - tokenPtr->numComponents - 1, NULL, line, NULL, NULL); + tokenPtr->numComponents - 1, NULL, line, NULL, NULL, + flags); arrayIndex = Tcl_GetObjResult(interp); Tcl_IncrRefCount(arrayIndex); } if (code == TCL_OK) { varName = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex, - TCL_LEAVE_ERR_MSG); + TCL_LEAVE_ERR_MSG | + ((flags & TCL_EVAL_GLOBAL) ? TCL_GLOBAL_ONLY : 0)); Tcl_DecrRefCount(varName); if (appendObj == NULL) { code = TCL_ERROR; } } @@ -2302,11 +2724,11 @@ case TCL_BREAK: /* Will not substitute anyway */ case TCL_CONTINUE: /* Will not substitute anyway */ break; default: /* - * All other return codes, we will subst the result from the + * All other return codes, we will subst the ulesult from the * code-throwing evaluation. */ appendObj = Tcl_GetObjResult(interp); } @@ -2316,10 +2738,50 @@ } count -= tokenPtr->numComponents; tokenPtr += tokenPtr->numComponents; break; } + + case TCL_TOKEN_SCRIPT_SUBST: { + Interp *iPtr = (Interp *) interp; + iPtr->numLevels++; + code = TclInterpReady(interp); + if (code == TCL_OK) { + int theline; + if (count <= tokenPtr->numComponents) { + Tcl_Panic("token components overflow token array"); + } + TclAdvanceContinuations (&line, &clNextOuter, + tokenPtr->start - outerScript); + theline = line + adjust; + code = TclEvalScriptTokens(interp, tokenPtr+1, + tokenPtr->numComponents, flags, theline, + clNextOuter, outerScript); + + TclAdvanceLines(&line, tokenPtr->start+1, + tokenPtr->start + tokenPtr->size - 1); + + /* + * Restore flag reset by nested eval for future bracketed + * commands and their cmdframe setup + */ + if (inFile) { + iPtr->evalFlags |= TCL_EVAL_FILE; + } + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + } + iPtr->numLevels--; + appendObj = Tcl_GetObjResult(interp); + break; + } + + case TCL_TOKEN_ERROR: + Tcl_SetResult(interp, (char *) + parseErrorMsg[tokenPtr->numComponents], TCL_STATIC); + code = TCL_ERROR; + break; default: Tcl_Panic("unexpected token type in TclSubstTokens: %d", tokenPtr->type); } @@ -2423,28 +2885,27 @@ const char *script, /* Script to check. */ int numBytes) /* Number of bytes in script. */ { Tcl_Parse parse; const char *p, *end; - int result; + + /* + * NOTE: This set of routines should not be converted to make use of + * TclParseScript, because [info complete] is defined to operate only + * one parsing level deep, while TclParseScript digs out parsing errors + * in nested script substitutions. See test parse-6.8, etc. + */ p = script; end = p + numBytes; - while (Tcl_ParseCommand(NULL, p, end - p, 0, &parse) == TCL_OK) { - p = parse.commandStart + parse.commandSize; - if (p >= end) { - break; - } - Tcl_FreeParse(&parse); - } - if (parse.incomplete) { - result = 0; - } else { - result = 1; - } - Tcl_FreeParse(&parse); - return result; + parse.incomplete = 0; + while ((p < end) + && (Tcl_ParseCommand(NULL, p, end - p, 0, &parse)) == TCL_OK) { + p = parse.commandStart + parse.commandSize; + Tcl_FreeParse(&parse); + } + return (parse.incomplete == 0); } /* *---------------------------------------------------------------------- * Index: generic/tclPreserve.c ================================================================== --- generic/tclPreserve.c +++ generic/tclPreserve.c @@ -11,41 +11,34 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" +#include "tclBrodnik.h" /* * The following data structure is used to keep track of all the Tcl_Preserve * calls that are still in effect. It grows as needed to accommodate any * number of calls in effect. */ typedef struct { ClientData clientData; /* Address of preserved block. */ + Tcl_FreeProc *freeProc; /* Function to call to free. */ int refCount; /* Number of Tcl_Preserve calls in effect for * block. */ - int mustFree; /* Non-zero means Tcl_EventuallyFree was - * called while a Tcl_Preserve call was in - * effect, so the structure must be freed when - * refCount becomes zero. */ - Tcl_FreeProc *freeProc; /* Function to call to free. */ } Reference; /* * Global data structures used to hold the list of preserved data references. * These variables are protected by "preserveMutex". */ -static Reference *refArray = NULL; /* First in array of references. */ -static int spaceAvl = 0; /* Total number of structures available at - * *firstRefPtr. */ -static int inUse = 0; /* Count of structures currently in use in - * refArray. */ -TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ - -#define INITIAL_SIZE 2 /* Initial number of reference slots to make */ +TclBrodnikArray(Reference); + +static BA_Reference *refArray = NULL; +TCL_DECLARE_MUTEX(preserveMutex) /* To protect the refArray */ /* * The following data structure is used to keep track of whether an arbitrary * block of memory has been deleted. This is used by the TclHandle code to * avoid the more time-expensive algorithm of Tcl_Preserve(). This mechanism @@ -86,15 +79,12 @@ /* ARGSUSED */ void TclFinalizePreserve(void) { Tcl_MutexLock(&preserveMutex); - if (spaceAvl != 0) { - ckfree(refArray); - refArray = NULL; - inUse = 0; - spaceAvl = 0; + if (refArray) { + BA_Reference_Destroy(refArray); } Tcl_MutexUnlock(&preserveMutex); } /* @@ -119,46 +109,41 @@ void Tcl_Preserve( ClientData clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - int i; /* * See if there is already a reference for this pointer. If so, just * increment its reference count. */ Tcl_MutexLock(&preserveMutex); - for (i=0, refPtr=refArray ; iclientData == clientData) { - refPtr->refCount++; - Tcl_MutexUnlock(&preserveMutex); - return; - } - } - - /* - * Make a reference array if it doesn't already exist, or make it bigger - * if it is full. - */ - - if (inUse == spaceAvl) { - spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE; - refArray = ckrealloc(refArray, spaceAvl * sizeof(Reference)); + if (refArray == NULL) { + refArray = BA_Reference_Create(); + } else { + BP_Reference ptr; + + refPtr = BA_Reference_First(refArray, &ptr); + while (refPtr) { + if (refPtr->clientData == clientData) { + refPtr->refCount++; + Tcl_MutexUnlock(&preserveMutex); + return; + } + refPtr = BP_Reference_Next(&ptr); + } } /* * Make a new entry for the new reference. */ - refPtr = &refArray[inUse]; + refPtr = BA_Reference_Append(refArray); refPtr->clientData = clientData; refPtr->refCount = 1; - refPtr->mustFree = 0; - refPtr->freeProc = TCL_STATIC; - inUse += 1; + refPtr->freeProc = NULL; Tcl_MutexUnlock(&preserveMutex); } /* *---------------------------------------------------------------------- @@ -182,16 +167,21 @@ void Tcl_Release( ClientData clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - int i; + BP_Reference ptr; Tcl_MutexLock(&preserveMutex); - for (i=0, refPtr=refArray ; iclientData != clientData) { continue; } @@ -206,14 +196,13 @@ * same clientData. Copy down the last reference in the array to * overwrite the current slot. */ freeProc = refPtr->freeProc; - mustFree = refPtr->mustFree; - inUse--; - if (i < inUse) { - refArray[i] = refArray[inUse]; + lastRefPtr = BA_Reference_Detach(refArray); + if (refPtr != lastRefPtr) { + *refPtr = *lastRefPtr; } /* * Now committed to disposing the data. But first, we've patched up * all the global data structures so we should release the mutex now. @@ -220,16 +209,12 @@ * Only then should we dabble around with potentially-slow memory * managers... */ Tcl_MutexUnlock(&preserveMutex); - if (mustFree) { - if (freeProc == TCL_DYNAMIC) { - ckfree(clientData); - } else { - freeProc(clientData); - } + if (freeProc) { + freeProc(clientData); } return; } Tcl_MutexUnlock(&preserveMutex); @@ -262,26 +247,32 @@ Tcl_EventuallyFree( ClientData clientData, /* Pointer to malloc'ed block of memory. */ Tcl_FreeProc *freeProc) /* Function to actually do free. */ { Reference *refPtr; - int i; + BP_Reference ptr; + if (freeProc == TCL_DYNAMIC) { + freeProc = Tcl_Free; + } /* - * See if there is a reference for this pointer. If so, set its "mustFree" - * flag (the flag had better not be set already!). + * See if there is a reference for this pointer. If so, set the freeProc + * to call (it should not be set already!). */ - Tcl_MutexLock(&preserveMutex); - for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refArray == NULL) { + refArray = BA_Reference_Create(); + } + + for (refPtr = BA_Reference_First(refArray, &ptr); refPtr; + refPtr = BP_Reference_Next(&ptr)) { if (refPtr->clientData != clientData) { continue; } - if (refPtr->mustFree) { + if (refPtr->freeProc) { Tcl_Panic("Tcl_EventuallyFree called twice for %p", clientData); } - refPtr->mustFree = 1; refPtr->freeProc = freeProc; Tcl_MutexUnlock(&preserveMutex); return; } Tcl_MutexUnlock(&preserveMutex); @@ -288,15 +279,11 @@ /* * No reference for this block. Free it now. */ - if (freeProc == TCL_DYNAMIC) { - ckfree(clientData); - } else { - freeProc(clientData); - } + freeProc(clientData); } /* *--------------------------------------------------------------------------- * Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -1324,11 +1324,10 @@ Tcl_Obj **namePtr; Var *varPtr; LocalCache *localCachePtr; CompiledLocal *localPtr; - int new; /* * Cache the names and initial values of local variables; store the * cache in both the framePtr for this execution and in the codePtr * for future calls. @@ -1343,13 +1342,12 @@ localPtr = procPtr->firstLocalPtr; while (localPtr) { if (TclIsVarTemporary(localPtr)) { *namePtr = NULL; } else { - *namePtr = TclCreateLiteral(iPtr, localPtr->name, - localPtr->nameLength, /* hash */ (unsigned int) -1, - &new, /* nsPtr */ NULL, 0, NULL); + *namePtr = TclCreateLiteral(iPtr, + localPtr->name, localPtr->nameLength); Tcl_IncrRefCount(*namePtr); } if (i < numArgs) { varPtr->flags = (localPtr->flags & VAR_IS_ARGS); Index: generic/tclStrToD.c ================================================================== --- generic/tclStrToD.c +++ generic/tclStrToD.c @@ -1974,11 +1974,12 @@ * RequiredPrecision -- * * Determines the number of bits needed to hold an intger. * * Results: - * Returns the position of the most significant bit (0 - 63). Returns 0 + * Returns the position of the most significant bit (1 - 64), starting + * the counting at 1 for the LSB. (RP(1) -> 1). Returns 0 * if the number is zero. * *---------------------------------------------------------------------- */ @@ -1986,10 +1987,17 @@ RequiredPrecision( Tcl_WideUInt w) /* Number to interrogate. */ { int rv; unsigned long wi; + + if (w == 0) { + return 0; + } + if (sizeof(Tcl_WideUInt) <= sizeof(size_t)) { + return 1 + TclMSB(w); + } if (w & ((Tcl_WideUInt) 0xffffffff << 32)) { wi = (unsigned long) (w >> 32); rv = 32; } else { wi = (unsigned long) w; rv = 0; Index: generic/tclTest.c ================================================================== --- generic/tclTest.c +++ generic/tclTest.c @@ -287,10 +287,13 @@ Tcl_Interp *interp, int argc, const char **argv); static int TestsetmainloopCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestexitmainloopCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestmsbObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestpanicCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestparserObjCmd(ClientData dummy, @@ -618,10 +621,11 @@ Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, NULL, NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testmsb", TestmsbObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, @@ -3310,10 +3314,55 @@ ClientData clientData, /* Data to be released. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { ckfree(clientData); } + +/* + *---------------------------------------------------------------------- + * + * TestmsbObjCmd -- + * + * This procedure implements the "testmsb" command. It is + * used for testing the TclMSB() routine. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestmsbObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Tcl_WideInt w = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "integer"); + return TCL_ERROR; + } + if (sizeof(Tcl_WideUInt) <= sizeof(size_t)) { + if (TCL_OK != Tcl_GetWideIntFromObj(interp, objv[1], &w)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(TclMSB(w))); + } else { + int i; + if (TCL_OK != Tcl_GetIntFromObj(interp, objv[1], &i)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(TclMSB(i))); + } + return TCL_OK; +} /* *---------------------------------------------------------------------- * * TestparserObjCmd -- ADDED tests/brodnik.test Index: tests/brodnik.test ================================================================== --- /dev/null +++ tests/brodnik.test @@ -0,0 +1,62 @@ +# This file contains a collection of tests for the procedures in the +# file tclBrodnik.c. +# +# Contributions from Don Porter, NIST, 2013. (not subject to US copyright) +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.6- +package require tcltest 2 + +namespace eval ::tcl::test::brodnik { + namespace import ::tcltest::loadTestedCommands + namespace import ::tcltest::testConstraint + namespace import ::tcltest::test + namespace import ::tcltest::cleanupTests + + loadTestedCommands + try {package require Tcltest} + testConstraint testmsb [expr {[namespace which -command testmsb] ne {}}] + + namespace eval tcl { + namespace eval mathfunc { + proc log2 {i} { + set k 0 + while {[set i [expr {$i>>1}]]} { + incr k + } + return $k + } + } + } + + # Tests for values with MSB in the low block + variable v 0 + while {$v < 1<<8} { + test brodnik-1.$v {TclMSB correctness} testmsb { + testmsb $v + } [expr {int(log2($v))}] + incr v + } + + variable i 8 + while {$i < 8*$::tcl_platform(pointerSize)} { + + variable j -1 + while {$j < 2} { + set v [expr {(1<<$i) + $j}] + + test brodnik-2.$i.$j {TclMSB correctness} testmsb { + testmsb $v + } [expr {int(log2($v))}] + + incr j + } + incr i + } + + cleanupTests +} +namespace delete ::tcl::test::brodnik +return Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -289,15 +289,15 @@ XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ - tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ - tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ + tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclBrodnik.o \ + tclCkalloc.o tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \ - tclEncoding.o tclEnsemble.o \ + tclEncoding.o tclEnsemble.o tclHAMT.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \ tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ @@ -391,10 +391,11 @@ $(GENERIC_DIR)/tclAlloc.c \ $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ $(GENERIC_DIR)/tclBinary.c \ + $(GENERIC_DIR)/tclBrodnik.c \ $(GENERIC_DIR)/tclCkalloc.c \ $(GENERIC_DIR)/tclClock.c \ $(GENERIC_DIR)/tclCmdAH.c \ $(GENERIC_DIR)/tclCmdIL.c \ $(GENERIC_DIR)/tclCmdMZ.c \ @@ -413,10 +414,11 @@ $(GENERIC_DIR)/tclEvent.c \ $(GENERIC_DIR)/tclExecute.c \ $(GENERIC_DIR)/tclFCmd.c \ $(GENERIC_DIR)/tclFileName.c \ $(GENERIC_DIR)/tclGet.c \ + $(GENERIC_DIR)/tclHAMT.c \ $(GENERIC_DIR)/tclHash.c \ $(GENERIC_DIR)/tclHistory.c \ $(GENERIC_DIR)/tclIndexObj.c \ $(GENERIC_DIR)/tclInterp.c \ $(GENERIC_DIR)/tclIO.c \ @@ -1062,10 +1064,13 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBasic.c tclBinary.o: $(GENERIC_DIR)/tclBinary.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBinary.c +tclBrodnik.o: $(GENERIC_DIR)/tclBrodnik.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBrodnik.c + tclCkalloc.o: $(GENERIC_DIR)/tclCkalloc.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCkalloc.c tclClock.o: $(GENERIC_DIR)/tclClock.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClock.c @@ -1128,10 +1133,13 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFileName.c tclGet.o: $(GENERIC_DIR)/tclGet.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclGet.c +tclHAMT.o: $(GENERIC_DIR)/tclHAMT.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHAMT.c + tclHash.o: $(GENERIC_DIR)/tclHash.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHash.c tclHistory.o: $(GENERIC_DIR)/tclHistory.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHistory.c