Attachment "2314561.patch" to
ticket [2314561fff]
added by
dgp
2009-09-05 00:21:39.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.402
diff -u -r1.402 tclBasic.c
--- generic/tclBasic.c 25 Aug 2009 21:03:25 -0000 1.402
+++ generic/tclBasic.c 4 Sep 2009 17:17:13 -0000
@@ -213,7 +213,7 @@
{"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},
Index: generic/tclCmdMZ.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdMZ.c,v
retrieving revision 1.191
diff -u -r1.191 tclCmdMZ.c
--- generic/tclCmdMZ.c 25 Aug 2009 21:03:25 -0000 1.191
+++ generic/tclCmdMZ.c 4 Sep 2009 17:17:13 -0000
@@ -3373,30 +3373,24 @@
*/
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_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;
Index: generic/tclCompCmds.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompCmds.c,v
retrieving revision 1.153
diff -u -r1.153 tclCompCmds.c
--- generic/tclCompCmds.c 25 Aug 2009 21:03:25 -0000 1.153
+++ generic/tclCompCmds.c 4 Sep 2009 17:17:14 -0000
@@ -3844,6 +3844,275 @@
/*
*----------------------------------------------------------------------
*
+ * 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.
Index: generic/tclCompile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.c,v
retrieving revision 1.172
diff -u -r1.172 tclCompile.c
--- generic/tclCompile.c 25 Aug 2009 23:20:36 -0000 1.172
+++ generic/tclCompile.c 4 Sep 2009 17:17:14 -0000
@@ -399,6 +399,13 @@
* 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 @@
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 @@
* '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 @@
} 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 @@
*/
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 @@
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 @@
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 @@
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;
Index: generic/tclCompile.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.h,v
retrieving revision 1.118
diff -u -r1.118 tclCompile.h
--- generic/tclCompile.h 25 Aug 2009 21:03:25 -0000 1.118
+++ generic/tclCompile.h 4 Sep 2009 17:17:15 -0000
@@ -666,8 +666,12 @@
#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 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,
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.444
diff -u -r1.444 tclExecute.c
--- generic/tclExecute.c 12 Aug 2009 16:06:43 -0000 1.444
+++ generic/tclExecute.c 4 Sep 2009 17:17:16 -0000
@@ -2493,6 +2493,10 @@
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 @@
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;
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.439
diff -u -r1.439 tclInt.h
--- generic/tclInt.h 4 Sep 2009 09:38:20 -0000 1.439
+++ generic/tclInt.h 4 Sep 2009 17:17:17 -0000
@@ -2950,6 +2950,11 @@
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 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);
Index: generic/tclParse.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclParse.c,v
retrieving revision 1.79
diff -u -r1.79 tclParse.c
--- generic/tclParse.c 25 Aug 2009 23:20:36 -0000 1.79
+++ generic/tclParse.c 4 Sep 2009 17:17:17 -0000
@@ -1880,18 +1880,17 @@
*----------------------------------------------------------------------
*/
-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 @@
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_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 @@
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_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 @@
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;
}
Index: tests/basic.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/basic.test,v
retrieving revision 1.44
diff -u -r1.44 basic.test
--- tests/basic.test 20 Apr 2007 05:51:11 -0000 1.44
+++ tests/basic.test 4 Sep 2009 17:17:18 -0000
@@ -632,7 +632,7 @@
(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
Index: tests/info.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/info.test,v
retrieving revision 1.65
diff -u -r1.65 info.test
--- tests/info.test 25 Aug 2009 21:03:25 -0000 1.65
+++ tests/info.test 4 Sep 2009 17:17:18 -0000
@@ -1525,12 +1525,12 @@
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 @@
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
Index: tests/parse.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/parse.test,v
retrieving revision 1.36
diff -u -r1.36 parse.test
--- tests/parse.test 27 Nov 2008 08:23:52 -0000 1.36
+++ tests/parse.test 4 Sep 2009 17:17:18 -0000
@@ -896,7 +896,7 @@
} 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 @@
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 @@
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*}
