diff options
| -rw-r--r-- | ChangeLog | 14 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 50 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 271 | ||||
| -rw-r--r-- | generic/tclCompile.c | 172 | ||||
| -rw-r--r-- | generic/tclCompile.h | 10 | ||||
| -rw-r--r-- | generic/tclExecute.c | 21 | ||||
| -rw-r--r-- | generic/tclInt.h | 10 | ||||
| -rw-r--r-- | generic/tclParse.c | 61 | ||||
| -rw-r--r-- | tests/basic.test | 4 | ||||
| -rw-r--r-- | tests/info.test | 123 | ||||
| -rw-r--r-- | tests/parse.test | 8 |
12 files changed, 616 insertions, 132 deletions
@@ -1,3 +1,17 @@ +2009-09-04 Don Porter <dgp@users.sourceforge.net> + + * generic/tclCompCmds.c (TclCompileSubstCmd): Added a bytecode + * generic/tclBasic.c: compiler routine for the [subst] command. + * generic/tclCmdMZ.c: This is a partial solution to the need to + * generic/tclCompile.c: NR-enable [subst] since bytecode execution is + * generic/tclCompile.h: already NR-enabled. [Bug 2314561] Two new + * generic/tclExecute.c: bytecode instructions, INST_NOP and + * generic/tclInt.h: INST_RETURN_CODE_BRANCH were added to support + * generic/tclParse.c: the new routine. INST_RETURN_CODE_BRANCH is + * tests/basic.test: likely to be useful in any future effort to + * tests/info.test: add a bytecode compiler routine for [try]. + * tests/parse.test: + 2009-09-03 Donal K. Fellows <dkf@users.sf.net> * doc/LinkVar.3: [Bug 2844962]: Added documentation of issues relating diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d97194c..b5abbc2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.402 2009/08/25 21:03:25 andreas_kupries Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.403 2009/09/04 17:33:11 dgp Exp $ */ #include "tclInt.h" @@ -213,7 +213,7 @@ static const CmdInfo builtInCmds[] = { {"scan", Tcl_ScanObjCmd, NULL, NULL, 1}, {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1}, {"split", Tcl_SplitObjCmd, NULL, NULL, 1}, - {"subst", Tcl_SubstObjCmd, NULL, NULL, 1}, + {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, NULL, 1}, {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1}, {"throw", Tcl_ThrowObjCmd, NULL, NULL, 1}, {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 2cce7be..a5a2f1b 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.191 2009/08/25 21:03:25 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.192 2009/09/04 17:33:11 dgp Exp $ */ #include "tclInt.h" @@ -3373,30 +3373,24 @@ TclInitStringCmd( */ int -Tcl_SubstObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +TclSubstOptions( + Tcl_Interp *interp, + int numOpts, + Tcl_Obj *const opts[], + int *flagPtr) { static const char *const substOptions[] = { "-nobackslashes", "-nocommands", "-novariables", NULL }; - enum substOptions { + enum { SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS }; - Tcl_Obj *resultPtr; - int flags, i; + int i, flags = TCL_SUBST_ALL; - /* - * Parse command-line options. - */ - - flags = TCL_SUBST_ALL; - for (i = 1; i < (objc-1); i++) { + for (i = 0; i < numOpts; i++) { int optionIndex; - if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, + if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "switch", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } @@ -3414,17 +3408,31 @@ Tcl_SubstObjCmd( Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } } - if (i != objc-1) { + *flagPtr = flags; + return TCL_OK; +} + +int +Tcl_SubstObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *resultPtr; + int flags; + + if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } - /* - * Perform the substitution. - */ + if (TclSubstOptions(interp, objc-2, objv+1, &flags) != TCL_OK) { + return TCL_ERROR; + } - resultPtr = Tcl_SubstObj(interp, objv[i], flags); + resultPtr = Tcl_SubstObj(interp, objv[objc-1], flags); if (resultPtr == NULL) { return TCL_ERROR; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5b5871f..ffcd22a 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.153 2009/08/25 21:03:25 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.154 2009/09/04 17:33:11 dgp Exp $ */ #include "tclInt.h" @@ -3844,6 +3844,275 @@ TclCompileStringLenCmd( /* *---------------------------------------------------------------------- * + * TclCompileSubstCmd -- + * + * Procedure called to compile the "subst" command. + * + * Results: + * Returns TCL_OK for successful compile, or TCL_ERROR to defer + * evaluation to runtime (either when it is too complex to get the + * semantics right, or when we know for sure that it is an error but need + * the error to happen at the right time). + * + * Side effects: + * Instructions are added to envPtr to execute the "subst" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileSubstCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + int numArgs = parsePtr->numWords - 1; + int numOpts = numArgs - 1; + int objc, flags = TCL_SUBST_ALL; + Tcl_Obj **objv/*, *toSubst = NULL*/; + Tcl_Parse parse; + Tcl_InterpState state = NULL; + Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + int breakOffset = 0, count = 0, code = TCL_OK; + Tcl_Token *endTokenPtr, *tokenPtr; + DefineLineInformation; /* TIP #280 */ + int bline = mapPtr->loc[eclIndex].line[numArgs]; + SetLineInformation(numArgs); + + if (numArgs == 0) { + return TCL_ERROR; + } + + objv = (Tcl_Obj **) TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *)); + + for (objc = 0; objc < /*numArgs*/ numOpts; objc++) { + objv[objc] = Tcl_NewObj(); + Tcl_IncrRefCount(objv[objc]); + if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { + objc++; + goto cleanup; + } + wordTokenPtr = TokenAfter(wordTokenPtr); + } + +/* + if (TclSubstOptions(NULL, numOpts, objv, &flags) == TCL_OK) { + toSubst = objv[numOpts]; + Tcl_IncrRefCount(toSubst); + } +*/ + + /* TODO: Figure out expansion to cover WordKnownAtCompileTime + * The difficulty is that WKACT makes a copy, and if TclSubstParse + * below parses the copy of the original source string, some deep + * parts of the compile machinery get upset. They want all pointers + * stored in Tcl_Tokens to point back to the same original string. + */ + if (wordTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + code = TCL_ERROR; + } + if (code == TCL_OK) { + code = TclSubstOptions(NULL, numOpts, objv, &flags); + } + + cleanup: + while (--objc >= 0) { + TclDecrRefCount(objv[objc]); + } + TclStackFree(interp, objv); + if (/*toSubst == NULL*/ code != TCL_OK) { + return TCL_ERROR; + } + + TclSubstParse(interp, /*toSubst,*/ wordTokenPtr[1].start, + wordTokenPtr[1].size, flags, &parse, &state); + + for (tokenPtr = parse.tokenPtr, endTokenPtr = tokenPtr + parse.numTokens; + tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { + int length, literal, catchRange, breakJump; + char buf[TCL_UTF_MAX]; + JumpFixup startFixup, okFixup, returnFixup, breakFixup; + JumpFixup continueFixup, otherFixup, endFixup; + + switch (tokenPtr->type) { + case TCL_TOKEN_TEXT: + literal = TclRegisterNewLiteral(envPtr, + tokenPtr->start, tokenPtr->size); + TclEmitPush(literal, envPtr); + TclAdvanceLines(&bline, tokenPtr->start, + tokenPtr->start + tokenPtr->size); + count++; + continue; + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, NULL, buf); + literal = TclRegisterNewLiteral(envPtr, buf, length); + TclEmitPush(literal, envPtr); + count++; + continue; + } + + while (count > 255) { + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + count -= 254; + } + if (count > 1) { + TclEmitInstInt1(INST_CONCAT1, count, envPtr); + count = 1; + } + + if (breakOffset == 0) { + /* Jump to the start (jump over the jump to end) */ + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup); + + /* Jump to the end (all BREAKs land here) */ + breakOffset = CurrentOffset(envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); + + /* Start */ + if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { + Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d", + CurrentOffset(envPtr) - startFixup.codeOffset); + } + } + + envPtr->line = bline; + catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + TclEmitInstInt4(INST_BEGIN_CATCH4, catchRange, envPtr); + ExceptionRangeStarts(envPtr, catchRange); + + switch (tokenPtr->type) { + case TCL_TOKEN_COMMAND: + TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, + envPtr); + count++; + break; + case TCL_TOKEN_VARIABLE: + TclCompileVarSubst(interp, tokenPtr, envPtr); + count++; + break; + default: + Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d", + tokenPtr->type); + } + + ExceptionRangeEnds(envPtr, catchRange); + + /* Substitution produced TCL_OK */ + TclEmitOpcode(INST_END_CATCH, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); + + /* Exceptional return codes processed here */ + ExceptionRangeTarget(envPtr, catchRange, catchOffset); + TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode(INST_PUSH_RESULT, envPtr); + TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); + TclEmitOpcode(INST_END_CATCH, envPtr); + TclEmitOpcode(INST_RETURN_CODE_BRANCH, envPtr); + + /* ERROR -> reraise it */ + TclEmitOpcode(INST_RETURN_STK, envPtr); + TclEmitOpcode(INST_NOP, envPtr); + + /* RETURN */ + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup); + + /* BREAK */ + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup); + + /* CONTINUE */ + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup); + + /* OTHER */ + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup); + + /* BREAK destination */ + if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { + Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", + CurrentOffset(envPtr) - breakFixup.codeOffset); + } + TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode(INST_POP, envPtr); + + breakJump = CurrentOffset(envPtr) - breakOffset; + if (breakJump > 127) { + TclEmitInstInt4(INST_JUMP4, -breakJump, envPtr) + } else { + TclEmitInstInt1(INST_JUMP1, -breakJump, envPtr) + } + + /* CONTINUE destination */ + if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { + Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", + CurrentOffset(envPtr) - continueFixup.codeOffset); + } + TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode(INST_POP, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); + + /* RETURN + other destination */ + if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { + Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", + CurrentOffset(envPtr) - returnFixup.codeOffset); + } + if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { + Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d", + CurrentOffset(envPtr) - otherFixup.codeOffset); + } + /* Pull the result to top of stack, discard options dict */ + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitOpcode(INST_POP, envPtr); + + /* OK destination */ + if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { + Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", + CurrentOffset(envPtr) - okFixup.codeOffset); + } + if (count > 1) { + TclEmitInstInt1(INST_CONCAT1, count, envPtr); + count = 1; + } + + /* CONTINUE jump to here */ + if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { + Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d", + CurrentOffset(envPtr) - endFixup.codeOffset); + } + bline = envPtr->line; + } + + + while (count > 255) { + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + count -= 254; + } + if (count > 1) { + TclEmitInstInt1(INST_CONCAT1, count, envPtr); + } + + Tcl_FreeParse(&parse); +/* TclDecrRefCount(toSubst);*/ + + if (state != NULL) { + Tcl_RestoreInterpState(interp, state); + TclCompileSyntaxError(interp, envPtr); + } + + /* Final target of the multi-jump from all BREAKs */ + if (breakOffset > 0) { + TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset, + envPtr->codeStart + breakOffset); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileSwitchCmd -- * * Procedure called to compile the "switch" command. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 970c1ef..b6b270b 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.172 2009/08/25 23:20:36 das Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.173 2009/09/04 17:33:11 dgp Exp $ */ #include "tclInt.h" @@ -399,6 +399,13 @@ InstructionDesc const tclInstructionTable[] = { * stknext */ {"existStk", 1, 0, 0, {OPERAND_NONE}}, /* Test if general variable exists; unparsed variable name is stktop*/ + {"nop", 1, 0, 0, {OPERAND_NONE}}, + /* Do nothing */ + {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}}, + /* Jump to next instruction based on the return code on top of stack + * ERROR: +1; RETURN: +3; BREAK: +5; CONTINUE: +7; + * Other non-OK: +9 + */ {0} }; @@ -1277,6 +1284,17 @@ TclCompileScript( 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 */ @@ -1361,9 +1379,6 @@ TclCompileScript( * 'wlines'. */ - TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); - TclAdvanceContinuations (&cmdLine, &clNext, - parsePtr->commandStart - envPtr->source); EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, parsePtr->tokenPtr, parsePtr->commandStart, parsePtr->commandSize, parsePtr->numWords, cmdLine, @@ -1633,6 +1648,14 @@ TclCompileScript( } 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. * @@ -1674,6 +1697,77 @@ TclCompileScript( */ void +TclCompileVarSubst( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + CompileEnv *envPtr) +{ + const char *p, *name = tokenPtr[1].start; + int nameBytes = tokenPtr[1].size; + int i, localVar, localVarName = 1; + + /* + * Determine how the variable name should be handled: if it + * contains any namespace qualifiers it is not a local variable + * (localVarName=-1); if it looks like an array element and the + * token has a single component, it should not be created here + * [Bug 569438] (localVarName=0); otherwise, the local variable + * can safely be created (localVarName=1). + */ + + for (i = 0, p = name; i < nameBytes; i++, p++) { + if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) { + localVarName = -1; + break; + } else if ((*p == '(') + && (tokenPtr->numComponents == 1) + && (*(name + nameBytes - 1) == ')')) { + localVarName = 0; + break; + } + } + + /* + * Either push the variable's name, or find its index in the array + * of local variables in a procedure frame. + */ + + localVar = -1; + if (localVarName != -1) { + localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr); + } + if (localVar < 0) { + TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), envPtr); + } + + /* + * Emit instructions to load the variable. + */ + + TclAdvanceLines(&(envPtr->line), tokenPtr[1].start, + tokenPtr[1].start + tokenPtr[1].size); + + if (tokenPtr->numComponents == 1) { + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); + } + } else { + TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); + } + } +} + +void TclCompileTokens( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to @@ -1685,9 +1779,7 @@ TclCompileTokens( Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; - const char *name, *p; - int numObjsToConcat, nameBytes, localVarName, localVar; - int length, i; + int i, numObjsToConcat, length; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; @@ -1731,6 +1823,8 @@ TclCompileTokens( switch (tokenPtr->type) { case TCL_TOKEN_TEXT: Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); + TclAdvanceLines(&(envPtr->line), tokenPtr->start, + tokenPtr->start + tokenPtr->size); break; case TCL_TOKEN_BS: @@ -1810,69 +1904,7 @@ TclCompileTokens( Tcl_DStringFree(&textBuffer); } - /* - * Determine how the variable name should be handled: if it - * contains any namespace qualifiers it is not a local variable - * (localVarName=-1); if it looks like an array element and the - * token has a single component, it should not be created here - * [Bug 569438] (localVarName=0); otherwise, the local variable - * can safely be created (localVarName=1). - */ - - name = tokenPtr[1].start; - nameBytes = tokenPtr[1].size; - - localVarName = 1; - for (i = 0, p = name; i < nameBytes; i++, p++) { - if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) { - localVarName = -1; - break; - } else if ((*p == '(') - && (tokenPtr->numComponents == 1) - && (*(name + nameBytes - 1) == ')')) { - localVarName = 0; - break; - } - } - - /* - * Either push the variable's name, or find its index in the array - * of local variables in a procedure frame. - */ - - localVar = -1; - if (localVarName != -1) { - localVar = TclFindCompiledLocal(name, nameBytes, localVarName, - envPtr); - } - if (localVar < 0) { - TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), - envPtr); - } - - /* - * Emit instructions to load the variable. - */ - - if (tokenPtr->numComponents == 1) { - if (localVar < 0) { - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); - } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); - } - } else { - TclCompileTokens(interp, tokenPtr+2, - tokenPtr->numComponents-1, envPtr); - if (localVar < 0) { - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); - } else { - TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); - } - } + TclCompileVarSubst(interp, tokenPtr, envPtr); numObjsToConcat++; count -= tokenPtr->numComponents; tokenPtr += tokenPtr->numComponents; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 4d9dbd1..25dec86 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.118 2009/08/25 21:03:25 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.119 2009/09/04 17:33:11 dgp Exp $ */ #ifndef _TCLCOMPILATION @@ -666,8 +666,12 @@ typedef struct ByteCode { #define INST_EXIST_ARRAY_STK 130 #define INST_EXIST_STK 131 +/* For [subst] compilation */ +#define INST_NOP 132 +#define INST_RETURN_CODE_BRANCH 133 + /* The last opcode */ -#define LAST_INST_OPCODE 131 +#define LAST_INST_OPCODE 133 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -893,6 +897,8 @@ MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); +MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, + Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE int TclCreateAuxData(ClientData clientData, const AuxDataType *typePtr, CompileEnv *envPtr); MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c668539..662d2a0 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.444 2009/08/12 16:06:43 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.445 2009/09/04 17:33:11 dgp Exp $ */ #include "tclInt.h" @@ -2493,6 +2493,10 @@ TclExecuteByteCode( NEXT_INST_F(opnd, 0, -1); } + case INST_NOP: + pc += 1; + goto cleanup0; + case INST_DUP: objResultPtr = OBJ_AT_TOS; TRACE_WITH_OBJ(("=> "), objResultPtr); @@ -7163,6 +7167,21 @@ TclExecuteByteCode( TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + case INST_RETURN_CODE_BRANCH: { + int code; + + if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { + Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!"); + } + if (code == TCL_OK) { + Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS is TCL_OK!"); + } + if (code < TCL_ERROR || code > TCL_CONTINUE) { + code = TCL_CONTINUE + 1; + } + NEXT_INST_F(2*code -1, 1, 0); + } + /* TODO: normalize "valPtr" to "valuePtr" */ { int opnd, opnd2, allocateDict; diff --git a/generic/tclInt.h b/generic/tclInt.h index dd073d2..97cb891 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.439 2009/09/04 09:38:20 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.440 2009/09/04 17:33:12 dgp Exp $ */ #ifndef _TCLINT @@ -2950,6 +2950,11 @@ MODULE_SCOPE int TclStringMatch(const char *str, int strLen, MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); +MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts, + Tcl_Obj *const opts[], int *flagPtr); +MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, + int numBytes, int flags, Tcl_Parse *parsePtr, + Tcl_InterpState *statePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line, int *clNextOuter, const char *outerScript); @@ -3370,6 +3375,9 @@ MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclParse.c b/generic/tclParse.c index aca6048..efb4422 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1880,18 +1880,17 @@ Tcl_ParseQuotedString( *---------------------------------------------------------------------- */ -Tcl_Obj * -Tcl_SubstObj( - Tcl_Interp *interp, /* Interpreter in which substitution occurs */ - Tcl_Obj *objPtr, /* The value to be substituted. */ - int flags) /* What substitutions to do. */ +void +TclSubstParse( + Tcl_Interp *interp, + const char *bytes, + int numBytes, + int flags, + Tcl_Parse *parsePtr, + Tcl_InterpState *statePtr) { - int length, tokensLeft, code; - Tcl_Token *endTokenPtr; - Tcl_Obj *result, *errMsg = NULL; - const char *p = TclGetStringFromObj(objPtr, &length); - Tcl_Parse *parsePtr = (Tcl_Parse *) - TclStackAlloc(interp, sizeof(Tcl_Parse)); + int length = numBytes; + const char *p = bytes; TclParseInit(interp, p, length, parsePtr); @@ -1903,12 +1902,11 @@ Tcl_SubstObj( if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, parsePtr)) { /* - * There was a parse error. Save the error message for possible - * reporting later. + * There was a parse error. Save the interpreter state for possible + * error reporting later. */ - errMsg = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(errMsg); + *statePtr = Tcl_SaveInterpState(interp, TCL_ERROR); /* * We need to re-parse to get the portion of the string we can [subst] @@ -2054,6 +2052,23 @@ Tcl_SubstObj( Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]); } } +} + +Tcl_Obj * +Tcl_SubstObj( + Tcl_Interp *interp, /* Interpreter in which substitution occurs */ + Tcl_Obj *objPtr, /* The value to be substituted. */ + int flags) /* What substitutions to do. */ +{ + int tokensLeft, code, numBytes; + Tcl_Token *endTokenPtr; + Tcl_Obj *result; + Tcl_Parse *parsePtr = (Tcl_Parse *) + TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_InterpState state = NULL; + const char *bytes = TclGetStringFromObj(objPtr, &numBytes); + + TclSubstParse(interp, bytes, numBytes, flags, parsePtr, &state); /* * Next, substitute the parsed tokens just as in normal Tcl evaluation. @@ -2066,9 +2081,8 @@ Tcl_SubstObj( if (code == TCL_OK) { Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); - if (errMsg != NULL) { - Tcl_SetObjResult(interp, errMsg); - Tcl_DecrRefCount(errMsg); + if (state != NULL) { + Tcl_RestoreInterpState(interp, state); return NULL; } return Tcl_GetObjResult(interp); @@ -2081,8 +2095,8 @@ Tcl_SubstObj( Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); Tcl_DecrRefCount(result); - if (errMsg != NULL) { - Tcl_DecrRefCount(errMsg); + if (state != NULL) { + Tcl_DiscardInterpState(state); } return NULL; case TCL_BREAK: @@ -2094,14 +2108,13 @@ Tcl_SubstObj( if (tokensLeft == 0) { Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); - if (errMsg != NULL) { + if (state != NULL) { if (code != TCL_BREAK) { Tcl_DecrRefCount(result); - Tcl_SetObjResult(interp, errMsg); - Tcl_DecrRefCount(errMsg); + Tcl_RestoreInterpState(interp, state); return NULL; } - Tcl_DecrRefCount(errMsg); + Tcl_DiscardInterpState(state); } return result; } diff --git a/tests/basic.test b/tests/basic.test index b8d608e..881b329 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -15,7 +15,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: basic.test,v 1.44 2007/04/20 05:51:11 kennykb Exp $ +# RCS: @(#) $Id: basic.test,v 1.45 2009/09/04 17:33:12 dgp Exp $ # package require tcltest 2 @@ -632,7 +632,7 @@ test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup { (file "*BREAKtest" line 2)} test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body { - subst {a[set b [format cd]} + set subst subst; $subst {a[set b [format cd]} } -returnCodes error -result {missing close-bracket} # Some lists for expansion tests to work with diff --git a/tests/info.test b/tests/info.test index 65d71bc..e538a23 100644 --- a/tests/info.test +++ b/tests/info.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: info.test,v 1.65 2009/08/25 21:03:25 andreas_kupries Exp $ +# RCS: @(#) $Id: info.test,v 1.66 2009/09/04 17:33:12 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -1525,12 +1525,12 @@ test info-30.10 {bs+nl in computed word, key to array} { set res } { type source line 1523 file info.test cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.11 {bs+nl in subst arguments, no true counting} { +test info-30.11 {bs+nl in subst arguments} { subst {[set \ res "\ [reduce \ - [info frame 0]]"]} -} { type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} + [info frame 0]]"]} ; #1532 +} { type source line 1532 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.12 {bs+nl in computed word, nested eval} { eval { @@ -1708,6 +1708,121 @@ test info-30.24 {bs+nl in single-body switch, full compiled} { type source line 1696 file info.test cmd {info frame 0} proc ::a level 0 type source line 1700 file info.test cmd {info frame 0} proc ::a level 0} +test info-30.25 {TIP 280 for compiled [subst]} { + subst {[reduce [info frame 0]]} ; # 1712 +} {type source line 1712 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.26 {TIP 280 for compiled [subst]} { + subst \ + {[reduce [info frame 0]]} ; # 1716 +} {type source line 1716 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.27 {TIP 280 for compiled [subst]} { + subst { +[reduce [info frame 0]]} ; # 1720 +} { +type source line 1720 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.28 {TIP 280 for compiled [subst]} { + subst {\ +[reduce [info frame 0]]} ; # 1725 +} { type source line 1725 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.29 {TIP 280 for compiled [subst]} { + subst {foo\ +[reduce [info frame 0]]} ; # 1729 +} {foo type source line 1729 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.30 {TIP 280 for compiled [subst]} { + subst {foo +[reduce [info frame 0]]} ; # 1733 +} {foo +type source line 1733 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.31 {TIP 280 for compiled [subst]} { + subst {[][reduce [info frame 0]]} ; # 1737 +} {type source line 1737 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.32 {TIP 280 for compiled [subst]} { + subst {[\ +][reduce [info frame 0]]} ; # 1741 +} {type source line 1741 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.33 {TIP 280 for compiled [subst]} { + subst {[ +][reduce [info frame 0]]} ; # 1745 +} {type source line 1745 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.34 {TIP 280 for compiled [subst]} { + subst {[format %s {} +][reduce [info frame 0]]} ; # 1749 +} {type source line 1749 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.35 {TIP 280 for compiled [subst]} { + subst {[format %s {} +] +[reduce [info frame 0]]} ; # 1754 +} { +type source line 1754 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.36 {TIP 280 for compiled [subst]} { + subst { +[format %s {}][reduce [info frame 0]]} ; # 1759 +} { +type source line 1759 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.37 {TIP 280 for compiled [subst]} { + subst { +[format %s {}] +[reduce [info frame 0]]} ; # 1765 +} { + +type source line 1765 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.38 {TIP 280 for compiled [subst]} { + subst {\ +[format %s {}][reduce [info frame 0]]} ; # 1771 +} { type source line 1771 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.39 {TIP 280 for compiled [subst]} { + subst {\ +[format %s {}]\ +[reduce [info frame 0]]} ; # 1776 +} { type source line 1776 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.40 {TIP 280 for compiled [subst]} { + unset -nocomplain empty + set empty {} + subst {$empty[reduce [info frame 0]]} ; # 1781 +} {type source line 1781 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.41 {TIP 280 for compiled [subst]} { + unset -nocomplain empty + set empty {} + subst {$empty +[reduce [info frame 0]]} ; # 1787 +} { +type source line 1787 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.42 {TIP 280 for compiled [subst]} { + unset -nocomplain empty + set empty {} + subst {$empty\ +[reduce [info frame 0]]} ; # 1794 +} { type source line 1794 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.43 {TIP 280 for compiled [subst]} { + unset -nocomplain a\nb + set a\nb {} + subst {${a +b}[reduce [info frame 0]]} ; # 1800 +} {type source line 1800 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.44 {TIP 280 for compiled [subst]} { + unset -nocomplain a + set a(\n) {} + subst {$a( +)[reduce [info frame 0]]} ; # 1806 +} {type source line 1806 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.45 {TIP 280 for compiled [subst]} { + unset -nocomplain a + set a() {} + subst {$a([ +return -level 0])[reduce [info frame 0]]} ; # 1812 +} {type source line 1812 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +test info-30.46 {TIP 280 for compiled [subst]} { + unset -nocomplain a + set a(1817) YES; set a(1816) 1816; set a(1818) 1818 + subst {$a([dict get [info frame 0] line])} ; # 1817 +} YES +test info-30.47 {TIP 280 for compiled [subst]} { + unset -nocomplain a + set a(\n1823) YES; set a(\n1822) 1822; set a(\n1824) 1824 + subst {$a( +[dict get [info frame 0] line])} ; # 1823 +} YES + # ------------------------------------------------------------------------- # cleanup diff --git a/tests/parse.test b/tests/parse.test index 9427254..b745a97 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: parse.test,v 1.36 2008/11/27 08:23:52 ferrieux Exp $ +# RCS: @(#) $Id: parse.test,v 1.37 2009/09/04 17:33:12 dgp Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -896,7 +896,7 @@ test parse-15.60 {CommandComplete procedure} { } 0 test parse-16.1 {Tcl_EvalEx, check termOffset is set correctly for non TCL_OK cases, bug 2535} { - subst {[eval {return foo}]bar} + set subst subst; $subst {[eval {return foo}]bar} } foobar test parse-17.1 {Correct return codes from errors during substitution} { @@ -1043,7 +1043,7 @@ test parse-19.3 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup { i eval {proc {} args {}} interp recursionlimit i 3 } -body { - i eval {subst {[]}} + i eval {set subst subst; $subst {[]}} } -cleanup { interp delete i } @@ -1053,7 +1053,7 @@ test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup { i eval {proc {} args {}} interp recursionlimit i 2 } -body { - i eval {subst {[[]]}} + i eval {set subst subst; $subst {[[]]}} } -cleanup { interp delete i } -returnCodes error -match glob -result {too many nested*} |