From dc4782f5951c5d881c932ff0a4c194ca89193702 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 25 Jun 2013 14:19:39 +0000 Subject: Branch for rewriting TclCompileScript() and related routines, with the intent to generally simplify and make more readable, as well as find and eliminate duplication with ensemble machinery and improve mergeability to other branches. Work in Progress. Doesn't work at all right now. --- generic/tclCompile.c | 124 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 124 insertions(+) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 8cb53f5..eafecbc 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1737,6 +1737,37 @@ FindCompiledCommandFromToken( *---------------------------------------------------------------------- */ +#if 1 +static void +CompileCommandTokens( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + CompileEnv *envPtr) +{ + Tcl_Obj *cmdObj; + Tcl_Token *cmdTokenPtr = parsePtr->tokenPtr; + + + if (parsePtr->numWords == 0) { + return 0; + } + + if (!TclWordKnownAtCompileTime(cmdTokenPtr, cmdObj)) { + /* + * Command is not known until runtime substitution is complete. + * Emit instructions to perform that substitution. + */ + CompileTokens(interp, cmdTokenPtr, envPtr); + + } + + + + TclEmitOpcode(INST_POP, envPtr); + +} +#endif + void TclCompileScript( Tcl_Interp *interp, /* Used for error and status reporting. Also @@ -1748,6 +1779,98 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { +#if 1 + unsigned char *entryCodeNext = envPtr->codeNext; + const char *p; + int cmdLine, *clNext; + + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); + } + + /* + * Each iteration through the following loop compiles the next command + * from the script. + */ + + p = script; + cmdLine = envPtr->line; + clNext = envPtr->clNext; + while (numBytes > 0) { + Tcl_Parse parse; + const char *next; + + /* TODO: can we relocate this to happen less frequently? */ + Tcl_ResetResult(interp); + 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 - parse.commandStart); + TclCompileSyntaxError(interp, envPtr); + break; + } + + /* + * TIP #280: Count newlines before the command start. + * (See test info-30.33). + */ + + TclAdvanceLines(&cmdLine, p, parse.commandStart); + TclAdvanceContinuations(&cmdLine, &clNext, + parse.commandStart - envPtr->source); + +#ifdef TCL_COMPILE_DEBUG + /* + * If tracing, print a line for each top level command compiled. + */ + + if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + fprintf(stdout, " Compiling: "); + TclPrintSource(stdout, parse.commandStart, + TclMin(parse.term - parse.commandStart, 55)); + fprintf(stdout, "\n"); + } +#endif + + CompileCommandTokens(interp, &parse, envPtr); + + /* + * Advance to the next command in the script. + */ + + next = parse.commandStart + parse.commandSize; + numBytes -= next - p; + p = next; + + /* + * TIP #280: Track lines in the just compiled command. + */ + + TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); + TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); + Tcl_FreeParse(&parse); + } + + /* + * TIP #280: Bring the line counts in the CompEnv up to date. + * See tests info-30.33,34,35 . + */ + + envPtr->line = cmdLine; + envPtr->clNext = clNext; + + /* + * If the source script yielded no instructions (e.g., if it was empty), + * push an empty string as the command's result. + */ + + if (envPtr->codeNext == entryCodeNext) { + PushStringLiteral(envPtr, ""); + } +#else int lastTopLevelCmdIndex = -1; /* Index of most recent toplevel command in * the command location table. Initialized to @@ -2192,6 +2315,7 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); } +#endif } /* -- cgit v0.12 From 11f1a88c1296f43cc886843ce15a820243ff2c12 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 25 Jun 2013 20:22:31 +0000 Subject: Nearly functional now, but leaky and not yet as tidy as I'm hoping for. --- generic/tclCompile.c | 301 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 289 insertions(+), 12 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 01320cf..2c6af46 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1744,27 +1744,295 @@ CompileCommandTokens( Tcl_Parse *parsePtr, CompileEnv *envPtr) { - Tcl_Obj *cmdObj; - Tcl_Token *cmdTokenPtr = parsePtr->tokenPtr; - + Interp *iPtr = (Interp *) interp; + Tcl_Obj *cmdObj = Tcl_NewObj(); + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + Command *cmdPtr = NULL; + int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + int *wlines, wlineat; - if (parsePtr->numWords == 0) { - return 0; + if (numWords == 0) { + return; + } + + for (wordIdx = 0; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + expand = 1; + break; + } } - if (!TclWordKnownAtCompileTime(cmdTokenPtr, cmdObj)) { + Tcl_IncrRefCount(cmdObj); + tokenPtr = parsePtr->tokenPtr; + cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); + + if (cmdKnown && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if (cmdPtr) { + /* + * Found a command. Test all the ways we can be told + * not to attempt to compile it. + */ + if ((cmdPtr->compileProc == NULL) + || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES) + || (expand && !(cmdPtr->flags & CMD_COMPILES_EXPANDED))) { + cmdPtr = NULL; + } + } + } + + /* Pre-Compile */ +int lastTopLevelCmdIndex, currCmdIndex, startCodeOffset; + +int cmdLine = envPtr->line; +int *clNext = envPtr->clNext; + + lastTopLevelCmdIndex = currCmdIndex = envPtr->numCommands; + envPtr->numCommands++; + startCodeOffset = envPtr->codeNext - envPtr->codeStart; + EnterCmdStartData(envPtr, currCmdIndex, + parsePtr->commandStart - envPtr->source, startCodeOffset); + + if (expand && !cmdPtr) { + StartExpanding(envPtr); + } + + /* + * 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, + clNext, &wlines, envPtr); + wlineat = eclPtr->nuloc - 1; + + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + + if (cmdPtr) { + int savedNumCmds = envPtr->numCommands; + int update = 0; + int startStackDepth = envPtr->currStackDepth; + + /* + * Mark the start of the command; the proper bytecode + * length will be updated later. There is no need to + * do this for the first bytecode in the compile env, + * as the check is done before calling + * TclNRExecuteByteCode(). Do emit an INST_START_CMD + * in special cases where the first bytecode is in a + * loop, to insure that the corresponding command is + * counted properly. Compilers for commands able to + * produce such a beast (currently 'while 1' only) set + * envPtr->atCmdStart to 0 in order to signal this + * case. [Bug 1752146] + * + * Note that the environment is initialised with + * atCmdStart=1 to avoid emitting ISC for the first + * command. + */ + + if (envPtr->atCmdStart == 1) { + if (startCodeOffset) { + /* + * Increase the number of commands being + * started at the current point. Note that + * this depends on the exact layout of the + * INST_START_CMD's operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) + } + } else if (envPtr->atCmdStart == 0) { + TclEmitInstInt4(INST_START_CMD, 0, envPtr); + TclEmitInt4(1, envPtr); + update = 1; + } + + if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { + +#ifdef TCL_COMPILE_DEBUG + /* + * Confirm that the command compiler generated a + * single value on the stack as its result. This + * is only done in debugging mode, as it *should* + * be correct and normal users have no reasonable + * way to fix it anyway. + */ + + int diff = envPtr->currStackDepth - startStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", + parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif + if (update) { + /* + * Fix the bytecode length. + */ + + unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; + unsigned fixLen = envPtr->codeNext - fixPtr + 1; + + TclStoreInt4AtPtr(fixLen, fixPtr); + } + goto finishCommand; + } + + if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { + /* + * Decrease the number of commands being started + * at the current point. Note that this depends on + * the exact layout of the INST_START_CMD's + * operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); + } + /* - * Command is not known until runtime substitution is complete. - * Emit instructions to perform that substitution. + * Restore numCommands, codeNext, and currStackDepth to their + * correct values, removing any commands compiled before the + * failure to produce bytecode got reported. + * [Bugs 705406, 735055, 3614102] */ - CompileTokens(interp, cmdTokenPtr, envPtr); + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart + startCodeOffset; + envPtr->currStackDepth = startStackDepth; + + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + + /* TODO: Can this happen? If so, is this right? */ + if (expand) { + StartExpanding(envPtr); + } } - + /* + * No complile attempted, or it failed. + * Need to emit instructions to invoke, with expansion if needed. + */ + + wordIdx = 0; + tokenPtr = parsePtr->tokenPtr; + if (cmdKnown) { + int cmdLitIdx, numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + + cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if (cmdPtr) { + TclSetCmdNameObj(interp, + TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); + wordIdx = 1; + tokenPtr += tokenPtr->numComponents + 1; + } + + for (; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + int objIdx; + + envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); + } + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, + eclPtr->loc[wlineat].next[wordIdx]); + } + TclEmitPush(objIdx, envPtr); + } + + /* + * Emit an invoke instruction for the command. We skip this if a + * compile procedure was found for the command. + */ + + if (expand) { + /* + * The stack depth during argument expansion can only be + * managed at runtime, as the number of elements in the + * expanded lists is not known at compile time. We adjust here + * the stack depth estimate so that it is correct after the + * command with expanded arguments returns. + * + * The end effect of this command's invocation is that all the + * words of the command are popped from the stack, and the + * result is pushed: the stack top changes by (1-wordIdx). + * + * Note that the estimates are not correct while the command + * is being prepared and run, INST_EXPAND_STKTOP is not + * stack-neutral in general. + */ + + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; + TclAdjustStackDepth(1 - wordIdx, envPtr); + } else { + /* + * Save PC -> command map for the TclArgumentBC* functions. + */ + + int isnew; + Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, + INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew); + + Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); + if (wordIdx <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + } + } + +finishCommand: TclEmitOpcode(INST_POP, envPtr); + EnterCmdExtentData(envPtr, currCmdIndex, + parsePtr->term - parsePtr->commandStart, + (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + if (cmdKnown) { + Tcl_DecrRefCount(cmdObj); + } + + /* + * TIP #280: Free full form of per-word line data and insert the + * reduced form now + */ + + envPtr->line = cmdLine; + envPtr->clNext = clNext; + ckfree(eclPtr->loc[wlineat].line); + ckfree(eclPtr->loc[wlineat].next); + eclPtr->loc[wlineat].line = wlines; + eclPtr->loc[wlineat].next = NULL; } #endif @@ -1828,14 +2096,19 @@ TclCompileScript( */ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + int commandLength = parse.term - parse.commandStart; fprintf(stdout, " Compiling: "); TclPrintSource(stdout, parse.commandStart, - TclMin(parse.term - parse.commandStart, 55)); + TclMin(commandLength, 55)); fprintf(stdout, "\n"); } #endif + envPtr->line = cmdLine; + envPtr->clNext = clNext; CompileCommandTokens(interp, &parse, envPtr); + cmdLine = envPtr->line; + clNext = envPtr->clNext; /* * Advance to the next command in the script. @@ -1849,7 +2122,7 @@ TclCompileScript( * TIP #280: Track lines in the just compiled command. */ - TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); + TclAdvanceLines(&cmdLine, parse.commandStart, p); TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); Tcl_FreeParse(&parse); } @@ -1869,6 +2142,10 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); + } else { + /* Remove the surplus INST_POP */ + envPtr->codeNext--; + TclAdjustStackDepth(1, envPtr); } #else int lastTopLevelCmdIndex = -1; -- cgit v0.12 From 5eecd400b721e762d5bb10f1582cf43b278f34b1 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Jun 2013 03:46:54 +0000 Subject: A few bug fixes from failing tests; still leaky. --- generic/tclCompile.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 955078c..626c5ae 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2076,7 +2076,10 @@ TclCompileScript( */ Tcl_LogCommandInfo(interp, script, parse.commandStart, - parse.term - parse.commandStart); + /* Drop the command terminator (";","]") if appropriate */ + (parse.term == + parse.commandStart + parse.commandSize - 1)? + parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); break; } @@ -2142,7 +2145,7 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); - } else { + } else if (envPtr->codeNext[-1] == INST_POP) { /* Remove the surplus INST_POP */ envPtr->codeNext--; TclAdjustStackDepth(1, envPtr); -- cgit v0.12 From ae7b32a706d7f69fc2e4ce06f546a99325f9716f Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Jun 2013 16:06:44 +0000 Subject: Fix bytecode ranges in the cmdMapPtr. still leaky. --- generic/tclCompile.c | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 626c5ae..62943b2 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1742,7 +1742,8 @@ static void CompileCommandTokens( Tcl_Interp *interp, Tcl_Parse *parsePtr, - CompileEnv *envPtr) + CompileEnv *envPtr, + int *lastPopPtr) { Interp *iPtr = (Interp *) interp; Tcl_Obj *cmdObj = Tcl_NewObj(); @@ -2017,6 +2018,8 @@ finishCommand: EnterCmdExtentData(envPtr, currCmdIndex, parsePtr->term - parsePtr->commandStart, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + *lastPopPtr = currCmdIndex; + if (cmdKnown) { Tcl_DecrRefCount(cmdObj); @@ -2051,6 +2054,7 @@ TclCompileScript( unsigned char *entryCodeNext = envPtr->codeNext; const char *p; int cmdLine, *clNext; + int lastPop = -1; if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); @@ -2081,6 +2085,7 @@ TclCompileScript( parse.commandStart + parse.commandSize - 1)? parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); + lastPop = -1; break; } @@ -2109,7 +2114,7 @@ TclCompileScript( envPtr->line = cmdLine; envPtr->clNext = clNext; - CompileCommandTokens(interp, &parse, envPtr); + CompileCommandTokens(interp, &parse, envPtr, &lastPop); cmdLine = envPtr->line; clNext = envPtr->clNext; @@ -2145,8 +2150,8 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); - } else if (envPtr->codeNext[-1] == INST_POP) { - /* Remove the surplus INST_POP */ + } else if (lastPop >= 0) { + envPtr->cmdMapPtr[lastPop].numCodeBytes--; envPtr->codeNext--; TclAdjustStackDepth(1, envPtr); } -- cgit v0.12 From 7070acfea16b0c6906cd488877c1bb74afca5275 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Jun 2013 13:11:53 +0000 Subject: plug memory leaks --- generic/tclCompile.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 62943b2..416078c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1746,7 +1746,7 @@ CompileCommandTokens( int *lastPopPtr) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *cmdObj = Tcl_NewObj(); + Tcl_Obj *cmdObj; Tcl_Token *tokenPtr = parsePtr->tokenPtr; Command *cmdPtr = NULL; int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; @@ -1765,6 +1765,7 @@ CompileCommandTokens( } } + cmdObj = Tcl_NewObj(); Tcl_IncrRefCount(cmdObj); tokenPtr = parsePtr->tokenPtr; cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); @@ -2085,6 +2086,7 @@ TclCompileScript( parse.commandStart + parse.commandSize - 1)? parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); + Tcl_FreeParse(&parse); lastPop = -1; break; } -- cgit v0.12 From a47b03577bd612657a8cc1c7844231c00bc6d313 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Jun 2013 20:10:41 +0000 Subject: Stop the compileProc routines leaving behind error messages in interp. (Nicer way to solve [Bug 20a81392ec].) Make simplifications in TclCompileScript() make possible by the new structure. Still a work in progress. --- generic/tclAssembly.c | 32 +++++++++++++- generic/tclCompCmds.c | 5 ++- generic/tclCompCmdsGR.c | 1 + generic/tclCompile.c | 109 ++++++++++++++++++++++-------------------------- 4 files changed, 83 insertions(+), 64 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 62641e6..1a061f0 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -930,6 +930,12 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ +#if 0 + int numCommands = envPtr->numCommands; + int offset = envPtr->codeNext - envPtr->codeStart; + int depth = envPtr->currStackDepth; +#endif + /* * Make sure that the command has a single arg that is a simple word. */ @@ -943,10 +949,32 @@ TclCompileAssembleCmd( } /* - * Compile the code and return any error from the compilation. + * Compile the code and convert any error from the compilation into + * bytecode reporting the error; */ - return TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0); + if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, + tokenPtr[1].size, TCL_EVAL_DIRECT)) { + + /* + * TODO: Finish working out how to capture syntax errors captured + * during compile and make them bytecode reporting the error. + */ +#if 0 + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%.*s\" body, line %d)", + parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, + Tcl_GetErrorLine(interp))); + envPtr->numCommands = numCommands; + envPtr->codeNext = envPtr->codeStart + offset; + envPtr->currStackDepth = depth; + TclCompileSyntaxError(interp, envPtr); +#else + Tcl_ResetResult(interp); + return TCL_ERROR; +#endif + } + return TCL_OK; } /* diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fddf152..18295eb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2544,7 +2544,7 @@ CompileEachloopCmd( Tcl_DStringInit(&varList); TclDStringAppendToken(&varList, &tokenPtr[1]); - code = Tcl_SplitList(interp, Tcl_DStringValue(&varList), + code = Tcl_SplitList(NULL, Tcl_DStringValue(&varList), &varcList[loopIndex], &varvList[loopIndex]); Tcl_DStringFree(&varList); if (code != TCL_OK) { @@ -2988,7 +2988,8 @@ TclCompileFormatCmd( ckfree(objv); Tcl_DecrRefCount(formatObj); if (tmpObj == NULL) { - return TCL_ERROR; + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; } /* diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index f7c15e6..4de8cf2 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2534,6 +2534,7 @@ TclCompileSyntaxError( TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); + Tcl_ResetResult(interp); } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 416078c..5a8524c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1738,24 +1738,25 @@ FindCompiledCommandFromToken( */ #if 1 -static void +static int CompileCommandTokens( Tcl_Interp *interp, Tcl_Parse *parsePtr, - CompileEnv *envPtr, - int *lastPopPtr) + CompileEnv *envPtr) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *cmdObj; Tcl_Token *tokenPtr = parsePtr->tokenPtr; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + Tcl_Obj *cmdObj = Tcl_NewObj(); Command *cmdPtr = NULL; int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int *wlines, wlineat; + int cmdLine = envPtr->line; + int *clNext = envPtr->clNext; + int cmdIdx = envPtr->numCommands; + int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - if (numWords == 0) { - return; - } + assert (numWords > 0); for (wordIdx = 0; wordIdx < numWords; wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { @@ -1765,7 +1766,6 @@ CompileCommandTokens( } } - cmdObj = Tcl_NewObj(); Tcl_IncrRefCount(cmdObj); tokenPtr = parsePtr->tokenPtr; cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); @@ -1787,15 +1787,9 @@ CompileCommandTokens( } /* Pre-Compile */ -int lastTopLevelCmdIndex, currCmdIndex, startCodeOffset; - -int cmdLine = envPtr->line; -int *clNext = envPtr->clNext; - lastTopLevelCmdIndex = currCmdIndex = envPtr->numCommands; envPtr->numCommands++; - startCodeOffset = envPtr->codeNext - envPtr->codeStart; - EnterCmdStartData(envPtr, currCmdIndex, + EnterCmdStartData(envPtr, cmdIdx, parsePtr->commandStart - envPtr->source, startCodeOffset); if (expand && !cmdPtr) { @@ -2016,11 +2010,9 @@ int *clNext = envPtr->clNext; finishCommand: TclEmitOpcode(INST_POP, envPtr); - EnterCmdExtentData(envPtr, currCmdIndex, + EnterCmdExtentData(envPtr, cmdIdx, parsePtr->term - parsePtr->commandStart, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - *lastPopPtr = currCmdIndex; - if (cmdKnown) { Tcl_DecrRefCount(cmdObj); @@ -2037,6 +2029,8 @@ finishCommand: ckfree(eclPtr->loc[wlineat].next); eclPtr->loc[wlineat].line = wlines; eclPtr->loc[wlineat].next = NULL; + + return cmdIdx; } #endif @@ -2052,10 +2046,8 @@ TclCompileScript( CompileEnv *envPtr) /* Holds resulting instructions. */ { #if 1 - unsigned char *entryCodeNext = envPtr->codeNext; - const char *p; - int cmdLine, *clNext; - int lastPop = -1; + int lastCmdIdx = -1; + const char *p = script; if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); @@ -2066,40 +2058,34 @@ TclCompileScript( * from the script. */ - p = script; - cmdLine = envPtr->line; - clNext = envPtr->clNext; + /* TODO: Figure out when/why we need this */ +#if 0 +if (Tcl_GetStringResult(interp)[0] != '\0') { + fprintf(stdout, "INIT: '%s'\n", Tcl_GetStringResult(interp)); + fflush(stdout); +} +#endif + Tcl_ResetResult(interp); while (numBytes > 0) { Tcl_Parse parse; const char *next; - /* TODO: can we relocate this to happen less frequently? */ - Tcl_ResetResult(interp); 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, +/* TODO: Make this more sensible, f. ex. [eval {foo \$x(}] */ /* Drop the command terminator (";","]") if appropriate */ (parse.term == parse.commandStart + parse.commandSize - 1)? parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); Tcl_FreeParse(&parse); - lastPop = -1; - break; + return; } - /* - * TIP #280: Count newlines before the command start. - * (See test info-30.33). - */ - - TclAdvanceLines(&cmdLine, p, parse.commandStart); - TclAdvanceContinuations(&cmdLine, &clNext, - parse.commandStart - envPtr->source); - #ifdef TCL_COMPILE_DEBUG /* * If tracing, print a line for each top level command compiled. @@ -2114,48 +2100,51 @@ TclCompileScript( } #endif - envPtr->line = cmdLine; - envPtr->clNext = clNext; - CompileCommandTokens(interp, &parse, envPtr, &lastPop); - cmdLine = envPtr->line; - clNext = envPtr->clNext; + /* + * 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 to the next command in the script. + * Advance parser to the next command in the script. */ next = parse.commandStart + parse.commandSize; numBytes -= next - p; p = next; + if (parse.numWords == 0) { + /* TODO: Document justification */ + continue; + } + + lastCmdIdx = CompileCommandTokens(interp, &parse, envPtr); + /* * TIP #280: Track lines in the just compiled command. */ - TclAdvanceLines(&cmdLine, parse.commandStart, p); - TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); + TclAdvanceLines(&envPtr->line, parse.commandStart, p); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + p - envPtr->source); Tcl_FreeParse(&parse); } /* - * TIP #280: Bring the line counts in the CompEnv up to date. - * See tests info-30.33,34,35 . - */ - - envPtr->line = cmdLine; - envPtr->clNext = clNext; - - /* * If the source script yielded no instructions (e.g., if it was empty), * push an empty string as the command's result. */ - if (envPtr->codeNext == entryCodeNext) { - PushStringLiteral(envPtr, ""); - } else if (lastPop >= 0) { - envPtr->cmdMapPtr[lastPop].numCodeBytes--; + if (lastCmdIdx >= 0) { + envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; - TclAdjustStackDepth(1, envPtr); + envPtr->currStackDepth++; + } else { + PushStringLiteral(envPtr, ""); } #else int lastTopLevelCmdIndex = -1; -- cgit v0.12 From 05fb0c0810d175e0affff7d4d7e507141aa0c5ff Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Jun 2013 02:58:15 +0000 Subject: More elimination of error message litter to fix [Bug 20a81392ec]. --- generic/tclCompCmdsSZ.c | 3 +++ generic/tclCompile.c | 8 -------- generic/tclExecute.c | 18 +++++++----------- 3 files changed, 10 insertions(+), 19 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 855dd8f..026b214 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -748,6 +748,9 @@ TclSubstCompile( Tcl_InterpState state = NULL; TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); + if (state != NULL) { + Tcl_ResetResult(interp); + } /* * Tricky point! If the first token does not result in a *guaranteed* push diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5a8524c..1f72aa7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2058,14 +2058,6 @@ TclCompileScript( * from the script. */ - /* TODO: Figure out when/why we need this */ -#if 0 -if (Tcl_GetStringResult(interp)[0] != '\0') { - fprintf(stdout, "INIT: '%s'\n", Tcl_GetStringResult(interp)); - fflush(stdout); -} -#endif - Tcl_ResetResult(interp); while (numBytes > 0) { Tcl_Parse parse; const char *next; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d3a0d32..37bf072 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1426,17 +1426,12 @@ Tcl_NRExprObj( Tcl_Obj *resultPtr) { ByteCode *codePtr; + Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK); - /* TODO: consider saving whole state? */ - Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp); - - Tcl_IncrRefCount(saveObjPtr); - + Tcl_ResetResult(interp); codePtr = CompileExprObj(interp, objPtr); - /* TODO: Confirm reset not required? */ - /*Tcl_ResetResult(interp);*/ - Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr, + Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr, NULL, NULL); return TclNRExecuteByteCode(interp, codePtr); } @@ -1447,14 +1442,15 @@ ExprObjCallback( Tcl_Interp *interp, int result) { - Tcl_Obj *saveObjPtr = data[0]; + Tcl_InterpState state = data[0]; Tcl_Obj *resultPtr = data[1]; if (result == TCL_OK) { TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_SetObjResult(interp, saveObjPtr); + (void) Tcl_RestoreInterpState(interp, state); + } else { + Tcl_DiscardInterpState(state); } - TclDecrRefCount(saveObjPtr); return result; } -- cgit v0.12 From aec5846c12ee4a0dc9b655a8e127c567b248d29f Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 1 Jul 2013 20:58:15 +0000 Subject: More Work In Progress. --- generic/tclCompile.c | 55 ++++++++++++++++++++++++++++++++-------------------- tests/misc.test | 7 +------ 2 files changed, 35 insertions(+), 27 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1f72aa7..6f5ef50 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -16,6 +16,8 @@ #include "tclCompile.h" #include +#define REWRITE + /* * Table of all AuxData types. */ @@ -562,8 +564,10 @@ static void EnterCmdExtentData(CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); +#ifndef REWRITE static Command * FindCompiledCommandFromToken(Tcl_Interp *interp, Tcl_Token *tokenPtr); +#endif static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); @@ -1671,6 +1675,7 @@ TclWordKnownAtCompileTime( return 1; } +#ifndef REWRITE /* * --------------------------------------------------------------------- * @@ -1718,6 +1723,7 @@ FindCompiledCommandFromToken( Tcl_DStringFree(&ds); return cmdPtr; } +#endif /* *---------------------------------------------------------------------- @@ -1737,7 +1743,7 @@ FindCompiledCommandFromToken( *---------------------------------------------------------------------- */ -#if 1 +#ifdef REWRITE static int CompileCommandTokens( Tcl_Interp *interp, @@ -2045,18 +2051,18 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { -#if 1 - int lastCmdIdx = -1; - const char *p = script; +#ifdef REWRITE + 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. */ if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); } - /* - * Each iteration through the following loop compiles the next command - * from the script. - */ + /* Each iteration compiles one command from the script. */ while (numBytes > 0) { Tcl_Parse parse; @@ -2068,11 +2074,7 @@ TclCompileScript( */ Tcl_LogCommandInfo(interp, script, parse.commandStart, -/* TODO: Make this more sensible, f. ex. [eval {foo \$x(}] */ - /* Drop the command terminator (";","]") if appropriate */ - (parse.term == - parse.commandStart + parse.commandSize - 1)? - parse.commandSize - 1 : parse.commandSize); + parse.term + 1 - parse.commandStart); TclCompileSyntaxError(interp, envPtr); Tcl_FreeParse(&parse); return; @@ -2126,17 +2128,28 @@ TclCompileScript( Tcl_FreeParse(&parse); } - /* - * If the source script yielded no instructions (e.g., if it was empty), - * push an empty string as the command's result. - */ - - if (lastCmdIdx >= 0) { + if (lastCmdIdx == -1) { + /* + * 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. + */ + PushStringLiteral(envPtr, ""); + } else { + /* + * We compiled at least one command to bytecode. The routine + * CompileCommandTokens() follows the bytecode of each compiled + * command with an INST_POP, so that stack balance is maintained + * when several commands are in sequence. (The result of each + * command is thrown away before moving on to the next command). + * For the last command compiled, we need to undo that INST_POP + * so that the result of the last command becomes the result of + * the script. These code here removes that trailing INST_POP. + */ envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; envPtr->currStackDepth++; - } else { - PushStringLiteral(envPtr, ""); } #else int lastTopLevelCmdIndex = -1; diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..d4ece74 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} { missing close-brace for variable name missing close-brace for variable name while executing -"set tst $a([winfo name $\{zz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a ..." +"set tst $a([winfo name $\{" (procedure "tstProc" line 4) invoked from within "tstProc"}] -- cgit v0.12 From 88731d9d93913d8f5ce27cd5153be02c84e5eb7a Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 2 Jul 2013 10:36:32 +0000 Subject: comment improvements --- generic/tclCompile.c | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6f5ef50..05daabf 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1764,6 +1764,7 @@ CompileCommandTokens( assert (numWords > 0); + /* Determine whether any words of the command require expansion */ for (wordIdx = 0; wordIdx < numWords; wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { @@ -1772,6 +1773,7 @@ CompileCommandTokens( } } + /* Do we know the command word? */ Tcl_IncrRefCount(cmdObj); tokenPtr = parsePtr->tokenPtr; cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); @@ -1791,6 +1793,7 @@ CompileCommandTokens( } } } + /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ /* Pre-Compile */ @@ -2112,7 +2115,22 @@ TclCompileScript( p = next; if (parse.numWords == 0) { - /* TODO: Document justification */ + /* + * 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; } @@ -2145,7 +2163,7 @@ TclCompileScript( * command is thrown away before moving on to the next command). * For the last command compiled, we need to undo that INST_POP * so that the result of the last command becomes the result of - * the script. These code here removes that trailing INST_POP. + * the script. The code here removes that trailing INST_POP. */ envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; -- cgit v0.12 From bd6afa9af58278486c0b7c0ac99561c1dbae6ad1 Mon Sep 17 00:00:00 2001 From: stwo Date: Sun, 7 Jul 2013 02:19:20 +0000 Subject: OpenBSD/m88k is now elf. Remove unneeded elf check. --- unix/configure | 43 ++++--------------------------------------- unix/tcl.m4 | 15 ++++----------- 2 files changed, 8 insertions(+), 50 deletions(-) diff --git a/unix/configure b/unix/configure index 3e04284..6faa7d8 100755 --- a/unix/configure +++ b/unix/configure @@ -7562,11 +7562,12 @@ fi OpenBSD-*) arch=`arch -s` case "$arch" in - m88k|vax) + vax) # Equivalent using configure option --disable-load # Step 4 will set the necessary variables DL_OBJS="" SHLIB_LD_LIBS="" + LDFLAGS="" ;; *) SHLIB_CFLAGS="-fPIC" @@ -7581,10 +7582,11 @@ fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' + LDFLAGS="-Wl,-export-dynamic" ;; esac case "$arch" in - m88k|vax) + vax) CFLAGS_OPTIMIZE="-O1" ;; sh) @@ -7594,43 +7596,6 @@ fi CFLAGS_OPTIMIZE="-O2" ;; esac - echo "$as_me:$LINENO: checking for ELF" >&5 -echo $ECHO_N "checking for ELF... $ECHO_C" >&6 -if test "${tcl_cv_ld_elf+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -#ifdef __ELF__ - yes -#endif - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "yes" >/dev/null 2>&1; then - tcl_cv_ld_elf=yes -else - tcl_cv_ld_elf=no -fi -rm -f conftest* - -fi -echo "$as_me:$LINENO: result: $tcl_cv_ld_elf" >&5 -echo "${ECHO_T}$tcl_cv_ld_elf" >&6 - if test $tcl_cv_ld_elf = yes; then - - LDFLAGS=-Wl,-export-dynamic - -else - LDFLAGS="" -fi - if test "${TCL_THREADS}" = "1"; then # On OpenBSD: Compile with -pthread diff --git a/unix/tcl.m4 b/unix/tcl.m4 index cdc5f99..879d810 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1484,11 +1484,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ OpenBSD-*) arch=`arch -s` case "$arch" in - m88k|vax) + vax) # Equivalent using configure option --disable-load # Step 4 will set the necessary variables DL_OBJS="" SHLIB_LD_LIBS="" + LDFLAGS="" ;; *) SHLIB_CFLAGS="-fPIC" @@ -1500,10 +1501,11 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' + LDFLAGS="-Wl,-export-dynamic" ;; esac case "$arch" in - m88k|vax) + vax) CFLAGS_OPTIMIZE="-O1" ;; sh) @@ -1513,15 +1515,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_OPTIMIZE="-O2" ;; esac - AC_CACHE_CHECK([for ELF], tcl_cv_ld_elf, [ - AC_EGREP_CPP(yes, [ -#ifdef __ELF__ - yes -#endif - ], tcl_cv_ld_elf=yes, tcl_cv_ld_elf=no)]) - AS_IF([test $tcl_cv_ld_elf = yes], [ - LDFLAGS=-Wl,-export-dynamic - ], [LDFLAGS=""]) AS_IF([test "${TCL_THREADS}" = "1"], [ # On OpenBSD: Compile with -pthread # Don't link with -lpthread -- cgit v0.12 From de31df63e799b702d1ebfe1ac588b4d2efa3e6cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 8 Jul 2013 06:49:44 +0000 Subject: Build stub objects with -DSTATIC_BUILD on all platforms. Only important on win32 (already done) and cygwin, on other platforms it should not have any effect. --- unix/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 34c7165..f6c4424 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1529,7 +1529,7 @@ waitpid.o: $(COMPAT_DIR)/waitpid.c # even though they will be placed in a static archive tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c - $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLib.c .c.o: $(CC) -c $(CC_SWITCHES) $< -- cgit v0.12 From d2b490f552aaf53f2f3d66b630c40a5db14157d1 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 14:31:14 +0000 Subject: The routines StartExpanding() and EnterCmdWordData() are orthogonal, so it's ok to reverse the order in which they are called. --- generic/tclCompile.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5aab69c..0dc30e2 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1802,10 +1802,6 @@ CompileCommandTokens( EnterCmdStartData(envPtr, cmdIdx, parsePtr->commandStart - envPtr->source, startCodeOffset); - if (expand && !cmdPtr) { - StartExpanding(envPtr); - } - /* * TIP #280. Scan the words and compute the extended location * information. The map first contain full per-word line @@ -1823,6 +1819,9 @@ CompileCommandTokens( envPtr->line = eclPtr->loc[wlineat].line[0]; envPtr->clNext = eclPtr->loc[wlineat].next[0]; + if (expand && !cmdPtr) { + StartExpanding(envPtr); + } if (cmdPtr) { int savedNumCmds = envPtr->numCommands; int update = 0; -- cgit v0.12 From 0dec640514ea686e9617b9813107057e7972300d Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 15:00:02 +0000 Subject: Consolidate the StartExpanding() calls. --- generic/tclCompile.c | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 0dc30e2..cbb93d9 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1819,9 +1819,6 @@ CompileCommandTokens( envPtr->line = eclPtr->loc[wlineat].line[0]; envPtr->clNext = eclPtr->loc[wlineat].next[0]; - if (expand && !cmdPtr) { - StartExpanding(envPtr); - } if (cmdPtr) { int savedNumCmds = envPtr->numCommands; int update = 0; @@ -1919,11 +1916,10 @@ CompileCommandTokens( envPtr->line = eclPtr->loc[wlineat].line[0]; envPtr->clNext = eclPtr->loc[wlineat].next[0]; + } - /* TODO: Can this happen? If so, is this right? */ - if (expand) { - StartExpanding(envPtr); - } + if (expand) { + StartExpanding(envPtr); } /* -- cgit v0.12 From da4296c06f86f3d4ff58fb77959049d42698d52a Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 15:24:56 +0000 Subject: Defer expansion request detection as much as possible. --- generic/tclCompile.c | 43 ++++++++++++++++++++++++++++++------------- 1 file changed, 30 insertions(+), 13 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cbb93d9..052dc8e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1744,6 +1744,22 @@ FindCompiledCommandFromToken( */ #ifdef REWRITE + +static int +ExpandRequested( + Tcl_Token *tokenPtr, + int numWords) +{ + /* Determine whether any words of the command require expansion */ + while (numWords--) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + return 1; + } + tokenPtr += tokenPtr->numComponents + 1; + } + return 0; +} + static int CompileCommandTokens( Tcl_Interp *interp, @@ -1755,7 +1771,7 @@ CompileCommandTokens( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; Tcl_Obj *cmdObj = Tcl_NewObj(); Command *cmdPtr = NULL; - int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; + int wordIdx, cmdKnown, expand = -1, numWords = parsePtr->numWords; int *wlines, wlineat; int cmdLine = envPtr->line; int *clNext = envPtr->clNext; @@ -1763,15 +1779,6 @@ CompileCommandTokens( int startCodeOffset = envPtr->codeNext - envPtr->codeStart; assert (numWords > 0); - - /* Determine whether any words of the command require expansion */ - for (wordIdx = 0; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; - break; - } - } /* Do we know the command word? */ Tcl_IncrRefCount(cmdObj); @@ -1783,13 +1790,19 @@ CompileCommandTokens( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); if (cmdPtr) { /* - * Found a command. Test all the ways we can be told + * Found a command. Test the ways we can be told * not to attempt to compile it. */ if ((cmdPtr->compileProc == NULL) || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) - || (cmdPtr->flags & CMD_HAS_EXEC_TRACES) - || (expand && !(cmdPtr->flags & CMD_COMPILES_EXPANDED))) { + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + cmdPtr = NULL; + } + } + if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + if (expand) { + /* We need to expand, but compileProc cannot. */ cmdPtr = NULL; } } @@ -1918,6 +1931,10 @@ CompileCommandTokens( envPtr->clNext = eclPtr->loc[wlineat].next[0]; } + if (expand < 0) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + } + if (expand) { StartExpanding(envPtr); } -- cgit v0.12 From 582824087ddfbdc099f0f7d8a8f0dc6a858de7d3 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 15:39:55 +0000 Subject: Move TIP 280 and command extent housekeeping to the periphery. --- generic/tclCompile.c | 54 ++++++++++++++++++++++++++-------------------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 052dc8e..388b8a0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1780,6 +1780,29 @@ CompileCommandTokens( assert (numWords > 0); + /* Pre-Compile */ + + envPtr->numCommands++; + EnterCmdStartData(envPtr, cmdIdx, + parsePtr->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, + 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; @@ -1809,29 +1832,6 @@ CompileCommandTokens( } /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ - /* Pre-Compile */ - - envPtr->numCommands++; - EnterCmdStartData(envPtr, cmdIdx, - parsePtr->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, - clNext, &wlines, envPtr); - wlineat = eclPtr->nuloc - 1; - - envPtr->line = eclPtr->loc[wlineat].line[0]; - envPtr->clNext = eclPtr->loc[wlineat].next[0]; - if (cmdPtr) { int savedNumCmds = envPtr->numCommands; int update = 0; @@ -2031,15 +2031,15 @@ CompileCommandTokens( } finishCommand: + if (cmdKnown) { + Tcl_DecrRefCount(cmdObj); + } + TclEmitOpcode(INST_POP, envPtr); EnterCmdExtentData(envPtr, cmdIdx, parsePtr->term - parsePtr->commandStart, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - if (cmdKnown) { - Tcl_DecrRefCount(cmdObj); - } - /* * TIP #280: Free full form of per-word line data and insert the * reduced form now -- cgit v0.12 From c10c796a466cd52d2fd3d2999801eb66a575388d Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 18:08:01 +0000 Subject: Plug memory leak; Break three compilation mechanisms into routines. --- generic/tclCompile.c | 462 +++++++++++++++++++++++++++++---------------------- 1 file changed, 266 insertions(+), 196 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 388b8a0..1958d47 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1760,6 +1760,255 @@ ExpandRequested( return 0; } +static void +CompileInvocation( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + int wlineat, + CompileEnv *envPtr) +{ + int isnew, wordIdx = 0; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + + if (cmdObj) { + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), + cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); + + wordIdx = 1; + tokenPtr += tokenPtr->numComponents + 1; + } + + for (; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + int objIdx; + + envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, + eclPtr->loc[wlineat].next[wordIdx]); + } + TclEmitPush(objIdx, envPtr); + } + + /* + * Save PC -> command map for the TclArgumentBC* functions. + */ + + Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, + INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew), + INT2PTR(wlineat)); + + if (wordIdx <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + } +} + +static void +CompileExpanded( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + int wlineat, + CompileEnv *envPtr) +{ + int wordIdx = 0; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + + StartExpanding(envPtr); + if (cmdObj) { + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, + TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); + + wordIdx = 1; + tokenPtr += tokenPtr->numComponents + 1; + } + + for (; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + int objIdx; + + envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); + } + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, + eclPtr->loc[wlineat].next[wordIdx]); + } + TclEmitPush(objIdx, envPtr); + } + + /* + * The stack depth during argument expansion can only be + * managed at runtime, as the number of elements in the + * expanded lists is not known at compile time. We adjust here + * the stack depth estimate so that it is correct after the + * command with expanded arguments returns. + * + * The end effect of this command's invocation is that all the + * words of the command are popped from the stack, and the + * result is pushed: the stack top changes by (1-wordIdx). + * + * Note that the estimates are not correct while the command + * is being prepared and run, INST_EXPAND_STKTOP is not + * stack-neutral in general. + */ + + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; + TclAdjustStackDepth(1 - wordIdx, envPtr); +} + +static int +CompileCmdCompileProc( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, + int startCodeOffset, + CompileEnv *envPtr) +{ + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + int savedNumCmds = envPtr->numCommands; + int startStackDepth = envPtr->currStackDepth; + int wlineat = eclPtr->nuloc - 1; + int update = 0; + + /* + * Mark the start of the command; the proper bytecode + * length will be updated later. There is no need to + * do this for the first bytecode in the compile env, + * as the check is done before calling + * TclNRExecuteByteCode(). Do emit an INST_START_CMD + * in special cases where the first bytecode is in a + * loop, to insure that the corresponding command is + * counted properly. Compilers for commands able to + * produce such a beast (currently 'while 1' only) set + * envPtr->atCmdStart to 0 in order to signal this + * case. [Bug 1752146] + * + * Note that the environment is initialised with + * atCmdStart=1 to avoid emitting ISC for the first + * command. + */ + + if (envPtr->atCmdStart == 1) { + if (startCodeOffset) { + /* + * Increase the number of commands being + * started at the current point. Note that + * this depends on the exact layout of the + * INST_START_CMD's operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) + } + } else if (envPtr->atCmdStart == 0) { + TclEmitInstInt4(INST_START_CMD, 0, envPtr); + TclEmitInt4(1, envPtr); + update = 1; + } + + if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { + +#ifdef TCL_COMPILE_DEBUG + /* + * Confirm that the command compiler generated a + * single value on the stack as its result. This + * is only done in debugging mode, as it *should* + * be correct and normal users have no reasonable + * way to fix it anyway. + */ + + int diff = envPtr->currStackDepth - startStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif + if (update) { + /* + * Fix the bytecode length. + */ + + unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; + unsigned fixLen = envPtr->codeNext - fixPtr + 1; + + TclStoreInt4AtPtr(fixLen, fixPtr); + } + return TCL_OK; + } + + if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { + /* + * Decrease the number of commands being started + * at the current point. Note that this depends on + * the exact layout of the INST_START_CMD's + * operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); + } + + /* + * Restore numCommands, codeNext, and currStackDepth to their + * correct values, removing any commands compiled before the + * failure to produce bytecode got reported. + * [Bugs 705406, 735055, 3614102] + */ + + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart + startCodeOffset; + envPtr->currStackDepth = startStackDepth; + + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + return TCL_ERROR; +} + static int CompileCommandTokens( Tcl_Interp *interp, @@ -1771,14 +2020,15 @@ CompileCommandTokens( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; Tcl_Obj *cmdObj = Tcl_NewObj(); Command *cmdPtr = NULL; - int wordIdx, cmdKnown, expand = -1, numWords = parsePtr->numWords; + 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; - assert (numWords > 0); + assert (parsePtr->numWords > 0); /* Pre-Compile */ @@ -1830,210 +2080,30 @@ CompileCommandTokens( } } } - /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ + /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ if (cmdPtr) { - int savedNumCmds = envPtr->numCommands; - int update = 0; - int startStackDepth = envPtr->currStackDepth; - - /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD - * in special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] - * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. - */ - - if (envPtr->atCmdStart == 1) { - if (startCodeOffset) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) - } - } else if (envPtr->atCmdStart == 0) { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; - } - - if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { - -#ifdef TCL_COMPILE_DEBUG - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ - - int diff = envPtr->currStackDepth - startStackDepth; - - if (diff != 1) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", - parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif - if (update) { - /* - * Fix the bytecode length. - */ - - unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; - unsigned fixLen = envPtr->codeNext - fixPtr + 1; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } - - if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); - } - - /* - * Restore numCommands, codeNext, and currStackDepth to their - * correct values, removing any commands compiled before the - * failure to produce bytecode got reported. - * [Bugs 705406, 735055, 3614102] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + startCodeOffset; - envPtr->currStackDepth = startStackDepth; - - envPtr->line = eclPtr->loc[wlineat].line[0]; - envPtr->clNext = eclPtr->loc[wlineat].next[0]; - } - - if (expand < 0) { - expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); - } - - if (expand) { - StartExpanding(envPtr); - } - - /* - * No complile attempted, or it failed. - * Need to emit instructions to invoke, with expansion if needed. - */ - - wordIdx = 0; - tokenPtr = parsePtr->tokenPtr; - if (cmdKnown) { - int cmdLitIdx, numBytes; - const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - - cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - if (cmdPtr) { - TclSetCmdNameObj(interp, - TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); - } - TclEmitPush(cmdLitIdx, envPtr); - - wordIdx = 1; - tokenPtr += tokenPtr->numComponents + 1; + code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, + startCodeOffset, envPtr); } - for (; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - int objIdx; - - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - CompileTokens(envPtr, tokenPtr, interp); - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); - } - continue; - } - - objIdx = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (envPtr->clNext) { - TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), - tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); + if (code == TCL_ERROR) { + if (expand < 0) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); } - TclEmitPush(objIdx, envPtr); - } - - /* - * Emit an invoke instruction for the command. We skip this if a - * compile procedure was found for the command. - */ - if (expand) { - /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. - * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). - * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. - */ - - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - envPtr->expandCount--; - TclAdjustStackDepth(1 - wordIdx, envPtr); - } else { - /* - * Save PC -> command map for the TclArgumentBC* functions. - */ - - int isnew; - Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, - INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew); - - Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); - if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + if (expand) { + CompileExpanded(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, + envPtr); } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + CompileInvocation(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, + envPtr); } } -finishCommand: - if (cmdKnown) { - Tcl_DecrRefCount(cmdObj); - } + Tcl_DecrRefCount(cmdObj); TclEmitOpcode(INST_POP, envPtr); EnterCmdExtentData(envPtr, cmdIdx, -- cgit v0.12 From b7fbf3c4330d9ae89e9884f07cb897729e122045 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 8 Jul 2013 18:55:23 +0000 Subject: Unbreak MSVC6 debug build (thanks Andreas Kupries!) --- generic/tclUtf.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index a122685..a038f8a 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1554,7 +1554,7 @@ Tcl_UniCharIsSpace( */ if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) { - return TclIsSpaceProc(ch); + return TclIsSpaceProc((char) ch); } else if ((Tcl_UniChar) ch == 0x180e) { return 1; } else { -- cgit v0.12 From e10479f3d739f650bd4b5a041b973f66796f4e4b Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 19:29:01 +0000 Subject: Factor out compiling the Command literal. --- generic/tclCompile.c | 41 +++++++++++++++++++---------------------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1958d47..a1ad5c8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1761,6 +1761,23 @@ ExpandRequested( } static void +CompileCmdLiteral( + Tcl_Interp *interp, + Tcl_Obj *cmdObj, + CompileEnv *envPtr) +{ + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); +} + +static void CompileInvocation( Tcl_Interp *interp, Tcl_Token *tokenPtr, @@ -1773,17 +1790,7 @@ CompileInvocation( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; if (cmdObj) { - int numBytes; - const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); - Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - - if (cmdPtr) { - TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), - cmdPtr); - } - TclEmitPush(cmdLitIdx, envPtr); - + CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; tokenPtr += tokenPtr->numComponents + 1; } @@ -1839,17 +1846,7 @@ CompileExpanded( StartExpanding(envPtr); if (cmdObj) { - int numBytes; - const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); - Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - - if (cmdPtr) { - TclSetCmdNameObj(interp, - TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); - } - TclEmitPush(cmdLitIdx, envPtr); - + CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; tokenPtr += tokenPtr->numComponents + 1; } -- cgit v0.12 From ba3bf9b61fa445633a8699982aa8ef38bdd75e80 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 22:36:55 +0000 Subject: Use TIP 280 macros. --- generic/tclCompile.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a1ad5c8..656f700 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1906,11 +1906,10 @@ CompileCmdCompileProc( int startCodeOffset, CompileEnv *envPtr) { - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int savedNumCmds = envPtr->numCommands; int startStackDepth = envPtr->currStackDepth; - int wlineat = eclPtr->nuloc - 1; int update = 0; + DefineLineInformation; /* * Mark the start of the command; the proper bytecode @@ -2001,8 +2000,7 @@ CompileCmdCompileProc( envPtr->codeNext = envPtr->codeStart + startCodeOffset; envPtr->currStackDepth = startStackDepth; - envPtr->line = eclPtr->loc[wlineat].line[0]; - envPtr->clNext = eclPtr->loc[wlineat].next[0]; + SetLineInformation(0); return TCL_ERROR; } -- cgit v0.12 From c46c7741267cbbe91a195e2abbbc19a95b0f3b3a Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 23:02:44 +0000 Subject: Use the TokenAfter() macro. --- generic/tclCompile.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 656f700..afe34b0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1755,7 +1755,7 @@ ExpandRequested( if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { return 1; } - tokenPtr += tokenPtr->numComponents + 1; + tokenPtr = TokenAfter(tokenPtr); } return 0; } @@ -1792,11 +1792,10 @@ CompileInvocation( if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; - tokenPtr += tokenPtr->numComponents + 1; + tokenPtr = TokenAfter(tokenPtr); } - for (; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; @@ -1848,11 +1847,10 @@ CompileExpanded( if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; - tokenPtr += tokenPtr->numComponents + 1; + tokenPtr = TokenAfter(tokenPtr); } - for (; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; -- cgit v0.12 From d72d5f8b7a85e097e1e934c4a757301699d80266 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 9 Jul 2013 20:37:37 +0000 Subject: Tentative Work In Progress unwinding TIP 280 line information. --- generic/tclCompile.c | 39 +++++++++++++++++++++++++++++---------- 1 file changed, 29 insertions(+), 10 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index afe34b0..777c03e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1787,7 +1787,8 @@ CompileInvocation( CompileEnv *envPtr) { int isnew, wordIdx = 0; - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; +// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + DefineLineInformation; if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); @@ -1798,8 +1799,9 @@ CompileInvocation( for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; +// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; +// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + SetLineInformation(wordIdx); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); @@ -1811,7 +1813,8 @@ CompileInvocation( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); +// eclPtr->loc[wlineat].next[wordIdx]); + mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); } @@ -1820,9 +1823,11 @@ CompileInvocation( * Save PC -> command map for the TclArgumentBC* functions. */ - Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, +// Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, + Tcl_SetHashValue(Tcl_CreateHashEntry(&mapPtr->litInfo, INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew), - INT2PTR(wlineat)); +// INT2PTR(wlineat)); + INT2PTR(eclIndex)); if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); @@ -1841,7 +1846,9 @@ CompileExpanded( CompileEnv *envPtr) { int wordIdx = 0; - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + DefineLineInformation; +// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + StartExpanding(envPtr); if (cmdObj) { @@ -1853,8 +1860,9 @@ CompileExpanded( for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + SetLineInformation(wordIdx); +// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; +// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); @@ -1870,7 +1878,8 @@ CompileExpanded( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); +// eclPtr->loc[wlineat].next[wordIdx]); + mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); } @@ -1998,6 +2007,16 @@ CompileCmdCompileProc( envPtr->codeNext = envPtr->codeStart + startCodeOffset; envPtr->currStackDepth = startStackDepth; + /* + * Throw out any line information generated by the failed + * compile attempt. + */ + while (mapPtr->nuloc - 1 > eclIndex) { + mapPtr->nuloc--; + ckfree(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; + } + SetLineInformation(0); return TCL_ERROR; } -- cgit v0.12 From afad6ffbb48761689faa9e08e8b9da7e5c63dca0 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 03:17:57 +0000 Subject: Revise the litInfo table so that it gets built later (in TclInitByteCodeObj) from a simpler store of data that can unwind. --- generic/tclCompile.c | 79 +++++++++++++--------------------------------------- generic/tclCompile.h | 1 + 2 files changed, 20 insertions(+), 60 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 777c03e..c31d256 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1786,8 +1786,7 @@ CompileInvocation( int wlineat, CompileEnv *envPtr) { - int isnew, wordIdx = 0; -// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + int wordIdx = 0; DefineLineInformation; if (cmdObj) { @@ -1799,8 +1798,6 @@ CompileInvocation( for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; -// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; -// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; SetLineInformation(wordIdx); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -1813,7 +1810,6 @@ CompileInvocation( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, -// eclPtr->loc[wlineat].next[wordIdx]); mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); @@ -1823,11 +1819,7 @@ CompileInvocation( * Save PC -> command map for the TclArgumentBC* functions. */ -// Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, - Tcl_SetHashValue(Tcl_CreateHashEntry(&mapPtr->litInfo, - INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew), -// INT2PTR(wlineat)); - INT2PTR(eclIndex)); + mapPtr->loc[eclIndex].invokePc = envPtr->codeNext - envPtr->codeStart; if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); @@ -1847,7 +1839,6 @@ CompileExpanded( { int wordIdx = 0; DefineLineInformation; -// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; StartExpanding(envPtr); @@ -1861,8 +1852,6 @@ CompileExpanded( int objIdx; SetLineInformation(wordIdx); -// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; -// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); @@ -1878,7 +1867,6 @@ CompileExpanded( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, -// eclPtr->loc[wlineat].next[wordIdx]); mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); @@ -2015,6 +2003,7 @@ CompileCmdCompileProc( mapPtr->nuloc--; ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; + mapPtr->loc[mapPtr->nuloc].invokePc = -1; } SetLineInformation(0); @@ -3340,6 +3329,17 @@ TclInitByteCodeObj( * byte code object (internal rep), for use with the bc compiler. */ + for (i = 0; i < envPtr->extCmdMapPtr->nuloc; i++) { + int isnew, pc = envPtr->extCmdMapPtr->loc[i].invokePc; + + if (pc < 0) { + continue; + } + + Tcl_SetHashValue(Tcl_CreateHashEntry(&envPtr->extCmdMapPtr->litInfo, + INT2PTR(pc), &isnew), INT2PTR(i)); + } + Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr, &isNew), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; @@ -3710,6 +3710,7 @@ EnterCmdWordData( ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; + ePtr->invokePc = -1; ePtr->line = ckalloc(numWords * sizeof(int)); ePtr->next = ckalloc(numWords * sizeof(int *)); ePtr->nline = numWords; @@ -4493,54 +4494,12 @@ TclFixupForwardJump( { ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; - - /* A helper structure */ - - typedef struct { - int pc; - int cmd; - } MAP; - - /* - * And the helper array. At most the whole hashtable is placed into - * this. - */ - - MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries); - - Tcl_HashSearch hSearch; - Tcl_HashEntry* hPtr; - int n, k, isnew; - - /* - * Phase I: Locate the affected entries, and save them in adjusted - * form to the array. This removes them from the hash. - */ - - for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - - map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr)); - map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr)); - - if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) { - Tcl_DeleteHashEntry(hPtr); - map [n].pc += 3; - n++; + for (k = eclPtr->nuloc - 1; k >= 0; k--) { + if (eclPtr->loc[k].invokePc < (jumpFixupPtr->codeOffset + 2)) { + continue; } + eclPtr->loc[k].invokePc += 3; } - - /* - * Phase II: Re-insert the modified entries into the hash. - */ - - for (k=0;klitInfo, INT2PTR(map[k].pc), &isnew); - Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd)); - } - - ckfree (map); } return 1; /* the jump was grown */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9af4911..cbe104c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -175,6 +175,7 @@ typedef struct CmdLocation { typedef struct ECL { int srcOffset; /* Command location to find the entry. */ + int invokePc; int nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ -- cgit v0.12 From 1e62f5ac76864a8e1e5d388fa6ecdef2dff63ca6 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 03:28:37 +0000 Subject: Remove the (now unused) wlineat arguments. --- generic/tclCompile.c | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c31d256..5f4acff 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1783,7 +1783,6 @@ CompileInvocation( Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, - int wlineat, CompileEnv *envPtr) { int wordIdx = 0; @@ -1834,7 +1833,6 @@ CompileExpanded( Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, - int wlineat, CompileEnv *envPtr) { int wordIdx = 0; @@ -2095,12 +2093,10 @@ CompileCommandTokens( if (expand) { CompileExpanded(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, - envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } else { CompileInvocation(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, - envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } } -- cgit v0.12 From ee74db1cbf0cb0122fbab5591ad2361c0a1f3313 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 16:17:12 +0000 Subject: Disabling the SetLineInformation() macro entirely causes only 3 tests in the test suite to fail. Restoring just 2 SetLineInformation() calls fixes those failures. The need for all the other SLI() calls is not demonstrated by any test. Without more complete test coverage, it is difficult to confidently tweak the TIP 280 implementation without fear that changes are introducing breakage. --- generic/tclCompCmdsGR.c | 2 ++ generic/tclCompCmdsSZ.c | 2 ++ generic/tclCompile.h | 9 ++++++--- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index f7c15e6..3cd0da6 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -265,6 +265,8 @@ TclCompileIfCmd( if (compileScripts) { SetLineInformation(wordIdx); +envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; +envPtr->clNext = mapPtr->loc[eclIndex].next[wordIdx]; CompileBody(envPtr, tokenPtr, interp); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 855dd8f..8723a4f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -726,6 +726,8 @@ TclCompileSubstCmd( } SetLineInformation(numArgs); +envPtr->line = mapPtr->loc[eclIndex].line[numArgs]; +envPtr->clNext = mapPtr->loc[eclIndex].next[numArgs]; TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9af4911..6fe14f2 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1537,9 +1537,12 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] +//#define SetLineInformation(word) \ +// envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ +// envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] + +#define SetLineInformation(word) + #define PushVarNameWord(i,v,e,f,l,sc,word) \ TclPushVarName(i,v,e,f,l,sc, \ -- cgit v0.12 From 7a53c36e3aa0311270181fed854e1c590656c2f3 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 16:27:09 +0000 Subject: First additional test. Remove dup macros in tclEnsemble.c. --- generic/tclCompCmds.c | 2 +- generic/tclCompCmdsGR.c | 4 +--- generic/tclCompCmdsSZ.c | 4 +--- generic/tclCompile.h | 6 +++--- generic/tclEnsemble.c | 10 ---------- tests/info.test | 15 +++++++++++++++ 6 files changed, 21 insertions(+), 20 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fddf152..7ed9006 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -610,7 +610,7 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - SetLineInformation(1); + LineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 3cd0da6..cc3f694 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -264,9 +264,7 @@ TclCompileIfCmd( */ if (compileScripts) { - SetLineInformation(wordIdx); -envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; -envPtr->clNext = mapPtr->loc[eclIndex].next[wordIdx]; + LineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 8723a4f..34c24f9 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -725,9 +725,7 @@ TclCompileSubstCmd( return TCL_ERROR; } - SetLineInformation(numArgs); -envPtr->line = mapPtr->loc[eclIndex].line[numArgs]; -envPtr->clNext = mapPtr->loc[eclIndex].next[numArgs]; + LineInformation(numArgs); TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6fe14f2..5043f65 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1537,9 +1537,9 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 -//#define SetLineInformation(word) \ -// envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ -// envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] +#define LineInformation(word) \ + envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] #define SetLineInformation(word) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 813e056..e0aa0c4 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -88,16 +88,6 @@ const Tcl_ObjType tclEnsembleCmdType = { NULL /* setFromAnyProc */ }; -/* - * Copied from tclCompCmds.c - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] static inline Tcl_Obj * NewNsObj( diff --git a/tests/info.test b/tests/info.test index ebc853a..a1d3b1a 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1962,6 +1962,21 @@ test info-9.13 {info level option, value in global context} -body { } -returnCodes error -result {bad level "2"} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + catch {*}{ + {info frame 0} + res + } + return $res +} +test info-33.4 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From d69c39d52e07b61221f06c9403a06c6a79ac31f9 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 16:43:01 +0000 Subject: Next attempt. Appears to have uncovered a bug. --- generic/tclCompCmds.c | 2 +- tests/info.test | 14 ++++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7ed9006..13318a3 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1467,7 +1467,7 @@ CompileDictEachCmd( * Compile the loop body itself. It should be stack-neutral. */ - SetLineInformation(3); + LineInformation(3); CompileBody(envPtr, bodyTokenPtr, interp); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); diff --git a/tests/info.test b/tests/info.test index a1d3b1a..ba31159 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1977,6 +1977,20 @@ test info-33.4 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + dict for {a b} {c d} {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.5 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From c079ab076f93957eb10fecbdc60e418c4007ca23 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 17:58:45 +0000 Subject: Fix for [86fb5ea28e]. Test will eventually merge in from tip280-test-coverage. --- generic/tclEnsemble.c | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 813e056..a718d0e 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3059,6 +3059,7 @@ CompileToCompiledCommand( int savedNumCmds = envPtr->numCommands; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; + DefineLineInformation; if (cmdPtr->compileProc == NULL) { return TCL_ERROR; @@ -3107,12 +3108,27 @@ CompileToCompiledCommand( } /* + * Shift the line information arrays to account for different word + * index values. + */ + + mapPtr->loc[eclIndex].line += (depth - 1); + mapPtr->loc[eclIndex].next += (depth - 1); + + /* * Hand off compilation to the subcommand compiler. At last! */ result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); /* + * Undo the shift. + */ + + mapPtr->loc[eclIndex].line -= (depth - 1); + mapPtr->loc[eclIndex].next -= (depth - 1); + + /* * If our target fails to compile, revert the number of commands and the * pointer to the place to issue the next instruction. [Bug 3600328] */ -- cgit v0.12 From 1dc19d83708afaa3accab0ba7a92882e1444158f Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 19:34:55 +0000 Subject: Add tests for, and fix bugs in, the SetLineInformation() calls in tclCompCmds.c. --- generic/tclCompCmds.c | 20 ++++----- tests/info.test | 118 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 127 insertions(+), 11 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 13318a3..28a3e64 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1651,7 +1651,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords - 1); + LineInformation(parsePtr->numWords - 1); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -1992,7 +1992,7 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords-1); + LineInformation(parsePtr->numWords-1); CompileBody(envPtr, tokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -2268,7 +2268,7 @@ TclCompileForCmd( * Inline compile the initial command. */ - SetLineInformation(1); + LineInformation(1); CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); @@ -2292,7 +2292,7 @@ TclCompileForCmd( bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - SetLineInformation(4); + LineInformation(4); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); TclEmitOpcode(INST_POP, envPtr); @@ -2306,7 +2306,7 @@ TclCompileForCmd( nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - SetLineInformation(3); + LineInformation(3); CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); TclEmitOpcode(INST_POP, envPtr); @@ -2325,7 +2325,7 @@ TclCompileForCmd( testCodeOffset += 3; } - SetLineInformation(2); + LineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; @@ -2464,7 +2464,7 @@ CompileEachloopCmd( Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex; + int jumpBackDist, jumpBackOffset, infoIndex, range; int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; DefineLineInformation; /* TIP #280 */ @@ -2504,8 +2504,6 @@ CompileEachloopCmd( return TCL_ERROR; } - bodyIndex = i-1; - /* * Allocate storage for the varcList and varvList arrays if necessary. */ @@ -2646,7 +2644,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - SetLineInformation(i); + LineInformation(i); CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); @@ -2684,7 +2682,7 @@ CompileEachloopCmd( * Inline compile the loop body. */ - SetLineInformation(bodyIndex); + LineInformation(numWords - 1); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); diff --git a/tests/info.test b/tests/info.test index ba31159..98bb724 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1991,6 +1991,124 @@ test info-33.5 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {a b} + dict update d x y {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.6 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1998 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {} + dict with d {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.7 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2013 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {set res [info frame 0]} + {1} {} {break} + } + return $res +} +test info-33.8 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2027 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} {} + {set res [info frame 0]; break} + } + return $res +} +test info-33.9 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2043 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} + {return [info frame 0]} + {} + } +} +test info-33.10 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2058 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} + {[return [info frame 0]]} + {} {} + } +} +test info-33.11 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2073 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x + } [return [info frame 0]] {} +} +test info-33.12 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2088 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x y + {set res [info frame 0]} + } + return $res +} +test info-33.13 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From 9d91a3db0b4c6c9a78f6be985bb2ed3dcd7b9573 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 19:43:56 +0000 Subject: Add tests for SetLineInformation() calls in tclCompCmdsGR.c. --- generic/tclCompCmdsGR.c | 8 ++++---- tests/info.test | 53 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index cc3f694..32514ab 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -222,7 +222,7 @@ TclCompileIfCmd( compileScripts = 0; } } else { - SetLineInformation(wordIdx); + LineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { @@ -345,7 +345,7 @@ TclCompileIfCmd( * Compile the else command body. */ - SetLineInformation(wordIdx); + LineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } @@ -474,7 +474,7 @@ TclCompileIncrCmd( PushLiteral(envPtr, word, numBytes); } } else { - SetLineInformation(2); + LineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); } } else { /* No incr amount given so use 1. */ @@ -701,7 +701,7 @@ TclCompileInfoLevelCmd( * list of arguments. */ - SetLineInformation(1); + LineInformation(1); CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); } diff --git a/tests/info.test b/tests/info.test index 98bb724..98f6ea7 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2109,6 +2109,59 @@ test info-33.13 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if {*}{ + {[return [info frame 0]]} + {} + } +} +test info-33.14 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2115 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if 0 {*}{ + {} else + {return [info frame 0]} + } +} +test info-33.15 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2130 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + incr {*}{ + x + } [return [info frame 0]] +} +test info-33.16 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2144 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + info level {*}{ + } [return [info frame 0]] +} +test info-33.16 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From 75bc23d59cf4ad60a7f0e10ad939564c9bfb4ec3 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 20:33:45 +0000 Subject: Add tests for SetLineInformation() calls in tclCompCmdsSZ.c as well as some obvious refactoring improvements. --- generic/tclCompCmdsSZ.c | 66 ++++++----------- tests/info.test | 186 +++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 206 insertions(+), 46 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 34c24f9..d5208e6 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -40,17 +40,14 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); static void IssueSwitchChainedTests(Tcl_Interp *interp, - CompileEnv *envPtr, ExtCmdLoc *mapPtr, - int eclIndex, int mode, int noCase, - int valueIndex, Tcl_Token *valueTokenPtr, - int numWords, Tcl_Token **bodyToken, - int *bodyLines, int **bodyNext); -static void IssueSwitchJumpTable(Tcl_Interp *interp, - CompileEnv *envPtr, ExtCmdLoc *mapPtr, - int eclIndex, int valueIndex, - Tcl_Token *valueTokenPtr, int numWords, + CompileEnv *envPtr, int mode, int noCase, + int valueIndex, int numWords, Tcl_Token **bodyToken, int *bodyLines, - int **bodyContLines); + int **bodyNext); +static void IssueSwitchJumpTable(Tcl_Interp *interp, + CompileEnv *envPtr, int valueIndex, + int numWords, Tcl_Token **bodyToken, + int *bodyLines, int **bodyContLines); static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, @@ -89,7 +86,7 @@ const AuxDataType tclJumptableInfoType = { #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define BODY(token,index) \ - SetLineInformation((index));CompileBody(envPtr,(token),interp) + LineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ PushStringLiteral(envPtr, str) #define JUMP4(name,var) \ @@ -436,7 +433,7 @@ TclCompileStringMatchCmd( } PushLiteral(envPtr, str, length); } else { - SetLineInformation(i+1+nocase); + LineInformation(i+1+nocase); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); @@ -486,7 +483,7 @@ TclCompileStringLenCmd( len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { - SetLineInformation(1); + LineInformation(1); CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_STR_LEN, envPtr); } @@ -1286,13 +1283,16 @@ TclCompileSwitchCmd( * but it handles the most common case well enough. */ + /* Both methods push the value to match against onto the stack. */ + LineInformation(valueIndex); + CompileTokens(envPtr, valueTokenPtr, interp); + if (mode == Switch_Exact) { - IssueSwitchJumpTable(interp, envPtr, mapPtr, eclIndex, valueIndex, - valueTokenPtr, numWords, bodyToken, bodyLines, bodyContLines); + IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken, + bodyLines, bodyContLines); } else { - IssueSwitchChainedTests(interp, envPtr, mapPtr, eclIndex, mode,noCase, - valueIndex, valueTokenPtr, numWords, bodyToken, bodyLines, - bodyContLines); + IssueSwitchChainedTests(interp, envPtr, mode, noCase, valueIndex, + numWords, bodyToken, bodyLines, bodyContLines); } result = TCL_OK; @@ -1330,13 +1330,9 @@ static void IssueSwitchChainedTests( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - ExtCmdLoc *mapPtr, /* For mapping tokens to their source code - * location. */ - int eclIndex, int mode, /* Exact, Glob or Regexp */ int noCase, /* Case-insensitivity flag. */ int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ @@ -1361,13 +1357,6 @@ IssueSwitchChainedTests( int i; /* - * First, we push the value we're matching against on the stack. - */ - - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); - - /* * Generate a test for each arm. */ @@ -1592,11 +1581,7 @@ static void IssueSwitchJumpTable( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - ExtCmdLoc *mapPtr, /* For mapping tokens to their source code - * location. */ - int eclIndex, int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ @@ -1612,13 +1597,6 @@ IssueSwitchJumpTable( Tcl_HashEntry *hPtr; /* - * First, we push the value we're matching against on the stack. - */ - - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); - - /* * Compile the switch by using a jump table, which is basically a * hashtable that maps from literal values to match against to the offset * (relative to the INST_JUMP_TABLE instruction) to jump to. The jump @@ -2048,8 +2026,7 @@ TclCompileTryCmd( */ DefineLineInformation; /* TIP #280 */ - SetLineInformation(1); - CompileBody(envPtr, bodyToken, interp); + BODY(bodyToken, 1); return TCL_OK; } @@ -3028,13 +3005,12 @@ TclCompileWhileCmd( * Compile the loop body. */ - SetLineInformation(2); bodyCodeOffset = ExceptionRangeStarts(envPtr, range); if (!loopMayEnd) { envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; } - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, 2); ExceptionRangeEnds(envPtr, range); OP( POP); @@ -3050,7 +3026,7 @@ TclCompileWhileCmd( bodyCodeOffset += 3; testCodeOffset += 3; } - SetLineInformation(1); + LineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; diff --git a/tests/info.test b/tests/info.test index 98f6ea7..a68fb43 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2155,13 +2155,197 @@ proc foo::bar {} { info level {*}{ } [return [info frame 0]] } -test info-33.16 {{*}, literal, simple, bytecompiled} -body { +test info-33.17 {{*}, literal, simple, bytecompiled} -body { reduce [foo::bar] } -cleanup { namespace delete foo } -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + } [return [info frame 0]] {} +} +test info-33.18 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2168 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + {} + } [return [info frame 0]] +} +test info-33.19 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2181 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string length {*}{ + } [return [info frame 0]] +} +test info-33.20 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2193 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while {*}{ + {[return [info frame 0]]} + } {} +} +test info-33.21 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2205 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + switch -- {*}{ + } [return [info frame 0]] {*}{ + } x y +} +test info-33.22 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2218 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.23 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2231 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } finally {} + return $res +} +test info-33.24 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2245 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} + return $res +} +test info-33.25 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2259 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} finally {} + return $res +} +test info-33.26 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2273 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while 1 {*}{ + {return [info frame 0]} + } +} +test info-33.27 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2287 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.28 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2300 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.29 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2313 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } +} +test info-33.30 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2326 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } finally {} +} +test info-33.31 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From 6f4f29670680e5ace35ab03d96c112fde1e45ff6 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 03:48:40 +0000 Subject: Add tests for the SetLineInformation() calls in tclEnsemble.c, and fix the bugs around those calls exposed by the tests. --- generic/tclEnsemble.c | 9 +++------ tests/info.test | 25 +++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 6 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index d654bbf..794a059 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3168,6 +3168,7 @@ CompileToInvokedCommand( bytes = Tcl_GetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* TODO: Check about registering Cmd Literals here */ int literal = TclRegisterNewLiteral(envPtr, tokPtr[1].start, tokPtr[1].size); @@ -3179,9 +3180,7 @@ CompileToInvokedCommand( } TclEmitPush(literal, envPtr); } else { - if (envPtr->clNext) { - SetLineInformation(i); - } + LineInformation(i); CompileTokens(envPtr, tokPtr, interp); } tokPtr = TokenAfter(tokPtr); @@ -3255,12 +3254,10 @@ CompileBasicNArgCommand( tokenPtr = TokenAfter(parsePtr->tokenPtr); for (i=1 ; inumWords ; i++) { - if (envPtr->clNext) { - SetLineInformation(i); - } if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); } else { + LineInformation(i); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); diff --git a/tests/info.test b/tests/info.test index a68fb43..afdaaee 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2346,6 +2346,31 @@ test info-33.31 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + binary format {*}{ + } [return [info frame 0]] +} +test info-33.32 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2352 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set format format + binary $format {*}{ + } [return [info frame 0]] +} +test info-33.33 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From f0992177e479b4444b46592c2f5fc1ccfa1dac71 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 04:00:57 +0000 Subject: Revert the revised macros used in developing the new tests. --- generic/tclCompCmds.c | 20 ++++++++++---------- generic/tclCompCmdsGR.c | 10 +++++----- generic/tclCompCmdsSZ.c | 12 ++++++------ generic/tclCompile.h | 5 +---- generic/tclEnsemble.c | 4 ++-- 5 files changed, 24 insertions(+), 27 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 28a3e64..a56727d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -610,7 +610,7 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - LineInformation(1); + SetLineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -1467,7 +1467,7 @@ CompileDictEachCmd( * Compile the loop body itself. It should be stack-neutral. */ - LineInformation(3); + SetLineInformation(3); CompileBody(envPtr, bodyTokenPtr, interp); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); @@ -1651,7 +1651,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - LineInformation(parsePtr->numWords - 1); + SetLineInformation(parsePtr->numWords - 1); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -1992,7 +1992,7 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - LineInformation(parsePtr->numWords-1); + SetLineInformation(parsePtr->numWords-1); CompileBody(envPtr, tokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -2268,7 +2268,7 @@ TclCompileForCmd( * Inline compile the initial command. */ - LineInformation(1); + SetLineInformation(1); CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); @@ -2292,7 +2292,7 @@ TclCompileForCmd( bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - LineInformation(4); + SetLineInformation(4); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); TclEmitOpcode(INST_POP, envPtr); @@ -2306,7 +2306,7 @@ TclCompileForCmd( nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - LineInformation(3); + SetLineInformation(3); CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); TclEmitOpcode(INST_POP, envPtr); @@ -2325,7 +2325,7 @@ TclCompileForCmd( testCodeOffset += 3; } - LineInformation(2); + SetLineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; @@ -2644,7 +2644,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - LineInformation(i); + SetLineInformation(i); CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); @@ -2682,7 +2682,7 @@ CompileEachloopCmd( * Inline compile the loop body. */ - LineInformation(numWords - 1); + SetLineInformation(numWords - 1); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 32514ab..f7c15e6 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -222,7 +222,7 @@ TclCompileIfCmd( compileScripts = 0; } } else { - LineInformation(wordIdx); + SetLineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { @@ -264,7 +264,7 @@ TclCompileIfCmd( */ if (compileScripts) { - LineInformation(wordIdx); + SetLineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } @@ -345,7 +345,7 @@ TclCompileIfCmd( * Compile the else command body. */ - LineInformation(wordIdx); + SetLineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } @@ -474,7 +474,7 @@ TclCompileIncrCmd( PushLiteral(envPtr, word, numBytes); } } else { - LineInformation(2); + SetLineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); } } else { /* No incr amount given so use 1. */ @@ -701,7 +701,7 @@ TclCompileInfoLevelCmd( * list of arguments. */ - LineInformation(1); + SetLineInformation(1); CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d5208e6..0497e8a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -86,7 +86,7 @@ const AuxDataType tclJumptableInfoType = { #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define BODY(token,index) \ - LineInformation((index));CompileBody(envPtr,(token),interp) + SetLineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ PushStringLiteral(envPtr, str) #define JUMP4(name,var) \ @@ -433,7 +433,7 @@ TclCompileStringMatchCmd( } PushLiteral(envPtr, str, length); } else { - LineInformation(i+1+nocase); + SetLineInformation(i+1+nocase); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); @@ -483,7 +483,7 @@ TclCompileStringLenCmd( len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { - LineInformation(1); + SetLineInformation(1); CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_STR_LEN, envPtr); } @@ -722,7 +722,7 @@ TclCompileSubstCmd( return TCL_ERROR; } - LineInformation(numArgs); + SetLineInformation(numArgs); TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); @@ -1284,7 +1284,7 @@ TclCompileSwitchCmd( */ /* Both methods push the value to match against onto the stack. */ - LineInformation(valueIndex); + SetLineInformation(valueIndex); CompileTokens(envPtr, valueTokenPtr, interp); if (mode == Switch_Exact) { @@ -3026,7 +3026,7 @@ TclCompileWhileCmd( bodyCodeOffset += 3; testCodeOffset += 3; } - LineInformation(1); + SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5043f65..9af4911 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1537,13 +1537,10 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 -#define LineInformation(word) \ +#define SetLineInformation(word) \ envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] -#define SetLineInformation(word) - - #define PushVarNameWord(i,v,e,f,l,sc,word) \ TclPushVarName(i,v,e,f,l,sc, \ mapPtr->loc[eclIndex].line[(word)], \ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 794a059..0bb7cb6 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3180,7 +3180,7 @@ CompileToInvokedCommand( } TclEmitPush(literal, envPtr); } else { - LineInformation(i); + SetLineInformation(i); CompileTokens(envPtr, tokPtr, interp); } tokPtr = TokenAfter(tokPtr); @@ -3257,7 +3257,7 @@ CompileBasicNArgCommand( if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); } else { - LineInformation(i); + SetLineInformation(i); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); -- cgit v0.12 From d061b314608a3e053255b383590ad08040352ed2 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 17:06:35 +0000 Subject: Have TclMakeEnsemble() set ENSEMBLE_COMPILE at creation, not as a separate epoch-bumping step. --- generic/tclEnsemble.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 0bb7cb6..680ab45d 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1527,6 +1527,14 @@ TclMakeEnsemble( cmdName = nameParts[nameCount - 1]; } } + + /* + * Switch on compilation always for core ensembles now that we can do + * nice bytecode things with them. Do it now. Waiting until later will + * just cause pointless epoch bumps. + */ + + ensembleFlags |= ENSEMBLE_COMPILE; ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags); /* @@ -1578,14 +1586,6 @@ TclMakeEnsemble( } } Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); - - /* - * Switch on compilation always for core ensembles now that we can do - * nice bytecode things with them. - */ - - Tcl_SetEnsembleFlags(interp, ensemble, - ensembleFlags | ENSEMBLE_COMPILE); } Tcl_DStringFree(&buf); -- cgit v0.12 From f302557ad523241b8da238efc187df31149d5d6a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 23:19:14 +0000 Subject: Revise the CompileWord() and PushVarNameWord() macros to make explicit the SetLineInformation() that's in each of them. --- generic/tclCompCmds.c | 9 +-------- generic/tclCompile.h | 16 ++++++---------- 2 files changed, 7 insertions(+), 18 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a56727d..0a1a739 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3164,10 +3164,7 @@ TclPushVarName( CompileEnv *envPtr, /* Holds resulting instructions. */ int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ int *localIndexPtr, /* Must not be NULL. */ - int *isScalarPtr, /* Must not be NULL. */ - int line, /* Line the token starts on. */ - int *clNext) /* Reference to offset of next hidden cont. - * line. */ + int *isScalarPtr) /* Must not be NULL. */ { register const char *p; const char *name, *elName; @@ -3347,8 +3344,6 @@ TclPushVarName( if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { if (elNameChars) { - envPtr->line = line; - envPtr->clNext = clNext; TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { @@ -3360,8 +3355,6 @@ TclPushVarName( * The var name isn't simple: compile and push it. */ - envPtr->line = line; - envPtr->clNext = clNext; CompileTokens(envPtr, varTokenPtr, interp); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9af4911..a4ebd96 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1074,7 +1074,7 @@ MODULE_SCOPE void TclPrintSource(FILE *outFile, MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, - int *isScalarPtr, int line, int *clNext); + int *isScalarPtr); MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, char *bytes, int length, int flags); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -1515,13 +1515,10 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #define CompileWord(envPtr, tokenPtr, interp, word) \ if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ - (tokenPtr)[1].size), (envPtr)); \ + PushLiteral((envPtr), (tokenPtr)[1].start, (tokenPtr)[1].size); \ } else { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); \ + SetLineInformation((word)); \ + CompileTokens((envPtr), (tokenPtr), (interp)); \ } /* @@ -1542,9 +1539,8 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] #define PushVarNameWord(i,v,e,f,l,sc,word) \ - TclPushVarName(i,v,e,f,l,sc, \ - mapPtr->loc[eclIndex].line[(word)], \ - mapPtr->loc[eclIndex].next[(word)]) + SetLineInformation(word); \ + TclPushVarName(i,v,e,f,l,sc) /* * Often want to issue one of two versions of an instruction based on whether -- cgit v0.12 From 451ab6927c1c2a1b56c335ce110de9c655a2069e Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 12 Jul 2013 16:25:51 +0000 Subject: Tests demonstrating the need for the last two SetLineInformation() calls. --- tests/info.test | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/tests/info.test b/tests/info.test index afdaaee..3057dd2 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2371,6 +2371,31 @@ test info-33.33 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append x {*}{ + } [return [info frame 0]] +} +test info-33.34 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append {*}{ + } x([return [info frame 0]]) {*}{ + } a +} +test info-33.35 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From 740d1811bca3d4f0ba8ca8b79eaa1edec3292d1b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 12 Jul 2013 18:44:15 +0000 Subject: Global replace: CompileBody() -> BODY(). --- generic/tclCompCmds.c | 25 +++++++++---------------- generic/tclCompCmdsGR.c | 6 ++---- generic/tclCompCmdsSZ.c | 4 +--- generic/tclCompile.h | 14 +++++++------- 4 files changed, 19 insertions(+), 30 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0a1a739..561d816 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -610,12 +610,12 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - SetLineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, cmdTokenPtr, interp); + BODY(cmdTokenPtr, 1); } else { + SetLineInformation(1); CompileTokens(envPtr, cmdTokenPtr, interp); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -1467,8 +1467,7 @@ CompileDictEachCmd( * Compile the loop body itself. It should be stack-neutral. */ - SetLineInformation(3); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, 3); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); @@ -1651,8 +1650,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords - 1); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -1992,8 +1990,7 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords-1); - CompileBody(envPtr, tokenPtr, interp); + BODY(tokenPtr, parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -2268,8 +2265,7 @@ TclCompileForCmd( * Inline compile the initial command. */ - SetLineInformation(1); - CompileBody(envPtr, startTokenPtr, interp); + BODY(startTokenPtr, 1); TclEmitOpcode(INST_POP, envPtr); /* @@ -2292,8 +2288,7 @@ TclCompileForCmd( bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - SetLineInformation(4); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, 4); ExceptionRangeEnds(envPtr, bodyRange); TclEmitOpcode(INST_POP, envPtr); @@ -2306,8 +2301,7 @@ TclCompileForCmd( nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - SetLineInformation(3); - CompileBody(envPtr, nextTokenPtr, interp); + BODY(nextTokenPtr, 3); ExceptionRangeEnds(envPtr, nextRange); TclEmitOpcode(INST_POP, envPtr); @@ -2682,9 +2676,8 @@ CompileEachloopCmd( * Inline compile the loop body. */ - SetLineInformation(numWords - 1); ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, numWords - 1); ExceptionRangeEnds(envPtr, range); if (collect == TCL_EACH_COLLECT) { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index f7c15e6..0572cd3 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -264,8 +264,7 @@ TclCompileIfCmd( */ if (compileScripts) { - SetLineInformation(wordIdx); - CompileBody(envPtr, tokenPtr, interp); + BODY(tokenPtr, wordIdx); } if (realCond) { @@ -345,8 +344,7 @@ TclCompileIfCmd( * Compile the else command body. */ - SetLineInformation(wordIdx); - CompileBody(envPtr, tokenPtr, interp); + BODY(tokenPtr, wordIdx); } /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0497e8a..19e636d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -85,8 +85,6 @@ const AuxDataType tclJumptableInfoType = { TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) -#define BODY(token,index) \ - SetLineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ PushStringLiteral(envPtr, str) #define JUMP4(name,var) \ @@ -1499,7 +1497,7 @@ IssueSwitchChainedTests( } /* - * Now do the actual compilation. Note that we do not use CompileBody + * Now do the actual compilation. Note that we do not use BODY() * because we may have synthesized the tokens in a non-standard * pattern. */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a4ebd96..cf8475d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1407,16 +1407,16 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) /* - * Convenience macro for use when compiling bodies of commands. The ANSI C - * "prototype" for this macro is: + * Convenience macros for use when compiling bodies of commands. The ANSI C + * "prototype" for these macros are: * - * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp); + * static void BODY(Tcl_Token *tokenPtr, int word); */ -#define CompileBody(envPtr, tokenPtr, interp) \ - TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)) +#define BODY(tokenPtr, word) \ + SetLineInformation((word)); \ + TclCompileCmdWord(interp, (tokenPtr)+1, (tokenPtr)->numComponents, \ + envPtr) /* * Convenience macro for use when compiling tokens to be pushed. The ANSI C -- cgit v0.12 From 774c4023655381f0f5d722f19ae8bed785ebff58 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Jul 2013 17:07:51 +0000 Subject: Prefer CompileWord() over CompileTokens() when possible. --- generic/tclCompCmds.c | 3 +-- generic/tclCompCmdsGR.c | 3 +-- generic/tclCompCmdsSZ.c | 3 +-- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 561d816..37ce335 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2638,8 +2638,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - SetLineInformation(i); - CompileTokens(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp, i); tempVar = (firstValueTemp + loopIndex); Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); TclEmitOpcode( INST_POP, envPtr); diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 0572cd3..2c71dc5 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -699,8 +699,7 @@ TclCompileInfoLevelCmd( * list of arguments. */ - SetLineInformation(1); - CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); + CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1); TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); } return TCL_OK; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 19e636d..3a91c83 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1282,8 +1282,7 @@ TclCompileSwitchCmd( */ /* Both methods push the value to match against onto the stack. */ - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); + CompileWord(envPtr, valueTokenPtr, interp, valueIndex); if (mode == Switch_Exact) { IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken, -- cgit v0.12 From d860a2c3a49e049350838d0ee2e259e7f8b4c3e6 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Jul 2013 20:16:11 +0000 Subject: Build CompileBasicNArgCommand on top of TclCompileInvocation. --- generic/tclBasic.c | 22 ++++++++++++++++++---- generic/tclCompile.c | 6 +++--- generic/tclCompile.h | 3 +++ generic/tclEnsemble.c | 10 ++++++++++ 4 files changed, 34 insertions(+), 7 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b2a505a..963b53a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5633,6 +5633,24 @@ TclArgumentBCEnter( CFWordBC *lastPtr = NULL; /* + * ePtr->nline is the number of words originally parsed. + * + * objc is the number of elements getting invoked. + * + * If they are not the same, we arrived here by compiling an + * ensemble dispatch. Ensemble subcommands that lead to script + * evaluation are not supposed to get compiled, because a command + * such as [info level] in the script can expose some of the dispatch + * shenanigans. This means that we don't have to tend to the + * housekeeping, and can escape now. + */ + + if (ePtr->nline != objc) { + return; + } + + /* + * Having disposed of the ensemble cases, we can state... * A few truths ... * (1) ePtr->nline == objc * (2) (ePtr->line[word] < 0) => !literal, for all words @@ -5642,10 +5660,6 @@ TclArgumentBCEnter( * have to save them at compile time. */ - if (ePtr->nline != objc) { - Tcl_Panic ("TIP 280 data structure inconsistency"); - } - for (word = 1; word < objc; word++) { if (ePtr->line[word] >= 0) { int isnew; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5f4acff..a2c7131 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1777,8 +1777,8 @@ CompileCmdLiteral( TclEmitPush(cmdLitIdx, envPtr); } -static void -CompileInvocation( +void +TclCompileInvocation( Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, @@ -2095,7 +2095,7 @@ CompileCommandTokens( CompileExpanded(interp, parsePtr->tokenPtr, cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } else { - CompileInvocation(interp, parsePtr->tokenPtr, + TclCompileInvocation(interp, parsePtr->tokenPtr, cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 0bcd84e..b94bd93 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1003,6 +1003,9 @@ MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr); +MODULE_SCOPE void 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); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 680ab45d..9b6ca92 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3229,6 +3229,15 @@ CompileBasicNArgCommand( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { +#if 1 + Tcl_Obj *objPtr = Tcl_NewObj(); + + Tcl_IncrRefCount(objPtr); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); + TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, + parsePtr->numWords, envPtr); + Tcl_DecrRefCount(objPtr); +#else Tcl_Token *tokenPtr; Tcl_Obj *objPtr; char *bytes; @@ -3272,6 +3281,7 @@ CompileBasicNArgCommand( } else { TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); } +#endif return TCL_OK; } -- cgit v0.12 From d848f30c4545739e202b7df265b942a79b284fba Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 14:07:41 +0000 Subject: Eliminate the litInfo table and all the code tending to its care and feeding. The pc -> command index mapping function it provided can be achieved using other data already in the ByteCode struct. --- generic/tclBasic.c | 134 +++++++++++++++++++++++++-------------------------- generic/tclCompile.c | 43 ----------------- generic/tclCompile.h | 8 --- generic/tclExecute.c | 44 ++++++++++++----- generic/tclInt.h | 2 +- 5 files changed, 97 insertions(+), 134 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 963b53a..bd4f157 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1609,8 +1609,6 @@ DeleteInterpProc( ckfree(eclPtr->loc); } - Tcl_DeleteHashTable(&eclPtr->litInfo); - ckfree(eclPtr); Tcl_DeleteHashEntry(hPtr); } @@ -5614,90 +5612,88 @@ TclArgumentBCEnter( int objc, void *codePtr, CmdFrame *cfPtr, + int cmd, int pc) { + ExtCmdLoc *eclPtr; + int word; + ECL *ePtr; + CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); - ExtCmdLoc *eclPtr; if (!hePtr) { return; } eclPtr = Tcl_GetHashValue(hePtr); - hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); - if (hePtr) { - int word; - int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); - ECL *ePtr = &eclPtr->loc[cmd]; - CFWordBC *lastPtr = NULL; + ePtr = &eclPtr->loc[cmd]; - /* - * ePtr->nline is the number of words originally parsed. - * - * objc is the number of elements getting invoked. - * - * If they are not the same, we arrived here by compiling an - * ensemble dispatch. Ensemble subcommands that lead to script - * evaluation are not supposed to get compiled, because a command - * such as [info level] in the script can expose some of the dispatch - * shenanigans. This means that we don't have to tend to the - * housekeeping, and can escape now. - */ + /* + * ePtr->nline is the number of words originally parsed. + * + * objc is the number of elements getting invoked. + * + * If they are not the same, we arrived here by compiling an + * ensemble dispatch. Ensemble subcommands that lead to script + * evaluation are not supposed to get compiled, because a command + * such as [info level] in the script can expose some of the dispatch + * shenanigans. This means that we don't have to tend to the + * housekeeping, and can escape now. + */ - if (ePtr->nline != objc) { - return; - } + if (ePtr->nline != objc) { + return; + } - /* - * Having disposed of the ensemble cases, we can state... - * A few truths ... - * (1) ePtr->nline == objc - * (2) (ePtr->line[word] < 0) => !literal, for all words - * (3) (word == 0) => !literal - * - * Item (2) is why we can use objv to get the literals, and do not - * have to save them at compile time. - */ + /* + * Having disposed of the ensemble cases, we can state... + * A few truths ... + * (1) ePtr->nline == objc + * (2) (ePtr->line[word] < 0) => !literal, for all words + * (3) (word == 0) => !literal + * + * Item (2) is why we can use objv to get the literals, and do not + * have to save them at compile time. + */ - for (word = 1; word < objc; word++) { - if (ePtr->line[word] >= 0) { - int isnew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, - objv[word], &isnew); - CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); - - cfwPtr->framePtr = cfPtr; - cfwPtr->obj = objv[word]; - cfwPtr->pc = pc; - cfwPtr->word = word; - cfwPtr->nextPtr = lastPtr; - lastPtr = cfwPtr; - - if (isnew) { - /* - * The word is not on the stack yet, remember the current - * location and initialize references. - */ - - cfwPtr->prevPtr = NULL; - } else { - /* - * The object is already on the stack, however it may have - * a different location now (literal sharing may map - * multiple location to a single Tcl_Obj*. Save the old - * information in the new structure. - */ - - cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); - } + for (word = 1; word < objc; word++) { + if (ePtr->line[word] >= 0) { + int isnew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, + objv[word], &isnew); + CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); - Tcl_SetHashValue(hPtr, cfwPtr); + cfwPtr->framePtr = cfPtr; + cfwPtr->obj = objv[word]; + cfwPtr->pc = pc; + cfwPtr->word = word; + cfwPtr->nextPtr = lastPtr; + lastPtr = cfwPtr; + + if (isnew) { + /* + * The word is not on the stack yet, remember the current + * location and initialize references. + */ + + cfwPtr->prevPtr = NULL; + } else { + /* + * The object is already on the stack, however it may have + * a different location now (literal sharing may map + * multiple location to a single Tcl_Obj*. Save the old + * information in the new structure. + */ + + cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); } - } /* for */ - cfPtr->litarg = lastPtr; - } /* if */ + Tcl_SetHashValue(hPtr, cfwPtr); + } + } /* for */ + + cfPtr->litarg = lastPtr; } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a2c7131..7e0be76 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1296,8 +1296,6 @@ ReleaseCmdWordData( ckfree((char *) eclPtr->loc); } - Tcl_DeleteHashTable (&eclPtr->litInfo); - ckfree((char *) eclPtr); } @@ -1382,7 +1380,6 @@ TclInitCompileEnv( envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; envPtr->extCmdMapPtr->path = NULL; - Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS); if ((invoker == NULL) || (invoker->type == TCL_LOCATION_EVAL_LIST)) { /* @@ -1814,12 +1811,6 @@ TclCompileInvocation( TclEmitPush(objIdx, envPtr); } - /* - * Save PC -> command map for the TclArgumentBC* functions. - */ - - mapPtr->loc[eclIndex].invokePc = envPtr->codeNext - envPtr->codeStart; - if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); } else { @@ -2001,7 +1992,6 @@ CompileCmdCompileProc( mapPtr->nuloc--; ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; - mapPtr->loc[mapPtr->nuloc].invokePc = -1; } SetLineInformation(0); @@ -3325,17 +3315,6 @@ TclInitByteCodeObj( * byte code object (internal rep), for use with the bc compiler. */ - for (i = 0; i < envPtr->extCmdMapPtr->nuloc; i++) { - int isnew, pc = envPtr->extCmdMapPtr->loc[i].invokePc; - - if (pc < 0) { - continue; - } - - Tcl_SetHashValue(Tcl_CreateHashEntry(&envPtr->extCmdMapPtr->litInfo, - INT2PTR(pc), &isnew), INT2PTR(i)); - } - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr, &isNew), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; @@ -3706,7 +3685,6 @@ EnterCmdWordData( ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; - ePtr->invokePc = -1; ePtr->line = ckalloc(numWords * sizeof(int)); ePtr->next = ckalloc(numWords * sizeof(int *)); ePtr->nline = numWords; @@ -4477,27 +4455,6 @@ TclFixupForwardJump( } } - /* - * TIP #280: Adjust the mapping from PC values to the per-command - * information about arguments and their line numbers. - * - * Note: We cannot simply remove an out-of-date entry and then reinsert - * with the proper PC, because then we might overwrite another entry which - * was at that location. Therefore we pull (copy + delete) all effected - * entries (beyond the fixed PC) into an array, update them there, and at - * last reinsert them all. - */ - - { - ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; - for (k = eclPtr->nuloc - 1; k >= 0; k--) { - if (eclPtr->loc[k].invokePc < (jumpFixupPtr->codeOffset + 2)) { - continue; - } - eclPtr->loc[k].invokePc += 3; - } - } - return 1; /* the jump was grown */ } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b94bd93..f70f8f7 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -175,7 +175,6 @@ typedef struct CmdLocation { typedef struct ECL { int srcOffset; /* Command location to find the entry. */ - int invokePc; int nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ @@ -194,13 +193,6 @@ typedef struct ExtCmdLoc { ECL *loc; /* Command word locations (lines). */ int nloc; /* Number of allocated entries in 'loc'. */ int nuloc; /* Number of used entries in 'loc'. */ - Tcl_HashTable litInfo; /* Indexed by bytecode 'PC', to have the - * information accessible per command and - * argument, not per whole bytecode. Value is - * index of command in 'loc', giving us the - * literals to associate with line information - * as command argument, see - * TclArgumentBCEnter() */ } ExtCmdLoc; /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 37bf072..f8ed667 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -721,7 +721,7 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int catchOnly, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, int *lengthPtr, - const unsigned char **pcBeg); + const unsigned char **pcBeg, int *cmdIdxPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, @@ -2431,8 +2431,11 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } pc++; @@ -2885,8 +2888,11 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } DECACHE_STACK_INFO(); @@ -3031,8 +3037,11 @@ TEBCresume( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = opnd; @@ -6967,7 +6976,7 @@ TEBCresume( if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { const unsigned char *pcBeg; - bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); + bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL); DECACHE_STACK_INFO(); TclLogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0, pcBeg, tosPtr); @@ -7149,7 +7158,7 @@ TEBCresume( } codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); opnd = TclGetUInt4AtPtr(pc+1); pc += (opnd-1); PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); @@ -8642,7 +8651,7 @@ ValidatePcAndStackTop( if (checkStack && ((stackTop < 0) || (stackTop > stackUpperBound))) { int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL); + const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", stackTop, relativePc, stackUpperBound); @@ -8756,7 +8765,7 @@ TclGetSrcInfoForCmd( ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, - codePtr, lenPtr, NULL); + codePtr, lenPtr, NULL, NULL); } void @@ -8768,7 +8777,7 @@ TclGetSrcInfoForPc( if (cfPtr->cmd.str.cmd == NULL) { cfPtr->cmd.str.cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->cmd.str.len, NULL); + &cfPtr->cmd.str.len, NULL, NULL); } if (cfPtr->cmd.str.cmd != NULL) { @@ -8828,9 +8837,12 @@ GetSrcInfoForPc( int *lengthPtr, /* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */ - const unsigned char **pcBeg)/* If non-NULL, the bytecode location + const unsigned char **pcBeg,/* If non-NULL, the bytecode location * where the current instruction starts. * If NULL; no pointer is stored. */ + int *cmdIdxPtr) /* If non-NULL, the location where the index + * of the command containing the pc should + * be stored. */ { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; @@ -8840,6 +8852,7 @@ GetSrcInfoForPc( int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + int bestCmdIdx = -1; if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { if (pcBeg != NULL) *pcBeg = NULL; @@ -8907,6 +8920,7 @@ GetSrcInfoForPc( bestDist = dist; bestSrcOffset = srcOffset; bestSrcLength = srcLen; + bestCmdIdx = i; } } } @@ -8936,6 +8950,10 @@ GetSrcInfoForPc( *lengthPtr = bestSrcLength; } + if (cmdIdxPtr != NULL) { + *cmdIdxPtr = bestCmdIdx; + } + return (codePtr->source + bestSrcOffset); } diff --git a/generic/tclInt.h b/generic/tclInt.h index b940225..da09366 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2828,7 +2828,7 @@ MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, - void *codePtr, CmdFrame *cfPtr, int pc); + void *codePtr, CmdFrame *cfPtr, int cmd, int pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, -- cgit v0.12 From 3f126895fb9a9135480b18a16d017dfa39d90f3f Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 14:52:33 +0000 Subject: Simplify arguments to TclContinuationsEnterDerived(). --- generic/tclCompile.c | 6 ++---- generic/tclEnsemble.c | 14 ++++++++------ 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7e0be76..bc7501a 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1805,8 +1805,7 @@ TclCompileInvocation( tokenPtr[1].start, tokenPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), - tokenPtr[1].start - envPtr->source, - mapPtr->loc[eclIndex].next[wordIdx]); + tokenPtr[1].start - envPtr->source, envPtr->clNext); } TclEmitPush(objIdx, envPtr); } @@ -1855,8 +1854,7 @@ CompileExpanded( tokenPtr[1].start, tokenPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), - tokenPtr[1].start - envPtr->source, - mapPtr->loc[eclIndex].next[wordIdx]); + tokenPtr[1].start - envPtr->source, envPtr->clNext); } TclEmitPush(objIdx, envPtr); } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 9b6ca92..864283b 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3163,12 +3163,16 @@ CompileToInvokedCommand( */ Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); - for (i=0,tokPtr=parsePtr->tokenPtr ; inumWords ; i++) { + for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; + i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { bytes = Tcl_GetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); - } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* TODO: Check about registering Cmd Literals here */ + continue; + } + + SetLineInformation(i); + if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { int literal = TclRegisterNewLiteral(envPtr, tokPtr[1].start, tokPtr[1].size); @@ -3176,14 +3180,12 @@ CompileToInvokedCommand( TclContinuationsEnterDerived( TclFetchLiteral(envPtr, literal), tokPtr[1].start - envPtr->source, - mapPtr->loc[eclIndex].next[i]); + envPtr->clNext); } TclEmitPush(literal, envPtr); } else { - SetLineInformation(i); CompileTokens(envPtr, tokPtr, interp); } - tokPtr = TokenAfter(tokPtr); } /* -- cgit v0.12 From c33f97005c30adcc8fbfafc81dc9d67913a4be43 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 17:21:12 +0000 Subject: Simplify the ensemble subcommand compile. There's no need to be crafting synthetic Tcl_Parse and copying tokens. Some pointer shifts will do. --- generic/tclCompile.c | 1 - generic/tclEnsemble.c | 70 +++++++++++---------------------------------------- 2 files changed, 15 insertions(+), 56 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index bc7501a..d82d728 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1992,7 +1992,6 @@ CompileCmdCompileProc( mapPtr->loc[mapPtr->nuloc].line = NULL; } - SetLineInformation(0); return TCL_ERROR; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 864283b..e4f96c0 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3029,12 +3029,6 @@ TclCompileEnsemble( return ourResult; } -/* - * How to compile a subcommand using its own command compiler. To do that, we - * have to perform some trickery to rewrite the arguments, as compilers *must* - * have parse tokens that refer to addresses in the original script. - */ - static int CompileToCompiledCommand( Tcl_Interp *interp, @@ -3043,10 +3037,8 @@ CompileToCompiledCommand( Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Parse synthetic; - Tcl_Token *tokenPtr; int result, i; - int savedNumCmds = envPtr->numCommands; + Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; DefineLineInformation; @@ -3055,47 +3047,17 @@ CompileToCompiledCommand( return TCL_ERROR; } - TclParseInit(interp, NULL, 0, &synthetic); - synthetic.numWords = parsePtr->numWords - depth + 1; - TclGrowParseTokenArray(&synthetic, 2); - synthetic.numTokens = 2; - - /* - * Now we have the space to work in, install something rewritten. The - * first word will "officially" be the bytes of the structured ensemble - * name. That's technically wrong, but nobody will care; we just need - * *something* here... - */ - - synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD; - synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[0].numComponents = 1; - synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT; - synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[1].numComponents = 0; - for (i=0,tokenPtr=parsePtr->tokenPtr ; istart - synthetic.tokenPtr[0].start) - + tokenPtr->size; - - synthetic.tokenPtr[0].size = sclen; - synthetic.tokenPtr[1].size = sclen; - tokenPtr = TokenAfter(tokenPtr); - } - /* - * Copy over the real argument tokens. + * Advance parsePtr->tokenPtr so that it points at the last subcommand. + * This will be wrong, but it will not matter, and it will put the + * tokens for the arguments in the right place without the needed to + * allocate a synthetic Tcl_Parse struct, or copy tokens around. */ - for (i=1; inumComponents + 1; - TclGrowParseTokenArray(&synthetic, toCopy); - memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, - sizeof(Tcl_Token) * toCopy); - synthetic.numTokens += toCopy; - tokenPtr = TokenAfter(tokenPtr); + for (i = 0; i < depth - 1; i++) { + parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr); } + parsePtr->numWords -= (depth - 1); /* * Shift the line information arrays to account for different word @@ -3109,7 +3071,7 @@ CompileToCompiledCommand( * Hand off compilation to the subcommand compiler. At last! */ - result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr); /* * Undo the shift. @@ -3118,22 +3080,20 @@ CompileToCompiledCommand( mapPtr->loc[eclIndex].line -= (depth - 1); mapPtr->loc[eclIndex].next -= (depth - 1); + parsePtr->numWords += (depth - 1); + parsePtr->tokenPtr = saveTokenPtr; + /* - * If our target fails to compile, revert the number of commands and the - * pointer to the place to issue the next instruction. [Bug 3600328] + * If our target failed to compile, revert any data from failed partial + * compiles. Note that envPtr->numCommands need not be checked because + * we avoid compiling subcommands that recursively call TclCompileScript(). */ if (result != TCL_OK) { - envPtr->numCommands = savedNumCmds; envPtr->currStackDepth = savedStackDepth; envPtr->codeNext = envPtr->codeStart + savedCodeNext; } - /* - * Clean up if necessary. - */ - - Tcl_FreeParse(&synthetic); return result; } -- cgit v0.12 From d383707870a66078dd83c9532e7dbcb1002e62ba Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 20:48:37 +0000 Subject: Streamline the housekeeping on the operands of INST_START_CMD. For example, do only incr on success, not incr on attempt + decr on error. --- generic/tclCompile.c | 81 +++++++++++++++++++++------------------------------- 1 file changed, 32 insertions(+), 49 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d82d728..6ac5fb9 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1885,47 +1885,41 @@ CompileCmdCompileProc( Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, - int startCodeOffset, CompileEnv *envPtr) { int savedNumCmds = envPtr->numCommands; int startStackDepth = envPtr->currStackDepth; - int update = 0; + int startCodeOffset = envPtr->codeNext - envPtr->codeStart; + int incrOffset = -1; DefineLineInformation; /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD - * in special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] + * Emit of the INST_START_CMD instruction is controlled by + * the value of envPtr->atCmdStart: * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. + * atCmdStart == 2 : We are not using the INST_START_CMD instruction. + * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. + * : We do not need to emit another. Instead we + * : increment the number of cmds started at it (except + * : for the special case at the start of a script.) + * atCmdStart == 0 : The last instruction was something else. We need + * : to emit INST_START_CMD here. */ - if (envPtr->atCmdStart == 1) { - if (startCodeOffset) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) - } - } else if (envPtr->atCmdStart == 0) { + switch (envPtr->atCmdStart) { + case 0: TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; + incrOffset = envPtr->codeNext - envPtr->codeStart; + TclEmitInt4(0, envPtr); + break; + case 1: + if (envPtr->codeNext > envPtr->codeStart) { + incrOffset = envPtr->codeNext - 4 - envPtr->codeStart; + } + break; + case 2: + /* Nothing to do */ + ; } if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { @@ -1947,30 +1941,20 @@ CompileCmdCompileProc( parsePtr->tokenPtr->start, diff); } #endif - if (update) { + if (incrOffset >= 0) { /* - * Fix the bytecode length. + * We successfully compiled a command. Increment the number + * of commands that start at the currently active INST_START_CMD. */ + unsigned char *incrPtr = envPtr->codeStart + incrOffset; + unsigned char *startPtr = incrPtr - 5; - unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; - unsigned fixLen = envPtr->codeNext - fixPtr + 1; - - TclStoreInt4AtPtr(fixLen, fixPtr); + TclIncrUInt4AtPtr(incrPtr, 1); + TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); } return TCL_OK; } - if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); - } - /* * Restore numCommands, codeNext, and currStackDepth to their * correct values, removing any commands compiled before the @@ -2069,8 +2053,7 @@ CompileCommandTokens( /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ if (cmdPtr) { - code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, - startCodeOffset, envPtr); + code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr); } if (code == TCL_ERROR) { -- cgit v0.12 From c2d6c48dd921e7120d626f1a85977ae130dd109e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Jul 2013 13:57:23 +0000 Subject: Factor out the call to a compileProc into one place used by both ensemble subcommand compiles and toplevel command compiles in TclCompileScript. --- generic/tclCompile.c | 48 ++++++++++++++---------------------------------- generic/tclCompile.h | 3 +++ generic/tclEnsemble.c | 28 +++++++++++++++++++++------- 3 files changed, 38 insertions(+), 41 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6ac5fb9..763e8f1 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1887,10 +1887,7 @@ CompileCmdCompileProc( Command *cmdPtr, CompileEnv *envPtr) { - int savedNumCmds = envPtr->numCommands; - int startStackDepth = envPtr->currStackDepth; - int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - int incrOffset = -1; + int unwind = 0, incrOffset = -1; DefineLineInformation; /* @@ -1908,6 +1905,7 @@ CompileCmdCompileProc( switch (envPtr->atCmdStart) { case 0: + unwind = tclInstructionTable[INST_START_CMD].numBytes; TclEmitInstInt4(INST_START_CMD, 0, envPtr); incrOffset = envPtr->codeNext - envPtr->codeStart; TclEmitInt4(0, envPtr); @@ -1922,25 +1920,7 @@ CompileCmdCompileProc( ; } - if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { - -#ifdef TCL_COMPILE_DEBUG - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ - - int diff = envPtr->currStackDepth - startStackDepth; - - if (diff != 1) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { if (incrOffset >= 0) { /* * We successfully compiled a command. Increment the number @@ -1950,21 +1930,15 @@ CompileCmdCompileProc( unsigned char *startPtr = incrPtr - 5; TclIncrUInt4AtPtr(incrPtr, 1); - TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); + if (unwind) { + /* We started the INST_START_CMD. Record the code length. */ + TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); + } } return TCL_OK; } - /* - * Restore numCommands, codeNext, and currStackDepth to their - * correct values, removing any commands compiled before the - * failure to produce bytecode got reported. - * [Bugs 705406, 735055, 3614102] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + startCodeOffset; - envPtr->currStackDepth = startStackDepth; + envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */ /* * Throw out any line information generated by the failed @@ -1976,6 +1950,12 @@ CompileCmdCompileProc( mapPtr->loc[mapPtr->nuloc].line = NULL; } + /* + * Reset the index of next command. + * Toss out any from failed nested partial compiles. + */ + envPtr->numCommands = mapPtr->nuloc; + return TCL_ERROR; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index f70f8f7..56315db 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -984,6 +984,9 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, *---------------------------------------------------------------- */ +MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, + Tcl_Parse *parsePtr, int depth, Command *cmdPtr, + CompileEnv *envPtr); MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index e4f96c0..bab63c9 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -35,9 +35,6 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); -static int CompileToCompiledCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int depth, Command *cmdPtr, - CompileEnv *envPtr); static void CompileToInvokedCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Obj *replacements, Command *cmdPtr, CompileEnv *envPtr); @@ -2994,8 +2991,8 @@ TclCompileEnsemble( */ invokeAnyway = 1; - if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr, - envPtr) == TCL_OK) { + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr, + envPtr)) { ourResult = TCL_OK; goto cleanup; } @@ -3029,8 +3026,8 @@ TclCompileEnsemble( return ourResult; } -static int -CompileToCompiledCommand( +int +TclAttemptCompileProc( Tcl_Interp *interp, Tcl_Parse *parsePtr, int depth, @@ -3092,6 +3089,23 @@ CompileToCompiledCommand( if (result != TCL_OK) { envPtr->currStackDepth = savedStackDepth; envPtr->codeNext = envPtr->codeStart + savedCodeNext; +#ifdef TCL_COMPILE_DEBUG + } else { + /* + * Confirm that the command compiler generated a single value on + * the stack as its result. This is only done in debugging mode, + * as it *should* be correct and normal users have no reasonable + * way to fix it anyway. + */ + + int diff = envPtr->currStackDepth - savedStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif } return result; -- cgit v0.12 From 81a1a91361cc615d3e9bf5b9016bd12cd258aa8d Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 18 Jul 2013 15:05:18 +0000 Subject: [Bug 1c17fbba5d] Fix -errorinfo from syntax errors so that the error is not obscured. Instead highlight it by making it the last character quoted. --- generic/tclAssembly.c | 15 ++++++++------- generic/tclBasic.c | 5 ++++- generic/tclCompile.c | 5 +---- tests/assemble.test | 3 +-- tests/misc.test | 7 +------ 5 files changed, 15 insertions(+), 20 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 62641e6..416ee10 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -985,8 +985,6 @@ TclAssembleCode( const char* instPtr = codePtr; /* Where to start looking for a line of code */ - int instLen; /* Length in bytes of the current line of - * code */ const char* nextPtr; /* Pointer to the end of the line of code */ int bytesLeft = codeLen; /* Number of bytes of source code remaining to * be parsed */ @@ -1000,10 +998,6 @@ TclAssembleCode( */ status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); - instLen = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + instLen - 1) { - --instLen; - } /* * Report errors in the parse. @@ -1012,7 +1006,7 @@ TclAssembleCode( if (status != TCL_OK) { if (flags & TCL_EVAL_DIRECT) { Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, - instLen); + parsePtr->term + 1 - parsePtr->commandStart); } FreeAssemblyEnv(assemEnvPtr); return TCL_ERROR; @@ -1032,6 +1026,13 @@ TclAssembleCode( */ if (parsePtr->numWords > 0) { + int instLen = parsePtr->commandSize; + /* Length in bytes of the current command */ + + if (parsePtr->term == parsePtr->commandStart + instLen - 1) { + --instLen; + } + /* * If tracing, show each line assembled as it happens. */ diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b2a505a..1d35034 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5084,7 +5084,9 @@ TclEvalEx( do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { code = TCL_ERROR; - goto error; + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + parsePtr->term + 1 - parsePtr->commandStart); + goto posterror; } /* @@ -5340,6 +5342,7 @@ TclEvalEx( Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, commandLength); } + posterror: iPtr->flags &= ~ERR_ALREADY_LOGGED; /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 633966e..6a2a318 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1790,10 +1790,7 @@ TclCompileScript( */ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - /* Drop the command terminator (";","]") if appropriate */ - (parsePtr->term == - parsePtr->commandStart + parsePtr->commandSize - 1)? - parsePtr->commandSize - 1 : parsePtr->commandSize); + parsePtr->term + 1 - parsePtr->commandStart); TclCompileSyntaxError(interp, envPtr); break; } diff --git a/tests/assemble.test b/tests/assemble.test index 7d4e5d1..b0487e6 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -175,8 +175,7 @@ test assemble-4.1 {syntax error} { -match glob -result {1 {extra characters after close-brace} {extra characters after close-brace while executing -"{}extra - " +"{}e" ("assemble" body, line 2)*}} } test assemble-4.2 {null command} { diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..d4ece74 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} { missing close-brace for variable name missing close-brace for variable name while executing -"set tst $a([winfo name $\{zz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a ..." +"set tst $a([winfo name $\{" (procedure "tstProc" line 4) invoked from within "tstProc"}] -- cgit v0.12 From 5e9e003379a72c3459d97b1931c3e8b8627541f8 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 18 Jul 2013 18:25:24 +0000 Subject: [assemble] compile syntax error into bytecode reporting syntax error message. --- generic/tclAssembly.c | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 0722eb9..9b9b6f8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -930,7 +930,7 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ -#if 0 +#if 1 int numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; int depth = envPtr->currStackDepth; @@ -956,11 +956,7 @@ TclCompileAssembleCmd( if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, TCL_EVAL_DIRECT)) { - /* - * TODO: Finish working out how to capture syntax errors captured - * during compile and make them bytecode reporting the error. - */ -#if 0 +#if 1 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s\" body, line %d)", parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, @@ -1136,7 +1132,7 @@ NewAssemblyEnv( assemEnvPtr->envPtr = envPtr; assemEnvPtr->parsePtr = parsePtr; - assemEnvPtr->cmdLine = envPtr->line; + assemEnvPtr->cmdLine = 1; assemEnvPtr->clNext = envPtr->clNext; /* -- cgit v0.12 From bc28cd1ac82705c2452e11f441e3fd0796c6d692 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Jul 2013 09:07:21 +0000 Subject: Add "testfork" test command. Not used in any test-case yet --- unix/configure | 204 ++++++++++++++++++++++++++--------------------------- unix/configure.in | 2 +- unix/tclUnixTest.c | 50 +++++++++++++ 3 files changed, 153 insertions(+), 103 deletions(-) diff --git a/unix/configure b/unix/configure index 6faa7d8..9fa5673 100755 --- a/unix/configure +++ b/unix/configure @@ -5303,6 +5303,108 @@ echo "${ECHO_T}no (default)" >&6 +for ac_func in pthread_atfork +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 #------------------------------------------------------------------------ @@ -17439,108 +17541,6 @@ _ACEOF fi done - -for ac_func in pthread_atfork -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define $ac_func to an innocuous variant, in case declares $ac_func. - For example, HP-UX 11i declares gettimeofday. */ -#define $ac_func innocuous_$ac_func - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef $ac_func - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - fi cat >>confdefs.h <<\_ACEOF diff --git a/unix/configure.in b/unix/configure.in index e22a7d3..5a7125e 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -93,6 +93,7 @@ fi #------------------------------------------------------------------------ SC_ENABLE_THREADS +AC_CHECK_FUNCS(pthread_atfork) #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 @@ -513,7 +514,6 @@ if test "`uname -s`" = "Darwin" ; then if test $tcl_corefoundation = yes; then AC_CHECK_HEADERS(libkern/OSAtomic.h) AC_CHECK_FUNCS(OSSpinLockLock) - AC_CHECK_FUNCS(pthread_atfork) fi AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?]) AC_DEFINE(TCL_DEFAULT_ENCODING, "utf-8", diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index b6529c2..2fc1647 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -66,6 +66,8 @@ static int TestfilewaitCmd(ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv); static int TestfindexecutableCmd(ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv); +static int TestforkObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST *argv); static int TestgetopenfileCmd(ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv); static int TestgetdefencdirCmd(ClientData dummy, @@ -110,6 +112,8 @@ TclplatformtestInit( (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd, (ClientData) 0, NULL); + Tcl_CreateObjCommand(interp, "testfork", TestforkObjCmd, + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd, @@ -533,6 +537,52 @@ TestsetdefencdirCmd( Tcl_SetDefaultEncodingDir(argv[1]); return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestforkObjCmd -- + * + * This function implements the "testfork" command. It is used to + * fork the Tcl process for specific test cases. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestforkObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST *objv) /* Argument strings. */ +{ + pid_t pid; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + pid = fork(); + if (pid == -1) { + Tcl_AppendResult(interp, + "Cannot fork", NULL); + return TCL_ERROR; + } +#ifndef HAVE_PTHREAD_ATFORK + /* Only needed when pthread_atfork is not present. */ + if (pid==0) { + Tcl_InitNotifier(); + } +#endif + Tcl_SetObjResult(interp, Tcl_NewIntObj(pid)); + return TCL_OK; +} /* *---------------------------------------------------------------------- -- cgit v0.12 From f796ad762c4354f621d513a997b320048a0a0f9a Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 23 Jul 2013 18:01:36 +0000 Subject: Stop checking stack depth in [catch] compiler. Stack depth is checked in compiles of *all* Tcl commands/scripts/bodies in debug builds already. --- generic/tclCompCmds.c | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7fe0728..bde6f96 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -544,7 +544,6 @@ TclCompileCatchCmd( JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; int resultIndex, optsIndex, range; - int initStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ /* @@ -742,15 +741,6 @@ TclCompileCatchCmd( TclEmitOpcode( INST_POP, envPtr); } - /* - * Result of all this, on either branch, should have been to leave one - * operand -- the return code -- on the stack. - */ - - if (envPtr->currStackDepth != initStackDepth + 1) { - Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d", - envPtr->currStackDepth, initStackDepth+1); - } return TCL_OK; } -- cgit v0.12 From 8163234efdf4df6b2cbfc307170a68219a65f528 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 23 Jul 2013 18:03:39 +0000 Subject: Remove outdated comment. Stack depths are well checked now. --- generic/tclCompCmdsSZ.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 320ed57..d8587be 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -991,9 +991,6 @@ TclSubstCompile( * Instructions are added to envPtr to execute the "switch" command at * runtime. * - * FIXME: - * Stack depths are probably not calculated correctly. - * *---------------------------------------------------------------------- */ -- cgit v0.12 From e0437fdf5828507b1d8411139e0030b2543259ee Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 23 Jul 2013 20:11:00 +0000 Subject: Remove outdated, disabled code. --- generic/tclCompile.c | 503 --------------------------------------------------- 1 file changed, 503 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a52ad3e..e4da2ba 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -16,8 +16,6 @@ #include "tclCompile.h" #include -#define REWRITE - /* * Table of all AuxData types. */ @@ -564,10 +562,6 @@ static void EnterCmdExtentData(CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); -#ifndef REWRITE -static Command * FindCompiledCommandFromToken(Tcl_Interp *interp, - Tcl_Token *tokenPtr); -#endif static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); @@ -1672,56 +1666,6 @@ TclWordKnownAtCompileTime( return 1; } -#ifndef REWRITE -/* - * --------------------------------------------------------------------- - * - * FindCompiledCommandFromToken -- - * - * A simple helper that looks up a command's compiler from its token. - * - * --------------------------------------------------------------------- - */ - -static Command * -FindCompiledCommandFromToken( - Tcl_Interp *interp, - Tcl_Token *tokenPtr) -{ - Tcl_DString ds; - Command *cmdPtr; - - /* - * If we have a non-trivial token or are suppressing compilation, we stop - * right now. - */ - - if ((tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) - || (((Interp *) interp)->flags & DONT_COMPILE_CMDS_INLINE)) { - return NULL; - } - - /* - * We copy the string before trying to find the command by name. We used - * to modify the string in place, but this is not safe because the name - * resolution handlers could have side effects that rely on the unmodified - * string. - */ - - Tcl_DStringInit(&ds); - TclDStringAppendToken(&ds, &tokenPtr[1]); - cmdPtr = (Command *) Tcl_FindCommand(interp, Tcl_DStringValue(&ds), NULL, - /*flags*/ 0); - if (cmdPtr != NULL && (cmdPtr->compileProc == NULL - || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) - || (cmdPtr->flags & CMD_HAS_EXEC_TRACES))) { - cmdPtr = NULL; - } - Tcl_DStringFree(&ds); - return cmdPtr; -} -#endif - /* *---------------------------------------------------------------------- * @@ -1740,8 +1684,6 @@ FindCompiledCommandFromToken( *---------------------------------------------------------------------- */ -#ifdef REWRITE - static int ExpandRequested( Tcl_Token *tokenPtr, @@ -2071,7 +2013,6 @@ CompileCommandTokens( return cmdIdx; } -#endif void TclCompileScript( @@ -2084,7 +2025,6 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { -#ifdef REWRITE int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last * command this routine compiles into bytecode. * Initial value of -1 indicates this routine @@ -2198,449 +2138,6 @@ TclCompileScript( envPtr->codeNext--; envPtr->currStackDepth++; } -#else - int lastTopLevelCmdIndex = -1; - /* Index of most recent toplevel command in - * the command location table. Initialized to - * avoid compiler warning. */ - int startCodeOffset = -1; /* Offset of first byte of current command's - * code. Init. to avoid compiler warning. */ - unsigned char *entryCodeNext = envPtr->codeNext; - const char *p, *next; - Command *cmdPtr; - Tcl_Token *tokenPtr; - int bytesLeft, isFirstCmd, wordIdx, currCmdIndex, commandLength, objIndex; - /* TIP #280 */ - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; - int *wlines, wlineat, cmdLine, *clNext; - Tcl_Parse parse, *parsePtr = &parse; - - if (envPtr->iPtr == NULL) { - Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); - } - - if (numBytes < 0) { - numBytes = strlen(script); - } - Tcl_ResetResult(interp); - isFirstCmd = 1; - - /* - * Each iteration through the following loop compiles the next command - * from the script. - */ - - p = script; - bytesLeft = numBytes; - cmdLine = envPtr->line; - clNext = envPtr->clNext; - do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { - /* - * Compile bytecodes to report the parse error at runtime. - */ - - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - parsePtr->term + 1 - parsePtr->commandStart); - TclCompileSyntaxError(interp, envPtr); - break; - } - - /* - * TIP #280: We have to count newlines before the command even in the - * degenerate case when the command has no words. (See test - * info-30.33). - * So make that counting here, and not in the (numWords > 0) branch - * below. - */ - - TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); - TclAdvanceContinuations(&cmdLine, &clNext, - parsePtr->commandStart - envPtr->source); - - if (parsePtr->numWords > 0) { - int expand = 0; /* Set if there are dynamic expansions to - * handle */ - - /* - * If not the first command, pop the previous command's result - * and, if we're compiling a top level command, update the last - * command's code size to account for the pop instruction. - */ - - if (!isFirstCmd) { - TclEmitOpcode(INST_POP, envPtr); - envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - startCodeOffset; - } - - /* - * Determine the actual length of the command. - */ - - commandLength = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + commandLength-1) { - /* - * The command terminator character (such as ; or ]) is the - * last character in the parsed command. Reduce the length by - * one so that the trace message doesn't include the - * terminator character. - */ - - commandLength -= 1; - } - -#ifdef TCL_COMPILE_DEBUG - /* - * If tracing, print a line for each top level command compiled. - */ - - if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parsePtr->commandStart, - TclMin(commandLength, 55)); - fprintf(stdout, "\n"); - } -#endif - - /* - * Check whether expansion has been requested for any of the - * words. - */ - - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; - break; - } - } - - /* - * If expansion was requested, check if the command declares that - * it knows how to compile it. Note that if expansion is requested - * for the first word, this check will fail as the token type will - * inhibit it. (Checked inside FindCompiledCommandFromToken.) This - * is as it should be. - */ - - if (expand) { - cmdPtr = FindCompiledCommandFromToken(interp, - parsePtr->tokenPtr); - if (cmdPtr && (cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = 0; - } - } - - envPtr->numCommands++; - currCmdIndex = envPtr->numCommands - 1; - lastTopLevelCmdIndex = currCmdIndex; - startCodeOffset = envPtr->codeNext - envPtr->codeStart; - EnterCmdStartData(envPtr, currCmdIndex, - parsePtr->commandStart - envPtr->source, startCodeOffset); - - /* - * Should only start issuing instructions after the "command has - * started" so that the command range is correct in the bytecode. - */ - - if (expand) { - StartExpanding(envPtr); - } - - /* - * 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, - clNext, &wlines, envPtr); - wlineat = eclPtr->nuloc - 1; - - /* - * Each iteration of the following loop compiles one word from the - * command. - */ - - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; wordIdx++, - tokenPtr += tokenPtr->numComponents + 1) { - /* - * Note the parse location information. - */ - - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * The word is not a simple string of characters. - */ - - CompileTokens(envPtr, tokenPtr, interp); - if (expand && tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); - } - continue; - } - - /* - * This is a simple string of literal characters (i.e. we know - * it absolutely and can use it directly). If this is the - * first word and the command has a compile procedure, let it - * compile the command. - */ - - if ((wordIdx == 0) && !expand) { - cmdPtr = FindCompiledCommandFromToken(interp, tokenPtr); - if (cmdPtr) { - int savedNumCmds = envPtr->numCommands; - unsigned savedCodeNext = - envPtr->codeNext - envPtr->codeStart; - int update = 0; - int startStackDepth = envPtr->currStackDepth; - - /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD - * in special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] - * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. - */ - - if (envPtr->atCmdStart == 1) { - if (savedCodeNext != 0) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) - } - } else if (envPtr->atCmdStart == 0) { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; - } - - if (cmdPtr->compileProc(interp, parsePtr, cmdPtr, - envPtr) == TCL_OK) { - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ - -#ifdef TCL_COMPILE_DEBUG - int diff = envPtr->currStackDepth-startStackDepth; - - if (diff != 1) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", - parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif - if (update) { - /* - * Fix the bytecode length. - */ - - unsigned char *fixPtr = envPtr->codeStart - + savedCodeNext + 1; - unsigned fixLen = envPtr->codeNext - - envPtr->codeStart - savedCodeNext; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } - - if (envPtr->atCmdStart == 1 && savedCodeNext != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); - } - - /* - * Restore numCommands and codeNext to their correct - * values, removing any commands compiled before the - * failure to produce bytecode got reported. [Bugs - * 705406 and 735055] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; - - /* - * And the stack depth too!! [Bug 3614102]. - */ - - envPtr->currStackDepth = startStackDepth; - } - - /* - * No compile procedure so push the word. If the command - * was found, push a CmdName object to reduce runtime - * lookups. Mark this as a command name literal to reduce - * shimmering. - */ - - objIndex = TclRegisterNewCmdLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (cmdPtr) { - TclSetCmdNameObj(interp, - TclFetchLiteral(envPtr, objIndex), cmdPtr); - } - } else { - /* - * Simple argument word of a command. We reach this if and - * only if the command word was not compiled for whatever - * reason. Register the literal's location for use by - * uplevel, etc. commands, should they encounter it - * unmodified. We care only if the we are in a context - * which already allows absolute counting. - */ - - objIndex = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - - if (envPtr->clNext) { - TclContinuationsEnterDerived( - TclFetchLiteral(envPtr, objIndex), - tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); - } - } - TclEmitPush(objIndex, envPtr); - } /* for loop */ - - /* - * Emit an invoke instruction for the command. We skip this if a - * compile procedure was found for the command. - */ - assert(wordIdx > 0); - - if (expand) { - /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. - * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). - * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. - */ - - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - envPtr->expandCount--; - TclAdjustStackDepth(1 - wordIdx, envPtr); - } else { - /* - * Save PC -> command map for the TclArgumentBC* functions. - */ - - int isnew; - Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, - INT2PTR(envPtr->codeNext - envPtr->codeStart), - &isnew); - - Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); - if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); - } - } - - /* - * Update the compilation environment structure and record the - * offsets of the source and code for the command. - */ - - finishCommand: - EnterCmdExtentData(envPtr, currCmdIndex, commandLength, - (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - isFirstCmd = 0; - - /* - * TIP #280: Free full form of per-word line data and insert the - * reduced form now - */ - - ckfree(eclPtr->loc[wlineat].line); - ckfree(eclPtr->loc[wlineat].next); - eclPtr->loc[wlineat].line = wlines; - eclPtr->loc[wlineat].next = NULL; - } /* end if parsePtr->numWords > 0 */ - - /* - * Advance to the next command in the script. - */ - - next = parsePtr->commandStart + parsePtr->commandSize; - bytesLeft -= next - p; - p = next; - - /* - * TIP #280: Track lines in the just compiled command. - */ - - TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); - TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); - Tcl_FreeParse(parsePtr); - } while (bytesLeft > 0); - - /* - * TIP #280: Bring the line counts in the CompEnv up to date. - * See tests info-30.33,34,35 . - */ - - envPtr->line = cmdLine; - envPtr->clNext = clNext; - - /* - * If the source script yielded no instructions (e.g., if it was empty), - * push an empty string as the command's result. - */ - - if (envPtr->codeNext == entryCodeNext) { - PushStringLiteral(envPtr, ""); - } -#endif } /* -- cgit v0.12 From d818803502a3520a2aa8c1a7ce11b8733eaafcc1 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Jul 2013 12:13:01 +0000 Subject: more disabled code removal --- generic/tclAssembly.c | 7 ------- generic/tclEnsemble.c | 46 ---------------------------------------------- 2 files changed, 53 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 9b9b6f8..6bf2fa8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -930,11 +930,9 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ -#if 1 int numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; int depth = envPtr->currStackDepth; -#endif /* * Make sure that the command has a single arg that is a simple word. @@ -956,7 +954,6 @@ TclCompileAssembleCmd( if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, TCL_EVAL_DIRECT)) { -#if 1 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s\" body, line %d)", parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, @@ -965,10 +962,6 @@ TclCompileAssembleCmd( envPtr->codeNext = envPtr->codeStart + offset; envPtr->currStackDepth = depth; TclCompileSyntaxError(interp, envPtr); -#else - Tcl_ResetResult(interp); - return TCL_ERROR; -#endif } return TCL_OK; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index bab63c9..ad11785 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3205,7 +3205,6 @@ CompileBasicNArgCommand( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { -#if 1 Tcl_Obj *objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); @@ -3213,51 +3212,6 @@ CompileBasicNArgCommand( TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, parsePtr->numWords, envPtr); Tcl_DecrRefCount(objPtr); -#else - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - char *bytes; - int length, i, literal; - DefineLineInformation; - - /* - * Push the name of the command we're actually dispatching to as part of - * the implementation. - */ - - objPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); - literal = TclRegisterNewCmdLiteral(envPtr, bytes, length); - TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, literal), cmdPtr); - TclEmitPush(literal, envPtr); - TclDecrRefCount(objPtr); - - /* - * Push the words of the command. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; inumWords ; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); - } else { - SetLineInformation(i); - CompileTokens(envPtr, tokenPtr, interp); - } - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Do the standard dispatch. - */ - - if (i <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); - } -#endif return TCL_OK; } -- cgit v0.12 From f2bea640bbf79037a46201c95c581f6f8ac5e5ee Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Jul 2013 13:58:35 +0000 Subject: Mark commands with potential to compile expansion arguments (as [list] does). --- generic/tclCompCmds.c | 9 +++++++++ generic/tclCompCmdsGR.c | 4 ++++ generic/tclCompCmdsSZ.c | 5 +++++ 3 files changed, 18 insertions(+) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index bde6f96..8edb2d9 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -87,6 +87,7 @@ TclCompileAppendCmd( int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -973,6 +974,7 @@ TclCompileDictGetCmd( * case is legal, but too special and magic for us to deal with here). */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1010,6 +1012,7 @@ TclCompileDictExistsCmd( * case is legal, but too special and magic for us to deal with here). */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1047,6 +1050,7 @@ TclCompileDictUnsetCmd( * compile to bytecode. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1192,6 +1196,7 @@ TclCompileDictMergeCmd( * argument, the only thing to do is to verify the dict-ness. */ + /* TODO: Consider support for compiling expanded args. (less likely) */ if (parsePtr->numWords < 2) { PushStringLiteral(envPtr, ""); return TCL_OK; @@ -1712,6 +1717,7 @@ TclCompileDictAppendCmd( * speed quite so much. ;-) */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords<4 || parsePtr->numWords>100) { return TCL_ERROR; } @@ -1764,6 +1770,8 @@ TclCompileDictLappendCmd( * There must be three arguments after the command. */ + /* TODO: Consider support for compiling expanded args. */ + /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */ if (parsePtr->numWords != 4) { return TCL_ERROR; } @@ -1810,6 +1818,7 @@ TclCompileDictWithCmd( * There must be at least one argument after the command. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index fc68509..150c378 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -60,6 +60,7 @@ TclCompileGlobalCmd( int localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; @@ -820,6 +821,7 @@ TclCompileLappendCmd( return TCL_ERROR; } + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -1061,6 +1063,7 @@ TclCompileLindexCmd( * Quit if too few args. */ + /* TODO: Consider support for compiling expanded args. */ if (numWords <= 1) { return TCL_ERROR; } @@ -1583,6 +1586,7 @@ TclCompileLsetCmd( * Check argument count. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { /* * Fail at run time, not in compilation. diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d8587be..d1eb9db 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2818,6 +2818,7 @@ TclCompileUnsetCmd( Tcl_Obj *leadingWord; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords-1; flags = 1; varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -3173,6 +3174,7 @@ CompileAssociativeBinaryOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); @@ -3256,6 +3258,7 @@ CompileComparisonOpCmd( Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { PUSH("1"); } else if (parsePtr->numWords == 3) { @@ -3593,6 +3596,7 @@ TclCompileMinusOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. @@ -3638,6 +3642,7 @@ TclCompileDivOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. -- cgit v0.12 From 8f2d19b95103df07e718125efcd772ff582c2be1 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Jul 2013 16:51:04 +0000 Subject: Demonstrate and fix memory leak in Tcl_ParseVar(). --- generic/tclParse.c | 1 + tests/parse.test | 21 +++++++++++++++++++++ 2 files changed, 22 insertions(+) diff --git a/generic/tclParse.c b/generic/tclParse.c index 96c2a10..e475fb8 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1566,6 +1566,7 @@ Tcl_ParseVar( code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, NULL, 1, NULL, NULL); + Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); if (code != TCL_OK) { return NULL; diff --git a/tests/parse.test b/tests/parse.test index 4605914..d7de5ff 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -23,6 +23,7 @@ testConstraint testparsevarname [llength [info commands testparsevarname]] testConstraint testparsevar [llength [info commands testparsevar]] testConstraint testasync [llength [info commands testasync]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] +testConstraint memory [llength [info commands memory]] test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 @@ -674,6 +675,26 @@ test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar unset -nocomplain abc list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg } {1 {invalid command name "bogus"}} +test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup { + proc getbytes {} { + return [lindex [split [memory info] \n] 3 3] + } +} -body { + set a() foo + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set vn {} + set res [testparsevar [append vn $ a([string repeat {[]} 19]) bar]] + if {$res ne {foo bar}} {error "Unexpected result: $res"} + + set tmp $end + set end [getbytes] + } + expr {$end - $tmp} +} -cleanup { + unset -nocomplain a end i vn res tmp + rename getbytes {} +} -result 0 test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 -- cgit v0.12 From c019848148730c03e59a86793f155327f407cd7e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Jul 2013 06:59:08 +0000 Subject: Put Cygwin's tclWinError.o in PLAT_OBJS, not in DL_OBJS --- unix/Makefile.in | 5 ++++- unix/configure | 3 ++- unix/tcl.m4 | 3 ++- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index b5ca879..163f4b5 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -335,7 +335,10 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o -STUB_LIB_OBJS = tclStubLib.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} +STUB_LIB_OBJS = tclStubLib.o \ + tclTomMathStubLib.o \ + tclOOStubLib.o \ + ${COMPAT_OBJS} UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ diff --git a/unix/configure b/unix/configure index ef47ac5..4d0ecef 100755 --- a/unix/configure +++ b/unix/configure @@ -7170,7 +7170,8 @@ fi SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" - DL_OBJS="tclLoadDl.o tclWinError.o" + DL_OBJS="tclLoadDl.o" + PLAT_OBJS="tclWinError.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" diff --git a/unix/tcl.m4 b/unix/tcl.m4 index b9b6532..a95cf63 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1224,7 +1224,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" - DL_OBJS="tclLoadDl.o tclWinError.o" + DL_OBJS="tclLoadDl.o" + PLAT_OBJS="tclWinError.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" -- cgit v0.12 From 60ef39d24a8c8c1572ef6f2efad50706b49e0f06 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Jul 2013 14:24:39 +0000 Subject: Move test for pthread_atfork inside SC_ENABLE_THREADS --- unix/configure | 105 ++---------------------------------------------------- unix/configure.in | 1 - unix/tcl.m4 | 2 +- 3 files changed, 3 insertions(+), 105 deletions(-) diff --git a/unix/configure b/unix/configure index 9fa5673..217e5d4 100755 --- a/unix/configure +++ b/unix/configure @@ -4796,7 +4796,8 @@ echo "$as_me: WARNING: Don't know how to find pthread lib on your system - you m ac_saved_libs=$LIBS LIBS="$LIBS $THREADS_LIBS" -for ac_func in pthread_attr_setstacksize + +for ac_func in pthread_attr_setstacksize pthread_atfork do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 @@ -5303,108 +5304,6 @@ echo "${ECHO_T}no (default)" >&6 -for ac_func in pthread_atfork -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define $ac_func to an innocuous variant, in case declares $ac_func. - For example, HP-UX 11i declares gettimeofday. */ -#define $ac_func innocuous_$ac_func - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef $ac_func - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - - #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 5a7125e..37de8be 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -93,7 +93,6 @@ fi #------------------------------------------------------------------------ SC_ENABLE_THREADS -AC_CHECK_FUNCS(pthread_atfork) #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 879d810..f484989 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -679,7 +679,7 @@ AC_DEFUN([SC_ENABLE_THREADS], [ ac_saved_libs=$LIBS LIBS="$LIBS $THREADS_LIBS" - AC_CHECK_FUNCS(pthread_attr_setstacksize) + AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork) AC_CHECK_FUNC(pthread_attr_get_np,tcl_ok=yes,tcl_ok=no) if test $tcl_ok = yes ; then AC_DEFINE(HAVE_PTHREAD_ATTR_GET_NP, 1, -- cgit v0.12 From 6adf3b8c6c375d8b2ec61544abe1acf0a734e5c1 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 26 Jul 2013 13:21:30 +0000 Subject: [6585b21ca8] [regexp {(\w).*?\1} abb] failed to match. Thanks to Tom Lane for passing on the discovery in Postgres. --- generic/regexec.c | 7 +------ tests/regexp.test | 4 ++++ 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/generic/regexec.c b/generic/regexec.c index c902209..205fcc2 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -512,12 +512,7 @@ cfindloop( return er; } if ((shorter) ? end == estop : end == begin) { - /* - * No point in trying again. - */ - - *coldp = cold; - return REG_NOMATCH; + break; } /* diff --git a/tests/regexp.test b/tests/regexp.test index 8138054..362f425 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -728,6 +728,10 @@ test regexp-22.5 {Bug 3610026} -setup { } -cleanup { unset -nocomplain e cp } -returnCodes error -match glob -result {*too many colors*} +test regexp-22.6 {Bug 6585b21ca8} { + expr {[regexp {(\w).*?\1} Programmer m] ? $m : ""} +} rogr + test regexp-23.1 {regexp -all and -line} { set string "" -- cgit v0.12