diff options
| -rw-r--r-- | ChangeLog | 17 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 569 | ||||
| -rw-r--r-- | generic/tclCompExpr.c | 17 | ||||
| -rw-r--r-- | generic/tclCompile.c | 264 | ||||
| -rw-r--r-- | generic/tclCompile.h | 10 | ||||
| -rw-r--r-- | generic/tclInt.h | 23 | ||||
| -rw-r--r-- | generic/tclProc.c | 9 | ||||
| -rw-r--r-- | tests/compExpr-old.test | 92 | ||||
| -rw-r--r-- | tests/compExpr.test | 10 | ||||
| -rw-r--r-- | tests/expr.test | 90 | ||||
| -rw-r--r-- | tests/for.test | 58 | ||||
| -rw-r--r-- | tests/if.test | 52 | ||||
| -rw-r--r-- | tests/incr.test | 44 | ||||
| -rw-r--r-- | tests/while.test | 28 |
14 files changed, 410 insertions, 873 deletions
@@ -1,3 +1,20 @@ +2004-09-26 Miguel Sofer <msofer@users.sf.net> + + * generic/tclCompCmds.c: + * generic/tclCompExpr.c: + * generic/tclCompile.c: + * generic/tclCompile.h: + * generic/tclInt.h: + * generic/tclProc.c: + * tests/compExpr-old.test: + * tests/compExpr.test: + * tests/expr.test: + * tests/for.test: + * tests/if.test: + * tests/incr.test: + * tests/while.test: + Report compilation errors at runtime, [Patch 103368] by dgp. + 2004-09-23 Mo DeJong <mdejong@users.sourceforge.net> * unix/dltest/Makefile.in (clean): Fixup make clean diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 486beaa..99a98c0 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.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: tclCompCmds.c,v 1.57 2004/09/22 03:19:52 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.58 2004/09/26 16:36:04 msofer Exp $ */ #include "tclInt.h" @@ -23,12 +23,12 @@ static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData)); -static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp, +static int PushVarName _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr)); /* - * Flags bits used by TclPushVarName. + * Flags bits used by PushVarName. */ #define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */ @@ -52,13 +52,8 @@ AuxDataType tclForeachInfoType = { * Procedure called to compile the "append" command. * * Results: - * The return value is a standard Tcl result, which is normally TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. If - * complation fails because the command requires a second level of - * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the - * command should be compiled "out of line" by emitting code to - * invoke its command procedure (Tcl_AppendObjCmd) at runtime. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "append" command @@ -76,7 +71,6 @@ TclCompileAppendCmd(interp, parsePtr, envPtr) { Tcl_Token *varTokenPtr, *valueTokenPtr; int simpleVarName, isScalar, localIndex, numWords; - int code = TCL_OK; numWords = parsePtr->numWords; if (numWords == 1) { @@ -104,11 +98,8 @@ TclCompileAppendCmd(interp, parsePtr, envPtr) varTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); - if (code != TCL_OK) { - goto done; - } /* * We are doing an assignment, otherwise TclCompileSetCmd was called, @@ -122,11 +113,8 @@ TclCompileAppendCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); } else { - code = TclCompileTokens(interp, valueTokenPtr+1, + TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } } } @@ -160,8 +148,7 @@ TclCompileAppendCmd(interp, parsePtr, envPtr) TclEmitOpcode(INST_APPEND_STK, envPtr); } - done: - return code; + return TCL_OK; } /* @@ -172,9 +159,8 @@ TclCompileAppendCmd(interp, parsePtr, envPtr) * Procedure called to compile the "break" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error during compilation. If an error occurs then - * the interpreter's result contains a standard error message. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "break" command @@ -191,10 +177,7 @@ TclCompileBreakCmd(interp, parsePtr, envPtr) CompileEnv *envPtr; /* Holds resulting instructions. */ { if (parsePtr->numWords != 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"break\"", -1); - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } /* @@ -213,13 +196,8 @@ TclCompileBreakCmd(interp, parsePtr, envPtr) * Procedure called to compile the "catch" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If the command is too complex for TclCompileCatchCmd, - * TCL_OUT_LINE_COMPILE is returned indicating that the catch command - * should be compiled "out of line" by emitting code to invoke its - * command procedure at runtime. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "catch" command @@ -239,7 +217,6 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) Tcl_Token *cmdTokenPtr, *nameTokenPtr; CONST char *name; int localIndex, nameChars, range, startOffset; - int code; int savedStackDepth = envPtr->currStackDepth; /* @@ -307,19 +284,14 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { startOffset = (envPtr->codeNext - envPtr->codeStart); - code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr); + TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr); } else { - code = TclCompileTokens(interp, cmdTokenPtr+1, + TclCompileTokens(interp, cmdTokenPtr+1, cmdTokenPtr->numComponents, envPtr); startOffset = (envPtr->codeNext - envPtr->codeStart); TclEmitOpcode(INST_EVAL_STK, envPtr); } envPtr->exceptArrayPtr[range].codeOffset = startOffset; - - if (code != TCL_OK) { - code = TCL_OUT_LINE_COMPILE; - goto done; - } envPtr->exceptArrayPtr[range].numCodeBytes = (envPtr->codeNext - envPtr->codeStart) - startOffset; @@ -372,10 +344,9 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) } TclEmitOpcode(INST_END_CATCH, envPtr); - done: envPtr->currStackDepth = savedStackDepth + 1; envPtr->exceptDepth--; - return code; + return TCL_OK; } /* @@ -386,9 +357,8 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) * Procedure called to compile the "continue" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "continue" command @@ -409,10 +379,7 @@ TclCompileContinueCmd(interp, parsePtr, envPtr) */ if (parsePtr->numWords != 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"continue\"", -1); - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } /* @@ -431,9 +398,8 @@ TclCompileContinueCmd(interp, parsePtr, envPtr) * Procedure called to compile the "expr" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "expr" command @@ -452,16 +418,13 @@ TclCompileExprCmd(interp, parsePtr, envPtr) Tcl_Token *firstWordPtr; if (parsePtr->numWords == 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"expr arg ?arg ...?\"", -1); - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } firstWordPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1), - envPtr); + TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1), envPtr); + return TCL_OK; } /* @@ -472,9 +435,8 @@ TclCompileExprCmd(interp, parsePtr, envPtr) * Procedure called to compile the "for" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "for" command @@ -492,15 +454,11 @@ TclCompileForCmd(interp, parsePtr, envPtr) Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; - int bodyRange, nextRange, code; - char buffer[32 + TCL_INTEGER_SPACE]; + int bodyRange, nextRange; int savedStackDepth = envPtr->currStackDepth; if (parsePtr->numWords != 5) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"for start test next command\"", -1); - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } /* @@ -544,15 +502,8 @@ TclCompileForCmd(interp, parsePtr, envPtr) * Inline compile the initial command. */ - code = TclCompileCmdWord(interp, startTokenPtr+1, + TclCompileCmdWord(interp, startTokenPtr+1, startTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"for\" initial command)", -1); - } - goto done; - } TclEmitOpcode(INST_POP, envPtr); /* @@ -575,17 +526,9 @@ TclCompileForCmd(interp, parsePtr, envPtr) bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart); - code = TclCompileCmdWord(interp, bodyTokenPtr+1, + TclCompileCmdWord(interp, bodyTokenPtr+1, bodyTokenPtr->numComponents, envPtr); envPtr->currStackDepth = savedStackDepth + 1; - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"for\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto done; - } envPtr->exceptArrayPtr[bodyRange].numCodeBytes = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; TclEmitOpcode(INST_POP, envPtr); @@ -598,16 +541,9 @@ TclCompileForCmd(interp, parsePtr, envPtr) nextCodeOffset = (envPtr->codeNext - envPtr->codeStart); envPtr->currStackDepth = savedStackDepth; - code = TclCompileCmdWord(interp, nextTokenPtr+1, + TclCompileCmdWord(interp, nextTokenPtr+1, nextTokenPtr->numComponents, envPtr); envPtr->currStackDepth = savedStackDepth + 1; - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"for\" loop-end command)", -1); - } - goto done; - } envPtr->exceptArrayPtr[nextRange].numCodeBytes = (envPtr->codeNext - envPtr->codeStart) - nextCodeOffset; @@ -629,14 +565,7 @@ TclCompileForCmd(interp, parsePtr, envPtr) } envPtr->currStackDepth = savedStackDepth; - code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"for\" test expression)", -1); - } - goto done; - } + TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; @@ -665,11 +594,9 @@ TclCompileForCmd(interp, parsePtr, envPtr) envPtr->currStackDepth = savedStackDepth; TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); - code = TCL_OK; - done: envPtr->exceptDepth--; - return code; + return TCL_OK; } /* @@ -680,13 +607,8 @@ TclCompileForCmd(interp, parsePtr, envPtr) * Procedure called to compile the "foreach" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If the command is too complex for TclCompileForeachCmd, - * TCL_OUT_LINE_COMPILE is returned indicating that the foreach command - * should be compiled "out of line" by emitting code to invoke its - * command procedure at runtime. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "foreach" command @@ -715,7 +637,6 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) JumpFixup jumpFalseFixup; int jumpBackDist, jumpBackOffset, infoIndex, range; int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; - char buffer[32 + TCL_INTEGER_SPACE]; int savedStackDepth = envPtr->currStackDepth; /* @@ -741,10 +662,7 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) numWords = parsePtr->numWords; if ((numWords < 4) || (numWords%2 != 0)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1); - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } /* @@ -809,6 +727,7 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) &varcList[loopIndex], &varvList[loopIndex]); Tcl_DStringFree(&varList); if (code != TCL_OK) { + code = TCL_OUT_LINE_COMPILE; goto done; } numVars = varcList[loopIndex]; @@ -833,6 +752,7 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) * nonoverlapping foreach loops, they don't share any temps. */ + code = TCL_OK; firstValueTemp = -1; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, @@ -882,11 +802,8 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) i < numWords-1; i++, tokenPtr += (tokenPtr->numComponents + 1)) { if ((i%2 == 0) && (i > 0)) { - code = TclCompileTokens(interp, tokenPtr+1, + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } tempVar = (firstValueTemp + loopIndex); if (tempVar <= 255) { @@ -921,17 +838,9 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) envPtr->exceptArrayPtr[range].codeOffset = (envPtr->codeNext - envPtr->codeStart); - code = TclCompileCmdWord(interp, bodyTokenPtr+1, + TclCompileCmdWord(interp, bodyTokenPtr+1, bodyTokenPtr->numComponents, envPtr); envPtr->currStackDepth = savedStackDepth + 1; - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"foreach\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto done; - } envPtr->exceptArrayPtr[range].numCodeBytes = (envPtr->codeNext - envPtr->codeStart) - envPtr->exceptArrayPtr[range].codeOffset; @@ -1104,13 +1013,8 @@ FreeForeachInfo(clientData) * Procedure called to compile the "if" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If the command is too complex for TclCompileIfCmd, - * TCL_OUT_LINE_COMPILE is returned indicating that the if command - * should be compiled "out of line" by emitting code to invoke its - * command procedure at runtime. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "if" command @@ -1137,7 +1041,6 @@ TclCompileIfCmd(interp, parsePtr, envPtr) int jumpIndex = 0; /* avoid compiler warning. */ int numWords, wordIdx, numBytes, j, code; CONST char *word; - char buffer[100]; int savedStackDepth = envPtr->currStackDepth; /* Saved stack depth at the start of the first * test; the envPtr current depth is restored @@ -1189,12 +1092,7 @@ TclCompileIfCmd(interp, parsePtr, envPtr) break; } if (wordIdx >= numWords) { - sprintf(buffer, - "wrong # args: no expression after \"%.*s\" argument", - (numBytes > 50 ? 50 : numBytes), word); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); - code = TCL_ERROR; + code = TCL_OUT_LINE_COMPILE; goto done; } @@ -1227,14 +1125,7 @@ TclCompileIfCmd(interp, parsePtr, envPtr) } } else { Tcl_ResetResult(interp); - code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"if\" test expression)", -1); - } - goto done; - } + TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } @@ -1243,6 +1134,7 @@ TclCompileIfCmd(interp, parsePtr, envPtr) TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpFalseFixupArray.fixup[jumpIndex])); } + code = TCL_OK; } @@ -1253,13 +1145,7 @@ TclCompileIfCmd(interp, parsePtr, envPtr) tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); wordIdx++; if (wordIdx >= numWords) { - sprintf(buffer, - "wrong # args: no script following \"%.*s\" argument", - (testTokenPtr->size > 50 ? 50 : testTokenPtr->size), - testTokenPtr->start); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); - code = TCL_ERROR; + code = TCL_OUT_LINE_COMPILE; goto done; } if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { @@ -1269,10 +1155,7 @@ TclCompileIfCmd(interp, parsePtr, envPtr) tokenPtr += (tokenPtr->numComponents + 1); wordIdx++; if (wordIdx >= numWords) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no script following \"then\" argument", -1); - code = TCL_ERROR; + code = TCL_OUT_LINE_COMPILE; goto done; } } @@ -1284,16 +1167,8 @@ TclCompileIfCmd(interp, parsePtr, envPtr) if (compileScripts) { envPtr->currStackDepth = savedStackDepth; - code = TclCompileCmdWord(interp, tokenPtr+1, + TclCompileCmdWord(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"if\" then script line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto done; - } } if (realCond) { @@ -1371,10 +1246,7 @@ TclCompileIfCmd(interp, parsePtr, envPtr) tokenPtr += (tokenPtr->numComponents + 1); wordIdx++; if (wordIdx >= numWords) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no script following \"else\" argument", -1); - code = TCL_ERROR; + code = TCL_OUT_LINE_COMPILE; goto done; } } @@ -1384,16 +1256,8 @@ TclCompileIfCmd(interp, parsePtr, envPtr) * Compile the else command body. */ - code = TclCompileCmdWord(interp, tokenPtr+1, + TclCompileCmdWord(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"if\" else script line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto done; - } } /* @@ -1402,10 +1266,7 @@ TclCompileIfCmd(interp, parsePtr, envPtr) wordIdx++; if (wordIdx < numWords) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: extra words after \"else\" clause in \"if\" command", -1); - code = TCL_ERROR; + code = TCL_OUT_LINE_COMPILE; goto done; } } else { @@ -1467,13 +1328,8 @@ TclCompileIfCmd(interp, parsePtr, envPtr) * Procedure called to compile the "incr" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If the command is too complex for TclCompileIncrCmd, - * TCL_OUT_LINE_COMPILE is returned indicating that the incr command - * should be compiled "out of line" by emitting code to invoke its - * command procedure at runtime. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "incr" command @@ -1491,24 +1347,17 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) { Tcl_Token *varTokenPtr, *incrTokenPtr; int simpleVarName, isScalar, localIndex, haveImmValue, immValue; - int code = TCL_OK; if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"incr varName ?increment?\"", -1); - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } varTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - code = TclPushVarName(interp, varTokenPtr, envPtr, + PushVarName(interp, varTokenPtr, envPtr, (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR), &localIndex, &simpleVarName, &isScalar); - if (code != TCL_OK) { - goto done; - } /* * If an increment is given, push it, but see first if it's a small @@ -1548,11 +1397,8 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) TclRegisterNewLiteral(envPtr, word, numBytes), envPtr); } } else { - code = TclCompileTokens(interp, incrTokenPtr+1, + TclCompileTokens(interp, incrTokenPtr+1, incrTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } } } else { /* no incr amount given so use 1 */ haveImmValue = 1; @@ -1603,8 +1449,7 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) } } - done: - return code; + return TCL_OK; } /* @@ -1615,13 +1460,8 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) * Procedure called to compile the "lappend" command. * * Results: - * The return value is a standard Tcl result, which is normally TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. If - * complation fails because the command requires a second level of - * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the - * command should be compiled "out of line" by emitting code to - * invoke its command procedure (Tcl_LappendObjCmd) at runtime. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lappend" command @@ -1639,7 +1479,6 @@ TclCompileLappendCmd(interp, parsePtr, envPtr) { Tcl_Token *varTokenPtr, *valueTokenPtr; int simpleVarName, isScalar, localIndex, numWords; - int code = TCL_OK; /* * If we're not in a procedure, don't compile. @@ -1650,10 +1489,7 @@ TclCompileLappendCmd(interp, parsePtr, envPtr) numWords = parsePtr->numWords; if (numWords == 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"lappend varName ?value value ...?\"", -1); - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } if (numWords != 3) { /* @@ -1673,11 +1509,8 @@ TclCompileLappendCmd(interp, parsePtr, envPtr) varTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); - if (code != TCL_OK) { - goto done; - } /* * If we are doing an assignment, push the new value. @@ -1690,11 +1523,8 @@ TclCompileLappendCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); } else { - code = TclCompileTokens(interp, valueTokenPtr+1, + TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } } } @@ -1732,8 +1562,7 @@ TclCompileLappendCmd(interp, parsePtr, envPtr) TclEmitOpcode(INST_LAPPEND_STK, envPtr); } - done: - return code; + return TCL_OK; } /* @@ -1744,12 +1573,8 @@ TclCompileLappendCmd(interp, parsePtr, envPtr) * Procedure called to compile the "lassign" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if the - * compilation was successful. If the command cannot be byte-compiled, - * TCL_OUT_LINE_COMPILE is returned, indicating that the command should - * be compiled "out of line" by emitting code to invoke its command - * procedure (Tcl_LassignObjCmd) at runtime, which enforces in correct - * error handling. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lassign" command @@ -1766,7 +1591,7 @@ TclCompileLassignCmd(interp, parsePtr, envPtr) CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int simpleVarName, isScalar, localIndex, numWords, code, idx; + int simpleVarName, isScalar, localIndex, numWords, idx; numWords = parsePtr->numWords; /* @@ -1784,11 +1609,7 @@ TclCompileLassignCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size), envPtr); } else { - code = TclCompileTokens(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); } /* @@ -1800,11 +1621,8 @@ TclCompileLassignCmd(interp, parsePtr, envPtr) /* * Generate the next variable name */ - code = TclPushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, + PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); - if (code != TCL_OK) { - return code; - } /* * Emit instructions to get the idx'th item out of the list @@ -1865,11 +1683,8 @@ TclCompileLassignCmd(interp, parsePtr, envPtr) * Procedure called to compile the "lindex" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if the - * compilation was successful. If the command cannot be byte-compiled, - * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the - * interpreter's result contains an error message, and TCL_ERROR is - * returned. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lindex" command @@ -1886,9 +1701,7 @@ TclCompileLindexCmd(interp, parsePtr, envPtr) CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int code, i; - - int numWords; + int i, numWords; numWords = parsePtr->numWords; /* @@ -1912,11 +1725,8 @@ TclCompileLindexCmd(interp, parsePtr, envPtr) TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { - code = TclCompileTokens(interp, varTokenPtr+1, + TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } } varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } @@ -1943,13 +1753,8 @@ TclCompileLindexCmd(interp, parsePtr, envPtr) * Procedure called to compile the "list" command. * * Results: - * The return value is a standard Tcl result, which is normally TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. If - * complation fails because the command requires a second level of - * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the - * command should be compiled "out of line" by emitting code to - * invoke its command procedure (Tcl_ListObjCmd) at runtime. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "list" command @@ -1983,7 +1788,7 @@ TclCompileListCmd(interp, parsePtr, envPtr) * Push the all values onto the stack. */ Tcl_Token *valueTokenPtr; - int i, code, numWords; + int i, numWords; numWords = parsePtr->numWords; @@ -1994,11 +1799,8 @@ TclCompileListCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); } else { - code = TclCompileTokens(interp, valueTokenPtr+1, + TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } } valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1); } @@ -2016,11 +1818,8 @@ TclCompileListCmd(interp, parsePtr, envPtr) * Procedure called to compile the "llength" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if the - * compilation was successful. If the command cannot be byte-compiled, - * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the - * interpreter's result contains an error message, and TCL_ERROR is - * returned. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "llength" command @@ -2037,12 +1836,9 @@ TclCompileLlengthCmd(interp, parsePtr, envPtr) CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int code; if (parsePtr->numWords != 2) { - Tcl_SetResult(interp, "wrong # args: should be \"llength list\"", - TCL_STATIC); - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } varTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); @@ -2055,11 +1851,8 @@ TclCompileLlengthCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { - code = TclCompileTokens(interp, varTokenPtr+1, + TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } } TclEmitOpcode(INST_LIST_LENGTH, envPtr); return TCL_OK; @@ -2073,12 +1866,8 @@ TclCompileLlengthCmd(interp, parsePtr, envPtr) * Procedure called to compile the "lset" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * the compilation was successful. If the "lset" command is too - * complex for this function, then TCL_OUT_LINE_COMPILE is returned, - * indicating that the command should be compiled "out of line" - * (that is, not byte-compiled). If an error occurs, TCL_ERROR is - * returned, and the interpreter result contains an error message. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lset" command @@ -2120,7 +1909,6 @@ TclCompileLsetCmd(interp, parsePtr, envPtr) * of the code burst. */ Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing * the parse of the variable name */ - int result; /* Status return from library calls */ int localIndex; /* Index of var in local var table */ int simpleVarName; /* Flag == 1 if var name is simple */ int isScalar; /* Flag == 1 if scalar, 0 if array */ @@ -2143,11 +1931,8 @@ TclCompileLsetCmd(interp, parsePtr, envPtr) varTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - result = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); - if (result != TCL_OK) { - return result; - } /* Push the "index" args and the new element value. */ @@ -2162,11 +1947,8 @@ TclCompileLsetCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { - result = TclCompileTokens(interp, varTokenPtr+1, + TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); - if (result != TCL_OK) { - return result; - } } } @@ -2265,12 +2047,8 @@ TclCompileLsetCmd(interp, parsePtr, envPtr) * Procedure called to compile the "regexp" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * the compilation was successful. If the "regexp" command is too - * complex for this function, then TCL_OUT_LINE_COMPILE is returned, - * indicating that the command should be compiled "out of line" - * (that is, not byte-compiled). If an error occurs, TCL_ERROR is - * returned, and the interpreter result contains an error message. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "regexp" command @@ -2288,7 +2066,7 @@ TclCompileRegexpCmd(interp, parsePtr, envPtr) { Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing * the parse of the RE or string */ - int i, len, code, nocase, anchorLeft, anchorRight, start; + int i, len, nocase, anchorLeft, anchorRight, start; char *str; /* @@ -2438,11 +2216,8 @@ TclCompileRegexpCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { - code = TclCompileTokens(interp, varTokenPtr+1, + TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } } if (anchorLeft && anchorRight && !nocase) { @@ -2462,10 +2237,8 @@ TclCompileRegexpCmd(interp, parsePtr, envPtr) * Procedure called to compile the "return" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if the - * compilation was successful. If analysis concludes that the - * command cannot be bytecompiled effectively, a return code of - * TCL__OUT_LINE_COMPILE is returned. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "return" command @@ -2541,11 +2314,8 @@ TclCompileReturnCmd(interp, parsePtr, envPtr) wordTokenPtr[1].size), envPtr); } else { /* More complex tokens get compiled */ - status = TclCompileTokens(interp, wordTokenPtr+1, + TclCompileTokens(interp, wordTokenPtr+1, wordTokenPtr->numComponents, envPtr); - if (TCL_OK != status) { - return status; - } } } else { /* No explict result argument, so default result is empty string */ @@ -2600,13 +2370,8 @@ TclCompileReturnCmd(interp, parsePtr, envPtr) * Procedure called to compile the "set" command. * * Results: - * The return value is a standard Tcl result, which is normally TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. If - * complation fails because the set command requires a second level of - * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the - * set command should be compiled "out of line" by emitting code to - * invoke its command procedure (Tcl_SetCmd) at runtime. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "set" command @@ -2624,14 +2389,10 @@ TclCompileSetCmd(interp, parsePtr, envPtr) { Tcl_Token *varTokenPtr, *valueTokenPtr; int isAssignment, isScalar, simpleVarName, localIndex, numWords; - int code = TCL_OK; numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"set varName ?newValue?\"", -1); - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } isAssignment = (numWords == 3); @@ -2646,11 +2407,8 @@ TclCompileSetCmd(interp, parsePtr, envPtr) varTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); - if (code != TCL_OK) { - goto done; - } /* * If we are doing an assignment, push the new value. @@ -2662,11 +2420,8 @@ TclCompileSetCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); } else { - code = TclCompileTokens(interp, valueTokenPtr+1, + TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } } } @@ -2710,8 +2465,7 @@ TclCompileSetCmd(interp, parsePtr, envPtr) TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); } - done: - return code; + return TCL_OK; } /* @@ -2722,11 +2476,8 @@ TclCompileSetCmd(interp, parsePtr, envPtr) * Procedure called to compile the "string" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if the - * compilation was successful. If the command cannot be byte-compiled, - * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the - * interpreter's result contains an error message, and TCL_ERROR is - * returned. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "string" command @@ -2745,7 +2496,6 @@ TclCompileStringCmd(interp, parsePtr, envPtr) Tcl_Token *opTokenPtr, *varTokenPtr; Tcl_Obj *opObj; int index; - int code; static CONST char *options[] = { "bytelength", "compare", "equal", "first", @@ -2825,11 +2575,8 @@ TclCompileStringCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { - code = TclCompileTokens(interp, varTokenPtr+1, + TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } } varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } @@ -2855,11 +2602,8 @@ TclCompileStringCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { - code = TclCompileTokens(interp, varTokenPtr+1, + TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } } varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } @@ -2885,11 +2629,8 @@ TclCompileStringCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr); return TCL_OK; } else { - code = TclCompileTokens(interp, varTokenPtr+1, + TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } } TclEmitOpcode(INST_STR_LEN, envPtr); return TCL_OK; @@ -2942,11 +2683,8 @@ TclCompileStringCmd(interp, parsePtr, envPtr) TclEmitPush( TclRegisterNewLiteral(envPtr, str, length), envPtr); } else { - code = TclCompileTokens(interp, varTokenPtr+1, + TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } } varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } @@ -2971,15 +2709,8 @@ TclCompileStringCmd(interp, parsePtr, envPtr) * Procedure called to compile the "switch" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If compilation failed because the command is too - * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned - * indicating that the while command should be compiled "out of line" - * by emitting code to invoke its command procedure at runtime. Note - * that most errors actually return TCL_OUT_LINE_COMPILE because that - * allows the real error to be raised at run-time. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "switch" command @@ -3181,13 +2912,8 @@ TclCompileSwitchCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); } else { - int code = TclCompileTokens(interp, valueTokenPtr+1, + TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - ckfree((char *)argv); - ckfree((char *)bodyTokenArray); - return code; - } } /* @@ -3201,7 +2927,6 @@ TclCompileSwitchCmd(interp, parsePtr, envPtr) fixupCount = 0; foundDefault = 0; for (i=0 ; i<argc ; i+=2) { - int code; /* Return codes from sub-compiles. */ int nextArmFixupIndex = -1; /* @@ -3276,25 +3001,7 @@ TclCompileSwitchCmd(interp, parsePtr, envPtr) TclEmitOpcode(INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth + 1; - code = TclCompileScript(interp, bodyTokenArray[i+1].start, - bodyTokenArray[i+1].size, envPtr); - if (code != TCL_OK) { - ckfree((char *)bodyTokenArray); - ckfree((char *)fixupArray); - ckfree((char *)fixupTargetArray); - - if (code == TCL_ERROR) { - char *errInfBuf = - ckalloc(strlen(argv[i])+40+TCL_INTEGER_SPACE); - - sprintf(errInfBuf, "\n (\"%s\" arm line %d)", - argv[i], interp->errorLine); - Tcl_AddObjErrorInfo(interp, errInfBuf, -1); - ckfree(errInfBuf); - } - ckfree((char *)argv); - return code; - } + TclCompileCmdWord(interp, bodyTokenArray+i+1, 1, envPtr); if (!foundDefault) { TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, @@ -3415,13 +3122,8 @@ TclCompileVariableCmd(interp, parsePtr, envPtr) * Procedure called to compile the "while" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If compilation failed because the command is too - * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned - * indicating that the while command should be compiled "out of line" - * by emitting code to invoke its command procedure at runtime. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "while" command @@ -3441,7 +3143,6 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, jumpDist; int range, code; - char buffer[32 + TCL_INTEGER_SPACE]; int savedStackDepth = envPtr->currStackDepth; int loopMayEnd = 1; /* This is set to 0 if it is recognized as * an infinite loop. */ @@ -3449,10 +3150,7 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) int boolVal; if (parsePtr->numWords != 3) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"while test command\"", -1); - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } /* @@ -3533,17 +3231,9 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) */ bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart); - code = TclCompileCmdWord(interp, bodyTokenPtr+1, + TclCompileCmdWord(interp, bodyTokenPtr+1, bodyTokenPtr->numComponents, envPtr); envPtr->currStackDepth = savedStackDepth + 1; - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"while\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto error; - } envPtr->exceptArrayPtr[range].numCodeBytes = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; TclEmitOpcode(INST_POP, envPtr); @@ -3561,14 +3251,7 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) testCodeOffset += 3; } envPtr->currStackDepth = savedStackDepth; - code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"while\" test expression)", -1); - } - goto error; - } + TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; @@ -3605,24 +3288,19 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); envPtr->exceptDepth--; return TCL_OK; - - error: - envPtr->exceptDepth--; - return code; } /* *---------------------------------------------------------------------- * - * TclPushVarName -- + * PushVarName -- * * Procedure used in the compiling where pushing a variable name * is necessary (append, lappend, set). * * Results: - * The return value is a standard Tcl result, which is normally TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. + * Returns TCL_OK for a successful compile. + * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "set" command @@ -3632,7 +3310,7 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) */ static int -TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, +PushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, simpleVarNamePtr, isScalarPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Token *varTokenPtr; /* Points to a variable token. */ @@ -3647,7 +3325,6 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, CONST char *name, *elName; register int i, n; int nameChars, elNameChars, simpleVarName, localIndex; - int code = TCL_OK; Tcl_Token *elemTokenPtr = NULL; int elemTokenCount = 0; @@ -3823,11 +3500,7 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, if (elName != NULL) { if (elNameChars) { - code = TclCompileTokens(interp, elemTokenPtr, - elemTokenCount, envPtr); - if (code != TCL_OK) { - goto done; - } + TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } @@ -3837,14 +3510,10 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, * The var name isn't simple: compile and push it. */ - code = TclCompileTokens(interp, varTokenPtr+1, + TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } } - done: if (removedParen) { ++varTokenPtr[removedParen].size; } @@ -3854,5 +3523,5 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, *localIndexPtr = localIndex; *simpleVarNamePtr = simpleVarName; *isScalarPtr = (elName == NULL); - return code; + return TCL_OK; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 84e0cac..33e4c09 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -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: tclCompExpr.c,v 1.22 2004/04/06 22:25:50 dgp Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.23 2004/09/26 16:36:04 msofer Exp $ */ #include "tclInt.h" @@ -365,11 +365,8 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) tokenPtr->start, tokenPtr->size); switch (tokenPtr->type) { case TCL_TOKEN_WORD: - code = TclCompileTokens(interp, tokenPtr+1, + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } tokenPtr += (tokenPtr->numComponents + 1); break; @@ -397,19 +394,13 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) break; case TCL_TOKEN_COMMAND: - code = TclCompileScript(interp, tokenPtr->start+1, + TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); - if (code != TCL_OK) { - goto done; - } tokenPtr += 1; break; case TCL_TOKEN_VARIABLE: - code = TclCompileTokens(interp, tokenPtr, 1, envPtr); - if (code != TCL_OK) { - goto done; - } + TclCompileTokens(interp, tokenPtr, 1, envPtr); tokenPtr += (tokenPtr->numComponents + 1); break; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f02b29d..7b79e66 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.74 2004/09/23 00:34:31 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.75 2004/09/26 16:36:04 msofer Exp $ */ #include "tclInt.h" @@ -317,9 +317,6 @@ static void FreeByteCodeInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); static int GetCmdLocEncodingSize _ANSI_ARGS_(( CompileEnv *envPtr)); -static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *script, CONST char *command, - int length)); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats _ANSI_ARGS_(( ByteCode *codePtr)); @@ -383,7 +380,7 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) register AuxData *auxDataPtr; LiteralEntry *entryPtr; register int i; - int length, result; + int length, result = TCL_OK; char *string; #ifdef TCL_COMPILE_DEBUG @@ -398,43 +395,41 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) string = Tcl_GetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, string, length); - result = TclCompileScript(interp, string, length, &compEnv); + TclCompileScript(interp, string, length, &compEnv); - if (result == TCL_OK) { - /* - * Successful compilation. Add a "done" instruction at the end. - */ + /* + * Successful compilation. Add a "done" instruction at the end. + */ - TclEmitOpcode(INST_DONE, &compEnv); + TclEmitOpcode(INST_DONE, &compEnv); - /* - * Invoke the compilation hook procedure if one exists. - */ + /* + * Invoke the compilation hook procedure if one exists. + */ - if (hookProc) { - result = (*hookProc)(interp, &compEnv, clientData); - } + if (hookProc) { + result = (*hookProc)(interp, &compEnv, clientData); + } - /* - * Change the object into a ByteCode object. Ownership of the literal - * objects and aux data items is given to the ByteCode object. - */ + /* + * Change the object into a ByteCode object. Ownership of the literal + * objects and aux data items is given to the ByteCode object. + */ #ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(&compEnv); + TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ - TclInitByteCodeObj(objPtr, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - } -#endif /* TCL_COMPILE_DEBUG */ + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); } +#endif /* TCL_COMPILE_DEBUG */ if (result != TCL_OK) { /* - * Compilation errors. + * Handle any error from the hookProc */ entryPtr = compEnv.literalArrayPtr; @@ -896,7 +891,7 @@ TclWordKnownAtCompileTime(tokenPtr, valuePtr) *---------------------------------------------------------------------- */ -int +void TclCompileScript(interp, script, numBytes, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. * Also serves as context for finding and @@ -987,7 +982,7 @@ TclCompileScript(interp, script, numBytes, envPtr) TclCompileReturnCmd(interp, &subParse, envPtr); Tcl_DecrRefCount(returnCmd); Tcl_FreeParse(&subParse); - return TCL_OK; + return; } gotParse = 1; if (parse.numWords > 0) { @@ -1002,7 +997,8 @@ TclCompileScript(interp, script, numBytes, envPtr) if (!isFirstCmd) { TclEmitOpcode(INST_POP, envPtr); envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - startCodeOffset; + (envPtr->codeNext - envPtr->codeStart) + - startCodeOffset; } /* @@ -1118,30 +1114,27 @@ TclCompileScript(interp, script, numBytes, envPtr) /* * Fix the bytecode length. */ - unsigned char *fixPtr = envPtr->codeStart + savedCodeNext + 1; - unsigned int fixLen = envPtr->codeNext - envPtr->codeStart - - savedCodeNext; + unsigned char *fixPtr = envPtr->codeStart + + savedCodeNext + 1; + unsigned int fixLen = envPtr->codeNext + - envPtr->codeStart + - savedCodeNext; TclStoreInt4AtPtr(fixLen, fixPtr); } goto finishCommand; } else if (code == TCL_OUT_LINE_COMPILE) { /* - * Restore numCommands and codeNext to their correct - * values, removing any commands compiled before - * TCL_OUT_LINE_COMPILE [Bugs 705406 and 735055] + * Restore numCommands and codeNext to their + * correct values, removing any commands + * compiled before TCL_OUT_LINE_COMPILE + * [Bugs 705406 and 735055] */ envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; + envPtr->codeNext = envPtr->codeStart + + savedCodeNext; } else { /* an error */ - /* - * There was a compilation error, the last - * command did not get compiled into (*envPtr). - * Decrement the number of commands - * claimed to be in (*envPtr). - */ - envPtr->numCommands--; - goto log; + Tcl_Panic("TclCompileScript: compileProc returned TCL_ERROR\n"); } } @@ -1177,11 +1170,8 @@ TclCompileScript(interp, script, numBytes, envPtr) * The word is not a simple string of characters. */ - code = TclCompileTokens(interp, tokenPtr+1, + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto log; - } } if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { TclEmitInstInt4(INST_EXPAND_STKTOP, @@ -1260,16 +1250,6 @@ TclCompileScript(interp, script, numBytes, envPtr) envPtr->numSrcBytes = (p - script); Tcl_DStringFree(&ds); - return TCL_OK; - - log: - LogCompilationInfo(interp, script, parse.commandStart, commandLength); - if (gotParse) { - Tcl_FreeParse(&parse); - } - envPtr->numSrcBytes = (p - script); - Tcl_DStringFree(&ds); - return code; } /* @@ -1293,7 +1273,7 @@ TclCompileScript(interp, script, numBytes, envPtr) *---------------------------------------------------------------------- */ -int +void TclCompileTokens(interp, tokenPtr, count, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens @@ -1307,7 +1287,7 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) char buffer[TCL_UTF_MAX]; CONST char *name, *p; int numObjsToConcat, nameBytes, localVarName, localVar; - int length, i, code; + int length, i; unsigned char *entryCodeNext = envPtr->codeNext; Tcl_DStringInit(&textBuffer); @@ -1341,11 +1321,8 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) Tcl_DStringFree(&textBuffer); } - code = TclCompileScript(interp, tokenPtr->start+1, + TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); - if (code != TCL_OK) { - goto error; - } numObjsToConcat++; break; @@ -1422,16 +1399,8 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) envPtr); } } else { - code = TclCompileTokens(interp, tokenPtr+2, + TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); - if (code != TCL_OK) { - char errorBuffer[150]; - sprintf(errorBuffer, - "\n (parsing index for array \"%.*s\")", - ((nameBytes > 100)? 100 : nameBytes), name); - Tcl_AddObjErrorInfo(interp, errorBuffer, -1); - goto error; - } if (localVar < 0) { TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); } else if (localVar <= 255) { @@ -1486,11 +1455,6 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) envPtr); } Tcl_DStringFree(&textBuffer); - return TCL_OK; - - error: - Tcl_DStringFree(&textBuffer); - return code; } /* @@ -1514,7 +1478,7 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) *---------------------------------------------------------------------- */ -int +void TclCompileCmdWord(interp, tokenPtr, count, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens @@ -1523,30 +1487,23 @@ TclCompileCmdWord(interp, tokenPtr, count, envPtr) * Must be at least 1. */ CompileEnv *envPtr; /* Holds the resulting instructions. */ { - int code; - - /* - * Handle the common case: if there is a single text token, compile it - * into an inline sequence of instructions. - */ - if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { - code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); - return code; - } - - /* - * Multiple tokens or the single token involves substitutions. Emit - * instructions to invoke the eval command procedure at runtime on the - * result of evaluating the tokens. - */ + /* + * Handle the common case: if there is a single text token, + * compile it into an inline sequence of instructions. + */ + + TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); + } else { + /* + * Multiple tokens or the single token involves substitutions. + * Emit instructions to invoke the eval command procedure at + * runtime on the result of evaluating the tokens. + */ - code = TclCompileTokens(interp, tokenPtr, count, envPtr); - if (code != TCL_OK) { - return code; + TclCompileTokens(interp, tokenPtr, count, envPtr); + TclEmitOpcode(INST_EVAL_STK, envPtr); } - TclEmitOpcode(INST_EVAL_STK, envPtr); - return TCL_OK; } /* @@ -1570,7 +1527,7 @@ TclCompileCmdWord(interp, tokenPtr, count, envPtr) *---------------------------------------------------------------------- */ -int +void TclCompileExprWords(interp, tokenPtr, numWords, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ Tcl_Token *tokenPtr; /* Points to first in an array of word @@ -1582,10 +1539,7 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) CompileEnv *envPtr; /* Holds the resulting instructions. */ { Tcl_Token *wordPtr; - int numBytes, i, code; - CONST char *script; - - code = TCL_OK; + int i, concatItems; /* * If the expression is a single word that doesn't require @@ -1593,10 +1547,16 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) */ if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { - script = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - code = TclCompileExpr(interp, script, numBytes, envPtr); - return code; + CONST char *script = tokenPtr[1].start; + int numBytes = tokenPtr[1].size; + int savedNumCmds = envPtr->numCommands; + unsigned int savedCodeNext = envPtr->codeNext - envPtr->codeStart; + + if (TclCompileExpr(interp, script, numBytes, envPtr) == TCL_OK) { + return; + } + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart + savedCodeNext; } /* @@ -1606,30 +1566,22 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { - code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, - envPtr); - if (code != TCL_OK) { - break; - } + TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); if (i < (numWords - 1)) { TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0), envPtr); } wordPtr += (wordPtr->numComponents + 1); } - if (code == TCL_OK) { - int concatItems = 2*numWords - 1; - while (concatItems > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); - concatItems -= 254; - } - if (concatItems > 1) { - TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); - } - TclEmitOpcode(INST_EXPR_STK, envPtr); + concatItems = 2*numWords - 1; + while (concatItems > 255) { + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + concatItems -= 254; } - - return code; + if (concatItems > 1) { + TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); + } + TclEmitOpcode(INST_EXPR_STK, envPtr); } /* @@ -1791,62 +1743,6 @@ TclInitByteCodeObj(objPtr, envPtr) /* *---------------------------------------------------------------------- * - * LogCompilationInfo -- - * - * This procedure is invoked after an error occurs during compilation. - * It adds information to the "errorInfo" variable to describe the - * command that was being compiled when the error occurred. - * - * Results: - * None. - * - * Side effects: - * Information about the command is added to errorInfo and the - * line number stored internally in the interpreter is set. If this - * is the first call to this procedure or Tcl_AddObjErrorInfo since - * an error occurred, then old information in errorInfo is - * deleted. - * - *---------------------------------------------------------------------- - */ - -static void -LogCompilationInfo(interp, script, command, length) - Tcl_Interp *interp; /* Interpreter in which to log the - * information. */ - CONST char *script; /* First character in script containing - * command (must be <= command). */ - CONST char *command; /* First character in command that - * generated the error. */ - int length; /* Number of bytes in command (-1 means - * use all bytes up to first null byte). */ -{ - register CONST char *p; - Interp *iPtr = (Interp *) interp; - Tcl_Obj *message; - - /* - * Compute the line number where the error occurred. - */ - - iPtr->errorLine = 1; - for (p = script; p != command; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - message = Tcl_NewStringObj("\n while compiling\n\"", -1); - Tcl_IncrRefCount(message); - TclAppendLimitedToObj(message, command, length, 153, NULL); - Tcl_AppendToObj(message, "\"", -1); - TclAppendObjToErrorInfo(interp, message); - Tcl_DecrRefCount(message); -} - -/* - *---------------------------------------------------------------------- - * * TclFindCompiledLocal -- * * This procedure is called at compile time to look up and optionally diff --git a/generic/tclCompile.h b/generic/tclCompile.h index e90454e..4654d2b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -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: tclCompile.h,v 1.47 2004/07/03 02:03:36 msofer Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.48 2004/09/26 16:36:04 msofer Exp $ */ #ifndef _TCLCOMPILATION @@ -766,19 +766,19 @@ EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp, */ EXTERN void TclCleanupByteCode _ANSI_ARGS_((ByteCode *codePtr)); -EXTERN int TclCompileCmdWord _ANSI_ARGS_((Tcl_Interp *interp, +EXTERN void TclCompileCmdWord _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr)); EXTERN int TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, int numBytes, CompileEnv *envPtr)); -EXTERN int TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp, +EXTERN void TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr)); -EXTERN int TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp, +EXTERN void TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, int numBytes, CompileEnv *envPtr)); -EXTERN int TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp, +EXTERN void TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr)); EXTERN int TclCreateAuxData _ANSI_ARGS_((ClientData clientData, diff --git a/generic/tclInt.h b/generic/tclInt.h index 079a01a..ea3c934 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.173 2004/09/17 22:06:24 kennykb Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.174 2004/09/26 16:36:04 msofer Exp $ */ #ifndef _TCLINT @@ -844,18 +844,19 @@ struct CompileEnv; /* * The type of procedures called by the Tcl bytecode compiler to compile * commands. Pointers to these procedures are kept in the Command structure - * describing each command. When a CompileProc returns, the interpreter's - * result is set to error information, if any. In addition, the CompileProc - * returns an integer value, which is one of the following: + * describing each command. The integer value returned by a CompileProc + * must be one of the following: * * TCL_OK Compilation completed normally. - * TCL_ERROR Compilation failed because of an error; - * the interpreter's result describes what went wrong. - * TCL_OUT_LINE_COMPILE Compilation failed because, e.g., the command is - * too complex for effective inline compilation. The - * CompileProc believes the command is legal but - * should be compiled "out of line" by emitting code - * to invoke its command procedure at runtime. + * TCL_OUT_LINE_COMPILE Compilation could not be completed. This can + * be just a judgment by the CompileProc that the + * command is too complex to compile effectively, + * or it can indicate that in the current state of + * the interp, the command would raise an error. + * In the latter circumstance, we defer error reporting + * until the actual runtime, because by then changes + * in the interp state may allow the command to be + * successfully evaluated. */ #define TCL_OUT_LINE_COMPILE (TCL_CONTINUE + 1) diff --git a/generic/tclProc.c b/generic/tclProc.c index 3cd3af7..4d9dcfd 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.55 2004/09/17 22:59:15 dgp Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.56 2004/09/26 16:36:04 msofer Exp $ */ #include "tclInt.h" @@ -1581,7 +1581,7 @@ TclCompileNoOp(interp, parsePtr, envPtr) CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int i, code; + int i; int savedStackDepth = envPtr->currStackDepth; tokenPtr = parsePtr->tokenPtr; @@ -1590,11 +1590,8 @@ TclCompileNoOp(interp, parsePtr, envPtr) envPtr->currStackDepth = savedStackDepth; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - code = TclCompileTokens(interp, tokenPtr+1, + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } TclEmitOpcode(INST_POP, envPtr); } } diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index b3e0677..8ce962d 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -12,10 +12,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compExpr-old.test,v 1.9 2004/05/19 20:15:31 dkf Exp $ +# RCS: @(#) $Id: compExpr-old.test,v 1.10 2004/09/26 16:36:05 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } @@ -479,11 +479,11 @@ test compExpr-old-14.15 {CompilePrimaryExpr: var reference primary} { catch {expr $i.2} msg set msg } 123.2 -test compExpr-old-14.16 {CompilePrimaryExpr: error compiling var reference primary} { +test compExpr-old-14.16 {CompilePrimaryExpr: error compiling var reference primary} -body { catch {expr {$a(foo}} msg set errorInfo -} {missing ) - while compiling +} -match glob -result {missing ) + while *ing "expr {$a(foo}"} test compExpr-old-14.17 {CompilePrimaryExpr: string primary that looks like var ref} { expr $ @@ -508,95 +508,91 @@ test compExpr-old-14.21 {CompilePrimaryExpr: error in quoted string primary} { test compExpr-old-14.22 {CompilePrimaryExpr: subcommand primary} { expr {[set i 123; set i]} } 123 -test compExpr-old-14.23 {CompilePrimaryExpr: error in subcommand primary} { +test compExpr-old-14.23 {CompilePrimaryExpr: error in subcommand primary} -body { catch {expr {[set]}} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - while compiling -"expr {[set]}"} -test compExpr-old-14.24 {CompilePrimaryExpr: error in subcommand primary} { +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*} +test compExpr-old-14.24 {CompilePrimaryExpr: error in subcommand primary} -body { catch {expr {[set i}} msg set errorInfo -} {missing close-bracket - while compiling -"expr {[set i}"} +} -match glob -result {missing close-bracket + while *ing +"expr {\[set i}"} test compExpr-old-14.25 {CompilePrimaryExpr: math function primary} { format %.6g [expr exp(1.0)] } 2.71828 test compExpr-old-14.26 {CompilePrimaryExpr: math function primary} { format %.6g [expr pow(2.0+0.1,3.0+0.1)] } 9.97424 -test compExpr-old-14.27 {CompilePrimaryExpr: error in math function primary} { +test compExpr-old-14.27 {CompilePrimaryExpr: error in math function primary} -body { catch {expr sinh::(2.0)} msg set errorInfo -} {syntax error in expression "sinh::(2.0)": expected parenthesis enclosing function arguments - while compiling +} -match glob -result {syntax error in expression "sinh::(2.0)": expected parenthesis enclosing function arguments + while *ing "expr sinh::(2.0)"} test compExpr-old-14.28 {CompilePrimaryExpr: subexpression primary} { expr 2+(3*4) } 14 -test compExpr-old-14.29 {CompilePrimaryExpr: error in subexpression primary} { +test compExpr-old-14.29 {CompilePrimaryExpr: error in subexpression primary} -body { catch {expr 2+(3*[set])} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - while compiling -"expr 2+(3*[set])"} -test compExpr-old-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} { +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*} +test compExpr-old-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} -body { catch {expr 2+(3*(4+5)} msg set errorInfo -} {syntax error in expression "2+(3*(4+5)": looking for close parenthesis - while compiling +} -match glob -result {syntax error in expression "2+(3*(4+5)": looking for close parenthesis + while *ing "expr 2+(3*(4+5)"} test compExpr-old-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} { set i "5+10" list "[expr $i] == 15" "[expr ($i)] == 15" "[eval expr ($i)] == 15" } {{15 == 15} {15 == 15} {15 == 15}} -test compExpr-old-14.32 {CompilePrimaryExpr: unexpected token} { +test compExpr-old-14.32 {CompilePrimaryExpr: unexpected token} -body { catch {expr @} msg set errorInfo -} {syntax error in expression "@": character not legal in expressions - while compiling +} -match glob -result {syntax error in expression "@": character not legal in expressions + while *ing "expr @"} -test compExpr-old-15.1 {CompileMathFuncCall: missing parenthesis} { +test compExpr-old-15.1 {CompileMathFuncCall: missing parenthesis} -body { catch {expr sinh2.0)} msg set errorInfo -} {syntax error in expression "sinh2.0)": variable references require preceding $ - while compiling +} -match glob -result {syntax error in expression "sinh2.0)": variable references require preceding $ + while *ing "expr sinh2.0)"} -test compExpr-old-15.2 {CompileMathFuncCall: unknown math function} { +test compExpr-old-15.2 {CompileMathFuncCall: unknown math function} -body { catch {expr whazzathuh(1)} msg set errorInfo -} {unknown math function "whazzathuh" - while compiling +} -match glob -result {unknown math function "whazzathuh" + while *ing "expr whazzathuh(1)"} -test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} { +test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} -body { catch {expr sin(1,2,3)} msg set errorInfo -} {too many arguments for math function - while compiling +} -match glob -result {too many arguments for math function + while *ing "expr sin(1,2,3)"} -test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} { +test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set errorInfo -} {too few arguments for math function - while compiling +} -match glob -result {too few arguments for math function + while *ing "expr sin()"} -test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} { +test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body { catch {expr pow(1)} msg set errorInfo -} {too few arguments for math function - while compiling +} -match glob -result {too few arguments for math function + while *ing "expr pow(1)"} -test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} { +test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { catch {expr sin(1} msg set errorInfo -} {syntax error in expression "sin(1": missing close parenthesis at end of function call - while compiling +} -match glob -result {syntax error in expression "sin(1": missing close parenthesis at end of function call + while *ing "expr sin(1"} test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions { expr 2*T1() diff --git a/tests/compExpr.test b/tests/compExpr.test index 4470fef..eec796e 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.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: compExpr.test,v 1.7 2004/05/19 20:15:31 dkf Exp $ +# RCS: @(#) $Id: compExpr.test,v 1.8 2004/09/26 16:36:05 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -87,7 +87,7 @@ test compExpr-2.13 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse catch {unset a} set a 15 list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg -} {1 {syntax error in expression "1+": premature end of expression}} +} {0 1} test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} { expr {5*6} } 30 @@ -180,7 +180,7 @@ test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse catch {unset a} set a 15 list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg -} {1 {syntax error in expression "1+": premature end of expression}} +} {0 1} test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { catch {unset a} set a false @@ -195,7 +195,7 @@ test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse catch {unset a} set a 15 list [catch {expr {1? 54 : "$a[expr 1+]00"}} msg] $msg -} {1 {syntax error in expression "1+": premature end of expression}} +} {0 54} test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} { catch {unset a} @@ -284,7 +284,7 @@ test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} } 83 test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} { list [catch {expr {1? 15 : [expr *2]}} msg] $msg -} {1 {syntax error in expression "*2": unexpected operator *}} +} {0 15} test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { format %.6g [expr atan2(1.0, 2.0)] diff --git a/tests/expr.test b/tests/expr.test index 4c3279d..4cfa615 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: expr.test,v 1.26 2004/09/24 21:30:11 dkf Exp $ +# RCS: @(#) $Id: expr.test,v 1.27 2004/09/26 16:36:05 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -507,11 +507,11 @@ test expr-14.15 {CompilePrimaryExpr: var reference primary} { catch {expr $i.2} msg set msg } 123.2 -test expr-14.16 {CompilePrimaryExpr: error compiling var reference primary} { +test expr-14.16 {CompilePrimaryExpr: error compiling var reference primary} -body { catch {expr {$a(foo}} msg set errorInfo -} {missing ) - while compiling +} -match glob -result {missing ) + while *ing "expr {$a(foo}"} test expr-14.17 {CompilePrimaryExpr: string primary that looks like var ref} { expr $ @@ -536,95 +536,91 @@ test expr-14.21 {CompilePrimaryExpr: error in quoted string primary} { test expr-14.22 {CompilePrimaryExpr: subcommand primary} { expr {[set i 123; set i]} } 123 -test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} { +test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} -body { catch {expr {[set]}} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - while compiling -"expr {[set]}"} -test expr-14.24 {CompilePrimaryExpr: error in subcommand primary} { +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*} +test expr-14.24 {CompilePrimaryExpr: error in subcommand primary} -body { catch {expr {[set i}} msg set errorInfo -} {missing close-bracket - while compiling -"expr {[set i}"} +} -match glob -result {missing close-bracket + while *ing +"expr {\[set i}"} test expr-14.25 {CompilePrimaryExpr: math function primary} { format %.6g [expr exp(1.0)] } 2.71828 test expr-14.26 {CompilePrimaryExpr: math function primary} { format %.6g [expr pow(2.0+0.1,3.0+0.1)] } 9.97424 -test expr-14.27 {CompilePrimaryExpr: error in math function primary} { +test expr-14.27 {CompilePrimaryExpr: error in math function primary} -body { catch {expr sinh::(2.0)} msg set errorInfo -} {syntax error in expression "sinh::(2.0)": expected parenthesis enclosing function arguments - while compiling +} -match glob -result {syntax error in expression "sinh::(2.0)": expected parenthesis enclosing function arguments + while *ing "expr sinh::(2.0)"} test expr-14.28 {CompilePrimaryExpr: subexpression primary} { expr 2+(3*4) } 14 -test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} { +test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} -body { catch {expr 2+(3*[set])} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - while compiling -"expr 2+(3*[set])"} -test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} { +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*} +test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} -body { catch {expr 2+(3*(4+5)} msg set errorInfo -} {syntax error in expression "2+(3*(4+5)": looking for close parenthesis - while compiling +} -match glob -result {syntax error in expression "2+(3*(4+5)": looking for close parenthesis + while *ing "expr 2+(3*(4+5)"} test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} { set i "5+10" list "[expr $i] == 15" "[expr ($i)] == 15" "[eval expr ($i)] == 15" } {{15 == 15} {15 == 15} {15 == 15}} -test expr-14.32 {CompilePrimaryExpr: unexpected token} { +test expr-14.32 {CompilePrimaryExpr: unexpected token} -body { catch {expr @} msg set errorInfo -} {syntax error in expression "@": character not legal in expressions - while compiling +} -match glob -result {syntax error in expression "@": character not legal in expressions + while *ing "expr @"} -test expr-15.1 {CompileMathFuncCall: missing parenthesis} { +test expr-15.1 {CompileMathFuncCall: missing parenthesis} -body { catch {expr sinh2.0)} msg set errorInfo -} {syntax error in expression "sinh2.0)": variable references require preceding $ - while compiling +} -match glob -result {syntax error in expression "sinh2.0)": variable references require preceding $ + while *ing "expr sinh2.0)"} -test expr-15.2 {CompileMathFuncCall: unknown math function} { +test expr-15.2 {CompileMathFuncCall: unknown math function} -body { catch {expr whazzathuh(1)} msg set errorInfo -} {unknown math function "whazzathuh" - while compiling +} -match glob -result {unknown math function "whazzathuh" + while *ing "expr whazzathuh(1)"} -test expr-15.3 {CompileMathFuncCall: too many arguments} { +test expr-15.3 {CompileMathFuncCall: too many arguments} -body { catch {expr sin(1,2,3)} msg set errorInfo -} {too many arguments for math function - while compiling +} -match glob -result {too many arguments for math function + while *ing "expr sin(1,2,3)"} -test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} { +test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set errorInfo -} {too few arguments for math function - while compiling +} -match glob -result {too few arguments for math function + while *ing "expr sin()"} -test expr-15.5 {CompileMathFuncCall: too few arguments} { +test expr-15.5 {CompileMathFuncCall: too few arguments} -body { catch {expr pow(1)} msg set errorInfo -} {too few arguments for math function - while compiling +} -match glob -result {too few arguments for math function + while *ing "expr pow(1)"} -test expr-15.6 {CompileMathFuncCall: missing ')'} { +test expr-15.6 {CompileMathFuncCall: missing ')'} -body { catch {expr sin(1} msg set errorInfo -} {syntax error in expression "sin(1": missing close parenthesis at end of function call - while compiling +} -match glob -result {syntax error in expression "sin(1": missing close parenthesis at end of function call + while *ing "expr sin(1"} test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} { expr 2*T1() diff --git a/tests/for.test b/tests/for.test index 4fbeef7..c6d7395 100644 --- a/tests/for.test +++ b/tests/for.test @@ -9,10 +9,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: for.test,v 1.9 2001/12/06 10:59:18 dkf Exp $ +# RCS: @(#) $Id: for.test,v 1.10 2004/09/26 16:36:06 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } @@ -21,21 +21,21 @@ if {[lsearch [namespace children] ::tcltest] == -1} { test for-1.1 {TclCompileForCmd: missing initial command} { list [catch {for} msg] $msg } {1 {wrong # args: should be "for start test next command"}} -test for-1.2 {TclCompileForCmd: error in initial command} { +test for-1.2 {TclCompileForCmd: error in initial command} -body { list [catch {for {set}} msg] $msg $errorInfo -} {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command" - while compiling +} -match glob -result {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command" + while *ing "for {set}"}} catch {unset i} test for-1.3 {TclCompileForCmd: missing test expression} { catch {for {set i 0}} msg set msg } {wrong # args: should be "for start test next command"} -test for-1.4 {TclCompileForCmd: error in test expression} { +test for-1.4 {TclCompileForCmd: error in test expression} -body { catch {for {set i 0} {$i<}} msg set errorInfo -} {wrong # args: should be "for start test next command" - while compiling +} -match glob -result {wrong # args: should be "for start test next command" + while *ing "for {set i 0} {$i<}"} test for-1.5 {TclCompileForCmd: test expression is enclosed in quotes} { set i 0 @@ -49,15 +49,12 @@ test for-1.7 {TclCompileForCmd: missing command body} { catch {for {set i 0} {$i < 5} {incr i}} msg set msg } {wrong # args: should be "for start test next command"} -test for-1.8 {TclCompileForCmd: error compiling command body} { +test for-1.8 {TclCompileForCmd: error compiling command body} -body { catch {for {set i 0} {$i < 5} {incr i} {set}} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - ("for" body line 1) - while compiling -"for {set i 0} {$i < 5} {incr i} {set}"} +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*} catch {unset a} test for-1.9 {TclCompileForCmd: simple command body} { set a {} @@ -83,15 +80,12 @@ test for-1.11 {TclCompileForCmd: computed command body} { for {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 set a } {x1} -test for-1.12 {TclCompileForCmd: error in "next" command} { - catch {for {set i 0} {$i < 5} {set} {puts $i}} msg +test for-1.12 {TclCompileForCmd: error in "next" command} -body { + catch {for {set i 0} {$i < 5} {set} {format $i}} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - ("for" loop-end command) - while compiling -"for {set i 0} {$i < 5} {set} {puts $i}"} +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*} test for-1.13 {TclCompileForCmd: long command body} { set a {} for {set i 1} {$i<6} {set i [expr $i+1]} { @@ -656,11 +650,11 @@ test for-6.5 {Tcl_ForObjCmd: number of args} { catch {$z {set i 0} {$i < 5} {incr i} {body} extra} msg set msg } {wrong # args: should be "for start test next command"} -test for-6.6 {Tcl_ForObjCmd: error in initial command} { +test for-6.6 {Tcl_ForObjCmd: error in initial command} -body { set z for list [catch {$z {set} {$i < 5} {incr i} {body}} msg] $msg $errorInfo -} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" - while compiling +} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while *ing "set" ("for" initial command) invoked from within @@ -677,12 +671,12 @@ test for-6.8 {Tcl_ForObjCmd: test expression is enclosed in quotes} { $z {set i 6} "$i > 5" {incr i} {set y $i} set i } 6 -test for-6.9 {Tcl_ForObjCmd: error executing command body} { +test for-6.9 {Tcl_ForObjCmd: error executing command body} -body { set z for catch {$z {set i 0} {$i < 5} {incr i} {set}} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing "set" ("for" body line 1) invoked from within @@ -714,12 +708,12 @@ test for-6.12 {Tcl_ForObjCmd: computed command body} { $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 set a } {x1} -test for-6.13 {Tcl_ForObjCmd: error in "next" command} { +test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body { set z for catch {$z {set i 0} {$i < 5} {set} {set j 4}} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing "set" ("for" loop-end command) invoked from within diff --git a/tests/if.test b/tests/if.test index 1c79ef2..aec98f4 100644 --- a/tests/if.test +++ b/tests/if.test @@ -10,10 +10,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: if.test,v 1.7 2001/12/04 15:36:29 dkf Exp $ +# RCS: @(#) $Id: if.test,v 1.8 2004/09/26 16:36:06 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } @@ -26,11 +26,10 @@ test if-1.1 {TclCompileIfCmd: missing if/elseif test} { test if-1.2 {TclCompileIfCmd: error in if/elseif test} { list [catch {if {[error "error in condition"]} foo} msg] $msg } {1 {error in condition}} -test if-1.3 {TclCompileIfCmd: error in if/elseif test} { +test if-1.3 {TclCompileIfCmd: error in if/elseif test} -body { list [catch {if {1+}} msg] $msg $errorInfo -} {1 {syntax error in expression "1+": premature end of expression} {syntax error in expression "1+": premature end of expression - ("if" test expression) - while compiling +} -match glob -result {1 {syntax error in expression "1+": premature end of expression} {syntax error in expression "1+": premature end of expression* + while *ing "if {1+}"}} test if-1.4 {TclCompileIfCmd: if/elseif test in braces} { set a {} @@ -63,15 +62,12 @@ test if-1.9 {TclCompileIfCmd: missing "then" body} { catch {if 1<2 then} msg set msg } {wrong # args: no script following "then" argument} -test if-1.10 {TclCompileIfCmd: error in "then" body} { +test if-1.10 {TclCompileIfCmd: error in "then" body} -body { set a {} list [catch {if {$a!="xxx"} then {set}} msg] $msg $errorInfo -} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - ("if" then script line 1) - while compiling -"if {$a!="xxx"} then {set}"}} +} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*}} test if-1.11 {TclCompileIfCmd: error in "then" body} { list [catch {if 2 then {[error "error in then clause"]}} msg] $msg } {1 {error in then clause}} @@ -177,12 +173,11 @@ test if-2.3 {TclCompileIfCmd: missing expression after "elseif"} { catch {if 1<2 {set a 1} elseif} msg set msg } {wrong # args: no expression after "elseif" argument} -test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} { +test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} -body { set a {} list [catch {if 3>4 {set a 1} elseif {1>}} msg] $msg $errorInfo -} {1 {syntax error in expression "1>": premature end of expression} {syntax error in expression "1>": premature end of expression - ("if" test expression) - while compiling +} -match glob -result {1 {syntax error in expression "1>": premature end of expression} {syntax error in expression "1>": premature end of expression* + while *ing "if 3>4 {set a 1} elseif {1>}"}} test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long "elseif" body} { catch {unset i} @@ -304,16 +299,13 @@ test if-3.3 {TclCompileIfCmd: missing body after "else"} { catch {if 2<1 {set a 1} else} msg set msg } {wrong # args: no script following "else" argument} -test if-3.4 {TclCompileIfCmd: error compiling body after "else"} { +test if-3.4 {TclCompileIfCmd: error compiling body after "else"} -body { set a {} catch {if 2<1 {set a 1} else {set}} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - ("if" else script line 1) - while compiling -"if 2<1 {set a 1} else {set}"} +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*} test if-3.5 {TclCompileIfCmd: extra arguments after "else" argument} { set a {} catch {if 2<1 {set a 1} else {set a 2} or something} msg @@ -552,12 +544,12 @@ test if-5.9 {if cmd with computed command names: missing "then" body} { catch {$z 1<2 then} msg set msg } {wrong # args: no script following "then" argument} -test if-5.10 {if cmd with computed command names: error in "then" body} { +test if-5.10 {if cmd with computed command names: error in "then" body} -body { set z if set a {} list [catch {$z {$a!="xxx"} then {set}} msg] $msg $errorInfo -} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" - while compiling +} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while *ing "set" invoked from within "$z {$a!="xxx"} then {set}"}} @@ -807,13 +799,13 @@ test if-7.3 {if cmd with computed command names: missing body after "else"} { catch {$z 2<1 {set a 1} else} msg set msg } {wrong # args: no script following "else" argument} -test if-7.4 {if cmd with computed command names: error compiling body after "else"} { +test if-7.4 {if cmd with computed command names: error compiling body after "else"} -body { set z if set a {} catch {$z 2<1 {set a 1} else {set}} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing "set" invoked from within "$z 2<1 {set a 1} else {set}"} diff --git a/tests/incr.test b/tests/incr.test index 309b757..bdf0b76 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -10,10 +10,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: incr.test,v 1.9 2003/04/28 12:34:33 dkf Exp $ +# RCS: @(#) $Id: incr.test,v 1.10 2004/09/26 16:36:06 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } @@ -174,15 +174,13 @@ test incr-1.18 {TclCompileIncrCmd: increment given, simple int} { set i 5 incr i -100 } -95 -test incr-1.19 {TclCompileIncrCmd: increment given, but erroneous} { +test incr-1.19 {TclCompileIncrCmd: increment given, but erroneous} -body { set i 5 catch {incr i [set]} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - while compiling -"incr i [set]"} +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*} test incr-1.20 {TclCompileIncrCmd: increment given, in quotes} { set i 25 incr i "-100" @@ -218,13 +216,11 @@ test incr-1.26 {TclCompileIncrCmd: runtime error, bad variable name} { (reading value of variable to increment) invoked from within "incr {"foo}"}} -test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} { +test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} -body { list [catch {incr [set]} msg] $msg $errorInfo -} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - while compiling -"incr [set]"}} +} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*}} test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} { proc readonly args {error "variable is read-only"} set x 123 @@ -426,16 +422,14 @@ test incr-2.18 {incr command (not compiled): increment given, simple int} { set i 5 $z i -100 } -95 -test incr-2.19 {incr command (not compiled): increment given, but erroneous} { +test incr-2.19 {incr command (not compiled): increment given, but erroneous} -body { set z incr set i 5 catch {$z i [set]} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - while compiling -"$z i [set]"} +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*} test incr-2.20 {incr command (not compiled): increment given, in quotes} { set z incr set i 25 @@ -478,14 +472,12 @@ test incr-2.26 {incr command (not compiled): runtime error, bad variable name} { (reading value of variable to increment) invoked from within "$z {"foo}"}} -test incr-2.27 {incr command (not compiled): runtime error, bad variable name} { +test incr-2.27 {incr command (not compiled): runtime error, bad variable name} -body { set z incr list [catch {$z [set]} msg] $msg $errorInfo -} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - while compiling -"$z [set]"}} +} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*}} test incr-2.28 {incr command (not compiled): runtime error, readonly variable} { set z incr proc readonly args {error "variable is read-only"} diff --git a/tests/while.test b/tests/while.test index 2fb396f..0352da4 100644 --- a/tests/while.test +++ b/tests/while.test @@ -10,10 +10,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: while.test,v 1.8 2001/12/04 15:36:29 dkf Exp $ +# RCS: @(#) $Id: while.test,v 1.9 2004/09/26 16:36:06 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } @@ -26,13 +26,12 @@ test while-1.1 {TclCompileWhileCmd: missing test expression} { catch {while } msg set msg } {wrong # args: should be "while test command"} -test while-1.2 {TclCompileWhileCmd: error in test expression} { +test while-1.2 {TclCompileWhileCmd: error in test expression} -body { set i 0 catch {while {$i<} break} msg set errorInfo -} {syntax error in expression "$i<": premature end of expression - ("while" test expression) - while compiling +} -match glob -result {syntax error in expression "$i<": premature end of expression* + while *ing "while {$i<} break"} test while-1.3 {TclCompileWhileCmd: error in test expression} { set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] @@ -66,16 +65,13 @@ test while-1.7 {TclCompileWhileCmd: missing command body} { catch {while {$i < 5} } msg set msg } {wrong # args: should be "while test command"} -test while-1.8 {TclCompileWhileCmd: error compiling command body} { +test while-1.8 {TclCompileWhileCmd: error compiling command body} -body { set i 0 catch {while {$i < 5} {set}} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling -"set" - ("while" body line 1) - while compiling -"while {$i < 5} {set}"} +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing +"set"*} test while-1.9 {TclCompileWhileCmd: simple command body} { set a {} set i 1 @@ -350,13 +346,13 @@ test while-4.8 {while (not compiled): missing command body} { catch {$z {$i < 5} } msg set msg } {wrong # args: should be "while test command"} -test while-4.9 {while (not compiled): error compiling command body} { +test while-4.9 {while (not compiled): error compiling command body} -body { set i 0 set z while catch {$z {$i < 5} {set}} msg set errorInfo -} {wrong # args: should be "set varName ?newValue?" - while compiling +} -match glob -result {wrong # args: should be "set varName ?newValue?" + while *ing "set" ("while" body line 1) invoked from within |