diff options
Diffstat (limited to 'generic/tclCompCmds.c')
| -rw-r--r-- | generic/tclCompCmds.c | 1980 |
1 files changed, 1980 insertions, 0 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c new file mode 100644 index 0000000..09c3dd0 --- /dev/null +++ b/generic/tclCompCmds.c @@ -0,0 +1,1980 @@ +/* + * tclCompCmds.c -- + * + * This file contains compilation procedures that compile various + * Tcl commands into a sequence of instructions ("bytecodes"). + * + * Copyright (c) 1997-1998 Sun Microsystems, Inc. + * + * 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.2 1999/04/16 00:46:43 stanton Exp $ + */ + +#include "tclInt.h" +#include "tclCompile.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); +static void FreeForeachInfo _ANSI_ARGS_(( + ClientData clientData)); + +/* + * The structures below define the AuxData types defined in this file. + */ + +AuxDataType tclForeachInfoType = { + "ForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo /* freeProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * TclCompileBreakCmd -- + * + * 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. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "break" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileBreakCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + if (parsePtr->numWords != 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"break\"", -1); + envPtr->maxStackDepth = 0; + return TCL_ERROR; + } + + /* + * Emit a break instruction. + */ + + TclEmitOpcode(INST_BREAK, envPtr); + envPtr->maxStackDepth = 0; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileCatchCmd -- + * + * 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. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "catch" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileCatchCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + JumpFixup jumpFixup; + Tcl_Token *cmdTokenPtr, *nameTokenPtr; + char *name; + int localIndex, nameChars, range, maxDepth, startOffset, jumpDist; + int code; + char buffer[32 + TCL_INTEGER_SPACE]; + + envPtr->maxStackDepth = 0; + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"catch command ?varName?\"", -1); + return TCL_ERROR; + } + + /* + * If a variable was specified and the catch command is at global level + * (not in a procedure), don't compile it inline: the payoff is + * too small. + */ + + if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Make sure the variable name, if any, has no substitutions and just + * refers to a local scaler. + */ + + localIndex = -1; + cmdTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (parsePtr->numWords == 3) { + nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1); + if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + name = nameTokenPtr[1].start; + nameChars = nameTokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_OUT_LINE_COMPILE; + } + localIndex = TclFindCompiledLocal(nameTokenPtr[1].start, + nameTokenPtr[1].size, /*create*/ 1, + /*flags*/ VAR_SCALAR, envPtr->procPtr); + } else { + return TCL_OUT_LINE_COMPILE; + } + } + + /* + * We will compile the catch command. Emit a beginCatch instruction at + * the start of the catch body: the subcommand it controls. + */ + + maxDepth = 0; + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); + + startOffset = (envPtr->codeNext - envPtr->codeStart); + envPtr->exceptArrayPtr[range].codeOffset = startOffset; + code = TclCompileCmdWord(interp, cmdTokenPtr+1, + cmdTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"catch\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = envPtr->maxStackDepth; + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) - startOffset; + + /* + * The "no errors" epilogue code: store the body's result into the + * variable (if any), push "0" (TCL_OK) as the catch's "no error" + * result, and jump around the "error case" code. + */ + + if (localIndex != -1) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + } + } + TclEmitOpcode(INST_POP, envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), + envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + + /* + * The "error case" code: store the body's result into the variable (if + * any), then push the error result code. The initial PC offset here is + * the catch's error target. + */ + + envPtr->exceptArrayPtr[range].catchOffset = + (envPtr->codeNext - envPtr->codeStart); + if (localIndex != -1) { + TclEmitOpcode(INST_PUSH_RESULT, envPtr); + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } + TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); + + /* + * Update the target of the jump after the "no errors" code, then emit + * an endCatch instruction at the end of the catch command. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { + panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist); + } + TclEmitOpcode(INST_END_CATCH, envPtr); + + done: + envPtr->exceptDepth--; + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileContinueCmd -- + * + * 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. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "continue" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileContinueCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + /* + * There should be no argument after the "continue". + */ + + if (parsePtr->numWords != 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"continue\"", -1); + envPtr->maxStackDepth = 0; + return TCL_ERROR; + } + + /* + * Emit a continue instruction. + */ + + TclEmitOpcode(INST_CONTINUE, envPtr); + envPtr->maxStackDepth = 0; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileExprCmd -- + * + * 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. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "expr" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "expr" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileExprCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *firstWordPtr; + + envPtr->maxStackDepth = 0; + if (parsePtr->numWords == 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"expr arg ?arg ...?\"", -1); + return TCL_ERROR; + } + + firstWordPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1), + envPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileForCmd -- + * + * 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. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "for" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileForCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; + JumpFixup jumpFalseFixup; + int maxDepth, jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist; + int bodyRange, nextRange, code; + unsigned char *jumpPc; + char buffer[32 + TCL_INTEGER_SPACE]; + + envPtr->maxStackDepth = 0; + 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; + } + + /* + * If the test expression requires substitutions, don't compile the for + * command inline. E.g., the expression might cause the loop to never + * execute or execute forever, as in "for {} "$x > 5" {incr x} {}". + */ + + startTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1); + if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Create ExceptionRange records for the body and the "next" command. + * The "next" command's ExceptionRange supports break but not continue + * (and has a -1 continueOffset). + */ + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + + /* + * Inline compile the initial command. + */ + + maxDepth = 0; + code = 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; + } + maxDepth = envPtr->maxStackDepth; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Compile the test then emit the conditional jump that exits the for. + */ + + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"for\" test expression)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Compile the loop body. + */ + + nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1); + envPtr->exceptArrayPtr[bodyRange].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"for\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[bodyRange].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[bodyRange].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Compile the "next" subcommand. + */ + + envPtr->exceptArrayPtr[bodyRange].continueOffset = + (envPtr->codeNext - envPtr->codeStart); + envPtr->exceptArrayPtr[nextRange].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, nextTokenPtr+1, + nextTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"for\" loop-end command)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[nextRange].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[nextRange].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Jump back to the test at the top of the loop. Generate a 4 byte jump + * if the distance to the test is > 120 bytes. This is conservative and + * ensures that we won't have to replace this jump if we later need to + * replace the ifFalse jump with a 4 byte jump. + */ + + jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); + jumpBackDist = (jumpBackOffset - testCodeOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + } + + /* + * Fix the target of the jumpFalse after the test. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body and "next" command ExceptionRanges since + * they moved down. + */ + + envPtr->exceptArrayPtr[bodyRange].codeOffset += 3; + envPtr->exceptArrayPtr[bodyRange].continueOffset += 3; + envPtr->exceptArrayPtr[nextRange].codeOffset += 3; + + /* + * Update the jump back to the test at the top of the loop since it + * also moved down 3 bytes. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + jumpBackDist += 3; + if (jumpBackDist > 120) { + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + } else { + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + } + } + + /* + * Set the loop's break target. + */ + + envPtr->exceptArrayPtr[bodyRange].breakOffset = + envPtr->exceptArrayPtr[nextRange].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * The for command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + code = TCL_OK; + + done: + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileForeachCmd -- + * + * 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. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "while" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "foreach" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileForeachCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Proc *procPtr = envPtr->procPtr; + ForeachInfo *infoPtr; /* Points to the structure describing this + * foreach command. Stored in a AuxData + * record in the ByteCode. */ + int firstValueTemp; /* Index of the first temp var in the frame + * used to point to a value list. */ + int loopCtTemp; /* Index of temp var holding the loop's + * iteration count. */ + Tcl_Token *tokenPtr, *bodyTokenPtr; + char *varList; + unsigned char *jumpPc; + JumpFixup jumpFalseFixup; + int jumpDist, jumpBackDist, jumpBackOffset, maxDepth, infoIndex, range; + int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; + char savedChar; + char buffer[32 + TCL_INTEGER_SPACE]; + + /* + * We parse the variable list argument words and create two arrays: + * varcList[i] is number of variables in i-th var list + * varvList[i] points to array of var names in i-th var list + */ + +#define STATIC_VAR_LIST_SIZE 5 + int varcListStaticSpace[STATIC_VAR_LIST_SIZE]; + char **varvListStaticSpace[STATIC_VAR_LIST_SIZE]; + int *varcList = varcListStaticSpace; + char ***varvList = varvListStaticSpace; + + /* + * If the foreach command isn't in a procedure, don't compile it inline: + * the payoff is too small. + */ + + envPtr->maxStackDepth = 0; + if (procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + maxDepth = 0; + + 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; + } + + /* + * Allocate storage for the varcList and varvList arrays if necessary. + */ + + numLists = (numWords - 2)/2; + if (numLists > STATIC_VAR_LIST_SIZE) { + varcList = (int *) ckalloc(numLists * sizeof(int)); + varvList = (char ***) ckalloc(numLists * sizeof(char **)); + } + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + varcList[loopIndex] = 0; + varvList[loopIndex] = (char **) NULL; + } + + /* + * Set the exception stack depth. + */ + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + + /* + * Break up each var list and set the varcList and varvList arrays. + * Don't compile the foreach inline if any var name needs substitutions + * or isn't a scalar, or if any var list needs substitutions. + */ + + loopIndex = 0; + for (i = 0, tokenPtr = parsePtr->tokenPtr; + i < numWords-1; + i++, tokenPtr += (tokenPtr->numComponents + 1)) { + if (i%2 == 1) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + code = TCL_OUT_LINE_COMPILE; + goto done; + } + varList = tokenPtr[1].start; + savedChar = varList[tokenPtr[1].size]; + + /* + * Note there is a danger that modifying the string could have + * undesirable side effects. In this case, Tcl_SplitList does + * not have any dependencies on shared strings so we should be + * safe. + */ + + varList[tokenPtr[1].size] = '\0'; + code = Tcl_SplitList(interp, varList, + &varcList[loopIndex], &varvList[loopIndex]); + varList[tokenPtr[1].size] = savedChar; + if (code != TCL_OK) { + goto done; + } + + numVars = varcList[loopIndex]; + for (j = 0; j < numVars; j++) { + char *varName = varvList[loopIndex][j]; + if (!TclIsLocalScalar(varName, (int) strlen(varName))) { + code = TCL_OUT_LINE_COMPILE; + goto done; + } + } + loopIndex++; + } + } + + /* + * We will compile the foreach command. + * Reserve (numLists + 1) temporary variables: + * - numLists temps to hold each value list + * - 1 temp for the loop counter (index of next element in each list) + * At this time we don't try to reuse temporaries; if there are two + * nonoverlapping foreach loops, they don't share any temps. + */ + + firstValueTemp = -1; + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, + /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + if (loopIndex == 0) { + firstValueTemp = tempVar; + } + } + loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, + /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + + /* + * Create and initialize the ForeachInfo and ForeachVarList data + * structures describing this command. Then create a AuxData record + * pointing to the ForeachInfo structure. + */ + + infoPtr = (ForeachInfo *) ckalloc((unsigned) + (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + infoPtr->numLists = numLists; + infoPtr->firstValueTemp = firstValueTemp; + infoPtr->loopCtTemp = loopCtTemp; + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + ForeachVarList *varListPtr; + numVars = varcList[loopIndex]; + varListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + (numVars * sizeof(int))); + varListPtr->numVars = numVars; + for (j = 0; j < numVars; j++) { + char *varName = varvList[loopIndex][j]; + int nameChars = strlen(varName); + varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, + nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + } + infoPtr->varLists[loopIndex] = varListPtr; + } + infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr); + + /* + * Evaluate then store each value list in the associated temporary. + */ + + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + + loopIndex = 0; + for (i = 0, tokenPtr = parsePtr->tokenPtr; + i < numWords-1; + i++, tokenPtr += (tokenPtr->numComponents + 1)) { + if ((i%2 == 0) && (i > 0)) { + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + + tempVar = (firstValueTemp + loopIndex); + if (tempVar <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + loopIndex++; + } + } + bodyTokenPtr = tokenPtr; + + /* + * Initialize the temporary var that holds the count of loop iterations. + */ + + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + + /* + * Top of loop code: assign each loop variable and check whether + * to terminate the loop. + */ + + envPtr->exceptArrayPtr[range].continueOffset = + (envPtr->codeNext - envPtr->codeStart); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Inline compile the loop body. + */ + + envPtr->exceptArrayPtr[range].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"foreach\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[range].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Jump back to the test at the top of the loop. Generate a 4 byte jump + * if the distance to the test is > 120 bytes. This is conservative and + * ensures that we won't have to replace this jump if we later need to + * replace the ifFalse jump with a 4 byte jump. + */ + + jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); + jumpBackDist = + (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + } + + /* + * Fix the target of the jump after the foreach_step test. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body's starting PC offset since it moved down. + */ + + envPtr->exceptArrayPtr[range].codeOffset += 3; + + /* + * Update the jump back to the test at the top of the loop since it + * also moved down 3 bytes. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + jumpBackDist += 3; + if (jumpBackDist > 120) { + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + } else { + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + } + } + + /* + * Set the loop's break target. + */ + + envPtr->exceptArrayPtr[range].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * The foreach command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + + done: + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + if (varvList[loopIndex] != (char **) NULL) { + ckfree((char *) varvList[loopIndex]); + } + } + if (varcList != varcListStaticSpace) { + ckfree((char *) varcList); + ckfree((char *) varvList); + } + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * DupForeachInfo -- + * + * This procedure duplicates a ForeachInfo structure created as + * auxiliary data during the compilation of a foreach command. + * + * Results: + * A pointer to a newly allocated copy of the existing ForeachInfo + * structure is returned. + * + * Side effects: + * Storage for the copied ForeachInfo record is allocated. If the + * original ForeachInfo structure pointed to any ForeachVarList + * records, these structures are also copied and pointers to them + * are stored in the new ForeachInfo record. + * + *---------------------------------------------------------------------- + */ + +static ClientData +DupForeachInfo(clientData) + ClientData clientData; /* The foreach command's compilation + * auxiliary data to duplicate. */ +{ + register ForeachInfo *srcPtr = (ForeachInfo *) clientData; + ForeachInfo *dupPtr; + register ForeachVarList *srcListPtr, *dupListPtr; + int numLists = srcPtr->numLists; + int numVars, i, j; + + dupPtr = (ForeachInfo *) ckalloc((unsigned) + (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + dupPtr->numLists = numLists; + dupPtr->firstValueTemp = srcPtr->firstValueTemp; + dupPtr->loopCtTemp = srcPtr->loopCtTemp; + + for (i = 0; i < numLists; i++) { + srcListPtr = srcPtr->varLists[i]; + numVars = srcListPtr->numVars; + dupListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + numVars*sizeof(int)); + dupListPtr->numVars = numVars; + for (j = 0; j < numVars; j++) { + dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; + } + dupPtr->varLists[i] = dupListPtr; + } + return (ClientData) dupPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeForeachInfo -- + * + * Procedure to free a ForeachInfo structure created as auxiliary data + * during the compilation of a foreach command. + * + * Results: + * None. + * + * Side effects: + * Storage for the ForeachInfo structure pointed to by the ClientData + * argument is freed as is any ForeachVarList record pointed to by the + * ForeachInfo structure. + * + *---------------------------------------------------------------------- + */ + +static void +FreeForeachInfo(clientData) + ClientData clientData; /* The foreach command's compilation + * auxiliary data to free. */ +{ + register ForeachInfo *infoPtr = (ForeachInfo *) clientData; + register ForeachVarList *listPtr; + int numLists = infoPtr->numLists; + register int i; + + for (i = 0; i < numLists; i++) { + listPtr = infoPtr->varLists[i]; + ckfree((char *) listPtr); + } + ckfree((char *) infoPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIfCmd -- + * + * 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. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "if" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIfCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + JumpFixupArray jumpFalseFixupArray; + /* Used to fix the ifFalse jump after each + * test when its target PC is determined. */ + JumpFixupArray jumpEndFixupArray; + /* Used to fix the jump after each "then" + * body to the end of the "if" when that PC + * is determined. */ + Tcl_Token *tokenPtr, *testTokenPtr; + int jumpDist, jumpFalseDist, jumpIndex; + int numWords, wordIdx, numBytes, maxDepth, j, code; + char *word; + char buffer[100]; + + TclInitJumpFixupArray(&jumpFalseFixupArray); + TclInitJumpFixupArray(&jumpEndFixupArray); + maxDepth = 0; + code = TCL_OK; + + /* + * Each iteration of this loop compiles one "if expr ?then? body" + * or "elseif expr ?then? body" clause. + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + numWords = parsePtr->numWords; + while (wordIdx < numWords) { + /* + * Stop looping if the token isn't "if" or "elseif". + */ + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + break; + } + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((tokenPtr == parsePtr->tokenPtr) + || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { + tokenPtr += (tokenPtr->numComponents + 1); + wordIdx++; + } else { + break; + } + if (wordIdx >= numWords) { + sprintf(buffer, + "wrong # args: no expression after \"%.30s\" argument", + word); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); + code = TCL_ERROR; + goto done; + } + + /* + * Compile the test expression then emit the conditional jump + * around the "then" part. If the expression word isn't simple, + * we back off and compile the if command out-of-line. + */ + + testTokenPtr = tokenPtr; + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"if\" test expression)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { + TclExpandJumpFixupArray(&jumpFalseFixupArray); + } + jumpIndex = jumpFalseFixupArray.next; + jumpFalseFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + &(jumpFalseFixupArray.fixup[jumpIndex])); + + /* + * Skip over the optional "then" before the then clause. + */ + + tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + wordIdx++; + if (wordIdx >= numWords) { + sprintf(buffer, "wrong # args: no script following \"%.20s\" argument", testTokenPtr->start); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); + code = TCL_ERROR; + goto done; + } + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { + 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; + goto done; + } + } + } + + /* + * Compile the "then" command body. + */ + + code = 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; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + + /* + * Jump to the end of the "if" command. Both jumpFalseFixupArray and + * jumpEndFixupArray are indexed by "jumpIndex". + */ + + if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { + TclExpandJumpFixupArray(&jumpEndFixupArray); + } + jumpEndFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &(jumpEndFixupArray.fixup[jumpIndex])); + + /* + * Fix the target of the jumpFalse after the test. Generate a 4 byte + * jump if the distance is > 120 bytes. This is conservative, and + * ensures that we won't have to replace this jump if we later also + * need to replace the proceeding jump to the end of the "if" with a + * 4 byte jump. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + if (TclFixupForwardJump(envPtr, + &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) { + /* + * Adjust the code offset for the proceeding jump to the end + * of the "if" command. + */ + + jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; + } + + tokenPtr += (tokenPtr->numComponents + 1); + wordIdx++; + } + + /* + * Check for the optional else clause. + */ + + if ((wordIdx < numWords) + && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { + /* + * There is an else clause. Skip over the optional "else" word. + */ + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { + 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; + goto done; + } + } + + /* + * Compile the else command body. + */ + + code = 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; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + + /* + * Make sure there are no words after the else clause. + */ + + 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; + goto done; + } + } else { + /* + * No else clause: the "if" command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0,/*onHeap*/ 0), envPtr); + maxDepth = TclMax(1, maxDepth); + } + + /* + * Fix the unconditional jumps to the end of the "if" command. + */ + + for (j = jumpEndFixupArray.next; j > 0; j--) { + jumpIndex = (j - 1); /* i.e. process the closest jump first */ + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpEndFixupArray.fixup[jumpIndex].codeOffset; + if (TclFixupForwardJump(envPtr, + &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) { + /* + * Adjust the immediately preceeding "ifFalse" jump. We moved + * it's target (just after this jump) down three bytes. + */ + + unsigned char *ifFalsePc = envPtr->codeStart + + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + unsigned char opCode = *ifFalsePc; + if (opCode == INST_JUMP_FALSE1) { + jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else if (opCode == INST_JUMP_FALSE4) { + jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else { + panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump"); + } + } + } + + /* + * Free the jumpFixupArray array if malloc'ed storage was used. + */ + + done: + TclFreeJumpFixupArray(&jumpFalseFixupArray); + TclFreeJumpFixupArray(&jumpEndFixupArray); + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIncrCmd -- + * + * 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. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "incr" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "incr" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIncrCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr, *incrTokenPtr; + Tcl_Parse elemParse; + int gotElemParse = 0; + char *name, *elName, *p; + int nameChars, elNameChars, haveImmValue, immValue, localIndex, i, code; + int maxDepth = 0; + char buffer[160]; + + envPtr->maxStackDepth = 0; + 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; + } + + name = NULL; + elName = NULL; + elNameChars = 0; + localIndex = -1; + code = TCL_OK; + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * A simple variable name. Divide it up into "name" and "elName" + * strings. If it is not a local variable, look it up at runtime. + */ + + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + for (i = 0, p = name; i < nameChars; i++, p++) { + if (*p == '(') { + char *openParen = p; + p = (name + nameChars-1); + if (*p == ')') { /* last char is ')' => array reference */ + nameChars = (openParen - name); + elName = openParen+1; + elNameChars = (p - elName); + } + break; + } + } + if (envPtr->procPtr != NULL) { + localIndex = TclFindCompiledLocal(name, nameChars, + /*create*/ 0, /*flags*/ 0, envPtr->procPtr); + if (localIndex > 255) { /* we'll push the name */ + localIndex = -1; + } + } + if (localIndex < 0) { + TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, + /*onHeap*/ 0), envPtr); + maxDepth = 1; + } + + /* + * Compile the element script, if any. + */ + + if (elName != NULL) { + /* + * Temporarily replace the '(' and ')' by '"'s. + */ + + *(elName-1) = '"'; + *(elName+elNameChars) = '"'; + code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, + /*nested*/ 0, &elemParse); + *(elName-1) = '('; + *(elName+elNameChars) = ')'; + gotElemParse = 1; + if ((code != TCL_OK) || (elemParse.numWords > 1)) { + sprintf(buffer, "\n (parsing index for array \"%.*s\")", + TclMin(nameChars, 100), name); + Tcl_AddObjErrorInfo(interp, buffer, -1); + code = TCL_ERROR; + goto done; + } else if (elemParse.numWords == 1) { + code = TclCompileTokens(interp, elemParse.tokenPtr+1, + elemParse.tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } else { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, + /*alreadyAlloced*/ 0), envPtr); + maxDepth += 1; + } + } + } else { + /* + * Not a simple variable name. Look it up at runtime. + */ + + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + } + + /* + * If an increment is given, push it, but see first if it's a small + * integer. + */ + + haveImmValue = 0; + immValue = 0; + if (parsePtr->numWords == 3) { + incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + char *word = incrTokenPtr[1].start; + int numBytes = incrTokenPtr[1].size; + char savedChar = word[numBytes]; + long n; + + /* + * Note there is a danger that modifying the string could have + * undesirable side effects. In this case, TclLooksLikeInt and + * TclGetLong do not have any dependencies on shared strings so we + * should be safe. + */ + + word[numBytes] = '\0'; + if (TclLooksLikeInt(word, numBytes) + && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) { + if ((-127 <= n) && (n <= 127)) { + haveImmValue = 1; + immValue = n; + } + } + word[numBytes] = savedChar; + if (!haveImmValue) { + TclEmitPush(TclRegisterLiteral(envPtr, word, numBytes, + /*onHeap*/ 0), envPtr); + maxDepth += 1; + } + } else { + code = TclCompileTokens(interp, incrTokenPtr+1, + incrTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (increment expression)", -1); + } + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + } else { /* no incr amount given so use 1 */ + haveImmValue = 1; + immValue = 1; + } + + /* + * Emit the instruction to increment the variable. + */ + + if (name != NULL) { + if (elName == NULL) { + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, + envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, + envPtr); + } else { + TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); + } + } + } else { + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, + envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, + envPtr); + } else { + TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); + } + } + } + } else { /* non-simple variable name */ + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode(INST_INCR_STK, envPtr); + } + } + + done: + if (gotElemParse) { + Tcl_FreeParse(&elemParse); + } + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileSetCmd -- + * + * 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. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the incr command. + * + * Side effects: + * Instructions are added to envPtr to execute the "set" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileSetCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr, *valueTokenPtr; + Tcl_Parse elemParse; + int gotElemParse = 0; + register char *p; + char *name, *elName; + int nameChars, elNameChars; + register int i; + int isAssignment, simpleVarName, localIndex, numWords; + int maxDepth = 0; + int code = TCL_OK; + + envPtr->maxStackDepth = 0; + 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; + } + isAssignment = (numWords == 3); + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + + simpleVarName = 0; + name = elName = NULL; + nameChars = elNameChars = 0; + localIndex = -1; + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + simpleVarName = 1; + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + /* last char is ')' => potential array reference */ + if ( *(name + nameChars - 1) == ')') { + for (i = 0, p = name; i < nameChars; i++, p++) { + if (*p == '(') { + elName = p + 1; + elNameChars = nameChars - i - 2; + nameChars = i ; + break; + } + } + } + + /* + * If elName contains any double quotes ("), we can't inline + * compile the element script using the replace '()' by '"' + * technique below. + */ + + for (i = 0, p = elName; i < elNameChars; i++, p++) { + if (*p == '"') { + simpleVarName = 0; + break; + } + } + } else if ((varTokenPtr->numComponents == 4) + && (varTokenPtr[1].type == TCL_TOKEN_TEXT) + && (varTokenPtr[1].start[varTokenPtr[1].size-1] == '(') + && (varTokenPtr[4].type == TCL_TOKEN_TEXT) + && (varTokenPtr[4].size == 1) + && (varTokenPtr[4].start[0] == ')')) { + simpleVarName = 1; + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size - 1; + elName = varTokenPtr[2].start; + elNameChars = varTokenPtr[2].size; + } + + if (simpleVarName) { + /* + * See whether name has any namespace separators (::'s). + */ + + int hasNsQualifiers = 0; + for (i = 0, p = name; i < nameChars; i++, p++) { + if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { + hasNsQualifiers = 1; + break; + } + } + + /* + * Look up the var name's index in the array of local vars in the + * proc frame. If retrieving the var's value and it doesn't already + * exist, push its name and look it up at runtime. + */ + + if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { + localIndex = TclFindCompiledLocal(name, nameChars, + /*create*/ isAssignment, + /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), + envPtr->procPtr); + } + if (localIndex >= 0) { + maxDepth = 0; + } else { + TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, + /*onHeap*/ 0), envPtr); + maxDepth = 1; + } + + /* + * Compile the element script, if any. + */ + + if (elName != NULL) { + /* + * Temporarily replace the '(' and ')' by '"'s. + */ + + *(elName-1) = '"'; + *(elName+elNameChars) = '"'; + code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, + /*nested*/ 0, &elemParse); + *(elName-1) = '('; + *(elName+elNameChars) = ')'; + gotElemParse = 1; + if ((code != TCL_OK) || (elemParse.numWords > 1)) { + char buffer[160]; + sprintf(buffer, "\n (parsing index for array \"%.*s\")", + TclMin(nameChars, 100), name); + Tcl_AddObjErrorInfo(interp, buffer, -1); + code = TCL_ERROR; + goto done; + } else if (elemParse.numWords == 1) { + code = TclCompileTokens(interp, elemParse.tokenPtr+1, + elemParse.tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } else { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, + /*alreadyAlloced*/ 0), envPtr); + maxDepth += 1; + } + } + } else { + /* + * The var name isn't simple: compile and push it. + */ + + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + + /* + * If we are doing an assignment, push the new value. + */ + + if (isAssignment) { + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start, + valueTokenPtr[1].size, /*onHeap*/ 0), envPtr); + maxDepth += 1; + } else { + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + } + + /* + * Emit instructions to set/get the variable. + */ + + if (simpleVarName) { + if (elName == NULL) { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1((isAssignment? + INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), + localIndex, envPtr); + } else { + TclEmitInstInt4((isAssignment? + INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), + localIndex, envPtr); + } + } else { + TclEmitOpcode((isAssignment? + INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), + envPtr); + } + } else { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1((isAssignment? + INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), + localIndex, envPtr); + } else { + TclEmitInstInt4((isAssignment? + INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), + localIndex, envPtr); + } + } else { + TclEmitOpcode((isAssignment? + INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), + envPtr); + } + } + } else { + TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), + envPtr); + } + + done: + if (gotElemParse) { + Tcl_FreeParse(&elemParse); + } + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileWhileCmd -- + * + * 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. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "while" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "while" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileWhileCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *testTokenPtr, *bodyTokenPtr; + JumpFixup jumpFalseFixup; + unsigned char *jumpPc; + int testCodeOffset, jumpDist, jumpBackDist, jumpBackOffset; + int range, maxDepth, code; + char buffer[32 + TCL_INTEGER_SPACE]; + + envPtr->maxStackDepth = 0; + maxDepth = 0; + if (parsePtr->numWords != 3) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"while test command\"", -1); + return TCL_ERROR; + } + + /* + * If the test expression requires substitutions, don't compile the + * while command inline. E.g., the expression might cause the loop to + * never execute or execute forever, as in "while "$x < 5" {}". + */ + + testTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Create a ExceptionRange record for the loop body. This is used to + * implement break and continue. + */ + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + envPtr->exceptArrayPtr[range].continueOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * Compile the test expression then emit the conditional jump that + * terminates the while. We already know it's a simple word. + */ + + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); + envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"while\" test expression)", -1); + } + goto error; + } + maxDepth = envPtr->maxStackDepth; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Compile the loop body. + */ + + bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + envPtr->exceptArrayPtr[range].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"while\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto error; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[range].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Jump back to the test at the top of the loop. Generate a 4 byte jump + * if the distance to the test is > 120 bytes. This is conservative and + * ensures that we won't have to replace this jump if we later need to + * replace the ifFalse jump with a 4 byte jump. + */ + + jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); + jumpBackDist = (jumpBackOffset - testCodeOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + } + + /* + * Fix the target of the jumpFalse after the test. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body's starting PC offset since it moved down. + */ + + envPtr->exceptArrayPtr[range].codeOffset += 3; + + /* + * Update the jump back to the test at the top of the loop since it + * also moved down 3 bytes. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + jumpBackDist += 3; + if (jumpBackDist > 120) { + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + } else { + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + } + } + + /* + * Set the loop's break target. + */ + + envPtr->exceptArrayPtr[range].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * The while command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return TCL_OK; + + error: + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return code; +} + + + |