/*
* 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.5 2000/01/21 02:25:26 hobbs 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;
}