/* $Header$ */ /* * 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.1.1.1 2001/06/13 04:35:34 dtashley 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); /* * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether * curly braces surround the variable name. * This really matters for array elements to handle things like * set {x($foo)} 5 * which raises an undefined var error if we are not careful here. * This goes with the hack in TclCompileSetCmd. */ if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && (varTokenPtr->start[0] != '{')) { /* * 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, n; 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); /* * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether * curly braces surround the variable name. * This really matters for array elements to handle things like * set {x($foo)} 5 * which raises an undefined var error if we are not careful here. * This goes with the hack in TclCompileIncrCmd. */ if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && (varTokenPtr->start[0] != '{')) { 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 (((n = varTokenPtr->numComponents) > 1) && (varTokenPtr[1].type == TCL_TOKEN_TEXT) && (varTokenPtr[n].type == TCL_TOKEN_TEXT) && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { simpleVarName = 0; /* * Check for parentheses inside first token */ for (i = 0, p = varTokenPtr[1].start; i < varTokenPtr[1].size; i++, p++) { if (*p == '(') { simpleVarName = 1; break; } } if (simpleVarName) { name = varTokenPtr[1].start; nameChars = p - varTokenPtr[1].start; elName = p + 1; elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2; /* * 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; } } } } 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; } /* End of tclcompcmds.c */