Logo Search packages:      
Sourcecode: tcl8.4 version File versions  Download package

tclCompCmds.c

/* 
 * 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.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002 ActiveState Corporation.
 *
 * 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.39.2.3 2005/03/18 15:32:29 dgp 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));
static int        TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
      Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
      int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr));

/*
 * Flags bits used by TclPushVarName.
 */

#define TCL_CREATE_VAR     1 /* Create a compiled local if none is found */
#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */

/*
 * The structures below define the AuxData types defined in this file.
 */

AuxDataType tclForeachInfoType = {
    "ForeachInfo",                        /* name */
    DupForeachInfo,                       /* dupProc */
    FreeForeachInfo                       /* freeProc */
};

/*
 *----------------------------------------------------------------------
 *
 * TclCompileAppendCmd --
 *
 *    Procedure called to compile the "append" command.
 *
 * Results:
 *    The return value is a standard Tcl result, which is normally TCL_OK
 *    unless there was an error while parsing string. If an error occurs
 *    then the interpreter's result contains a standard error message. If
 *    complation fails because the command requires a second level of
 *    substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
 *    command should be compiled "out of line" by emitting code to
 *    invoke its command procedure (Tcl_AppendObjCmd) at runtime.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the "append" command
 *    at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileAppendCmd(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;
    int simpleVarName, isScalar, localIndex, numWords;
    int code = TCL_OK;

    numWords = parsePtr->numWords;
    if (numWords == 1) {
      Tcl_ResetResult(interp);
      Tcl_AppendToObj(Tcl_GetObjResult(interp),
            "wrong # args: should be \"append varName ?value value ...?\"",
            -1);
      return TCL_ERROR;
    } else if (numWords == 2) {
      /*
       * append varName === set varName
       */
        return TclCompileSetCmd(interp, parsePtr, envPtr);
    } else if (numWords > 3) {
      /*
       * APPEND instructions currently only handle one value
       */
        return TCL_OUT_LINE_COMPILE;
    }

    /*
     * 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. 
     */

    varTokenPtr = parsePtr->tokenPtr
          + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
          &localIndex, &simpleVarName, &isScalar);
    if (code != TCL_OK) {
      goto done;
    }

    /*
     * We are doing an assignment, otherwise TclCompileSetCmd was called,
     * so push the new value.  This will need to be extended to push a
     * value for each argument.
     */

    if (numWords > 2) {
      valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
      if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
          TclEmitPush(TclRegisterNewLiteral(envPtr, 
                valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
      } else {
          code = TclCompileTokens(interp, valueTokenPtr+1,
                  valueTokenPtr->numComponents, envPtr);
          if (code != TCL_OK) {
            goto done;
          }
      }
    }

    /*
     * Emit instructions to set/get the variable.
     */

    if (simpleVarName) {
      if (isScalar) {
          if (localIndex >= 0) {
            if (localIndex <= 255) {
                TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
            } else {
                TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
            }
          } else {
            TclEmitOpcode(INST_APPEND_STK, envPtr);
          }
      } else {
          if (localIndex >= 0) {
            if (localIndex <= 255) {
                TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
            } else {
                TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
            }
          } else {
            TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
          }
      }
    } else {
      TclEmitOpcode(INST_APPEND_STK, envPtr);
    }

    done:
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * 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);
      return TCL_ERROR;
    }

    /*
     * Emit a break instruction.
     */

    TclEmitOpcode(INST_BREAK, envPtr);
    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.
 *
 * 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;
    CONST char *name;
    int localIndex, nameChars, range, startOffset, jumpDist;
    int code;
    int savedStackDepth = envPtr->currStackDepth;

    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.
     */
    
    envPtr->exceptDepth++;
    envPtr->maxExceptDepth =
      TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
    TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);

    /*
     * If the body is a simple word, compile the instructions to
     * eval it. Otherwise, compile instructions to substitute its
     * text without catching, a catch instruction that resets the 
     * stack to what it was before substituting the body, and then 
     * an instruction to eval the body. Care has to be taken to 
     * register the correct startOffset for the catch range so that
     * errors in the substitution are not catched [Bug 219184]
     */

    if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
      startOffset = (envPtr->codeNext - envPtr->codeStart);
      code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr);
    } else {
      code = TclCompileTokens(interp, cmdTokenPtr+1,
              cmdTokenPtr->numComponents, envPtr);
      startOffset = (envPtr->codeNext - envPtr->codeStart);
      TclEmitOpcode(INST_EVAL_STK, envPtr);
    }
    envPtr->exceptArrayPtr[range].codeOffset = startOffset;

    if (code != TCL_OK) {
      code = TCL_OUT_LINE_COMPILE;
      goto done;
    }
    envPtr->exceptArrayPtr[range].numCodeBytes =
          (envPtr->codeNext - envPtr->codeStart) - startOffset;
                
    /*
     * 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(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
    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->currStackDepth = savedStackDepth;
    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->currStackDepth = savedStackDepth + 1;
    envPtr->exceptDepth--;
    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.
 *
 * 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);
      return TCL_ERROR;
    }

    /*
     * Emit a continue instruction.
     */

    TclEmitOpcode(INST_CONTINUE, envPtr);
    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.
 *
 * 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;

    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.
 *
 * 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 jumpEvalCondFixup;
    int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
    int bodyRange, nextRange, code;
    char buffer[32 + TCL_INTEGER_SPACE];
    int savedStackDepth = envPtr->currStackDepth;

    if (parsePtr->numWords != 5) {
      Tcl_ResetResult(interp);
      Tcl_AppendToObj(Tcl_GetObjResult(interp),
              "wrong # args: should be \"for start test next command\"", -1);
      return TCL_ERROR;
    }

    /*
     * 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;
    }

    /*
     * Bail out also if the body or the next expression require substitutions
     * in order to insure correct behaviour [Bug 219166]
     */

    nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
    bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);
    if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) 
          || (bodyTokenPtr->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.
     */

    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;
    }
    TclEmitOpcode(INST_POP, envPtr);
   
    /*
     * Jump to the evaluation of the condition. This code uses the "loop
     * rotation" optimisation (which eliminates one branch from the loop).
     * "for start cond next body" produces then:
     *       start
     *       goto A
     *    B: body                : bodyCodeOffset
     *       next                : nextCodeOffset, continueOffset
     *    A: cond -> result      : testCodeOffset
     *       if (result) goto B
     */

    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);

    /*
     * Compile the loop body.
     */

    bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);

    code = TclCompileCmdWord(interp, bodyTokenPtr+1,
          bodyTokenPtr->numComponents, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;
    if (code != TCL_OK) {
      if (code == TCL_ERROR) {
          sprintf(buffer, "\n    (\"for\" body line %d)",
                interp->errorLine);
            Tcl_AddObjErrorInfo(interp, buffer, -1);
        }
      goto done;
    }
    envPtr->exceptArrayPtr[bodyRange].numCodeBytes =
          (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
    TclEmitOpcode(INST_POP, envPtr);


    /*
     * Compile the "next" subcommand.
     */

    nextCodeOffset = (envPtr->codeNext - envPtr->codeStart);

    envPtr->currStackDepth = savedStackDepth;
    code = TclCompileCmdWord(interp, nextTokenPtr+1,
          nextTokenPtr->numComponents, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;
    if (code != TCL_OK) {
      if (code == TCL_ERROR) {
          Tcl_AddObjErrorInfo(interp,
                  "\n    (\"for\" loop-end command)", -1);
      }
      goto done;
    }
    envPtr->exceptArrayPtr[nextRange].numCodeBytes =
          (envPtr->codeNext - envPtr->codeStart)
          - nextCodeOffset;
    TclEmitOpcode(INST_POP, envPtr);
    envPtr->currStackDepth = savedStackDepth;

    /*
     * Compile the test expression then emit the conditional jump that
     * terminates the for.
     */

    testCodeOffset = (envPtr->codeNext - envPtr->codeStart);

    jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
    if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
      bodyCodeOffset += 3;
      nextCodeOffset += 3;
      testCodeOffset += 3;
    }
    
    envPtr->currStackDepth = savedStackDepth;
    code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
    if (code != TCL_OK) {
      if (code == TCL_ERROR) {
          Tcl_AddObjErrorInfo(interp,
                        "\n    (\"for\" test expression)", -1);
      }
      goto done;
    }
    envPtr->currStackDepth = savedStackDepth + 1;
    
    jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
    if (jumpDist > 127) {
      TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
    } else {
      TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
    }
    
    /*
     * Set the loop's offsets and break target.
     */

    envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset;
    envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset;

    envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;

    envPtr->exceptArrayPtr[bodyRange].breakOffset =
            envPtr->exceptArrayPtr[nextRange].breakOffset =
          (envPtr->codeNext - envPtr->codeStart);
    
    /*
     * The for command's result is an empty string.
     */

    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    code = TCL_OK;

    done:
    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.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the "foreach" command
 *    at runtime.
 *
n*----------------------------------------------------------------------
 */

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;
    unsigned char *jumpPc;
    JumpFixup jumpFalseFixup;
    int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
    int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
    char buffer[32 + TCL_INTEGER_SPACE];
    int savedStackDepth = envPtr->currStackDepth;

    /*
     * 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];
    CONST char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
    int *varcList = varcListStaticSpace;
    CONST char ***varvList = varvListStaticSpace;

    /*
     * If the foreach command isn't in a procedure, don't compile it inline:
     * the payoff is too small.
     */

    if (procPtr == NULL) {
      return TCL_OUT_LINE_COMPILE;
    }

    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;
    }

    /*
     * Bail out if the body requires substitutions
     * in order to insure correct behaviour [Bug 219166]
     */
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
          i < numWords-1;
          i++, tokenPtr += (tokenPtr->numComponents + 1)) {
    }
    bodyTokenPtr = tokenPtr;
    if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
      return TCL_OUT_LINE_COMPILE;
    }

    /*
     * 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 = (CONST char ***) ckalloc(numLists * sizeof(CONST char **));
    }
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
        varcList[loopIndex] = 0;
        varvList[loopIndex] = 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;
          } else {
            /* Lots of copying going on here.  Need a ListObj wizard
             * to show a better way. */

            Tcl_DString varList;

            Tcl_DStringInit(&varList);
            Tcl_DStringAppend(&varList, tokenPtr[1].start,
                  tokenPtr[1].size);
            code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
                  &varcList[loopIndex], &varvList[loopIndex]);
            Tcl_DStringFree(&varList);
            if (code != TCL_OK) {
                goto done;
            }
            numVars = varcList[loopIndex];
            for (j = 0;  j < numVars;  j++) {
                CONST 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++) {
          CONST 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;
          }

          tempVar = (firstValueTemp + loopIndex);
          if (tempVar <= 255) {
            TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
          } else {
            TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
          }
          TclEmitOpcode(INST_POP, envPtr);
          loopIndex++;
      }
    }

    /*
     * 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);
    envPtr->currStackDepth = savedStackDepth + 1;
    if (code != TCL_OK) {
      if (code == TCL_ERROR) {
          sprintf(buffer, "\n    (\"foreach\" body line %d)",
                interp->errorLine);
            Tcl_AddObjErrorInfo(interp, buffer, -1);
        }
      goto done;
    }
    envPtr->exceptArrayPtr[range].numCodeBytes =
          (envPtr->codeNext - envPtr->codeStart)
          - envPtr->exceptArrayPtr[range].codeOffset;
    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.
     */

    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;

    done:
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
      if (varvList[loopIndex] != (CONST char **) NULL) {
          ckfree((char *) varvList[loopIndex]);
      }
    }
    if (varcList != varcListStaticSpace) {
      ckfree((char *) varcList);
        ckfree((char *) varvList);
    }
    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.
 *
 * 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;
    int jumpIndex = 0;          /* avoid compiler warning. */
    int numWords, wordIdx, numBytes, j, code;
    CONST char *word;
    char buffer[100];
    int savedStackDepth = envPtr->currStackDepth;
                                /* Saved stack depth at the start of the first
                         * test; the envPtr current depth is restored
                         * to this value at the start of each test. */
    int realCond = 1;           /* set to 0 for static conditions: "if 0 {..}" */
    int boolVal;                /* value of static condition */
    int compileScripts = 1;            

    /*
     * Only compile the "if" command if all arguments are simple
     * words, in order to insure correct substitution [Bug 219166]
     */

    tokenPtr = parsePtr->tokenPtr;
    wordIdx = 0;
    numWords = parsePtr->numWords;

    for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
      if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
          return TCL_OUT_LINE_COMPILE;
      }
      tokenPtr += 2;
    }


    TclInitJumpFixupArray(&jumpFalseFixupArray);
    TclInitJumpFixupArray(&jumpEndFixupArray);
    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;
    while (wordIdx < numWords) {
      /*
       * Stop looping if the token isn't "if" or "elseif".
       */

      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 \"%.*s\" argument",
                (numBytes > 50 ? 50 : numBytes), 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. 
       */
      
      envPtr->currStackDepth = savedStackDepth;
      testTokenPtr = tokenPtr;


      if (realCond) {
          /*
           * Find out if the condition is a constant. 
           */
      
          Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
                testTokenPtr[1].size);
          Tcl_IncrRefCount(boolObj);
          code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
          Tcl_DecrRefCount(boolObj);
          if (code == TCL_OK) {
            /*
             * A static condition
             */
            realCond = 0;
            if (!boolVal) {
                compileScripts = 0;
            }
          } else {
            Tcl_ResetResult(interp);
            code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
            if (code != TCL_OK) {
                if (code == TCL_ERROR) {
                  Tcl_AddObjErrorInfo(interp,
                          "\n    (\"if\" test expression)", -1);
                }
                goto done;
            }
            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 \"%.*s\" argument",
                (testTokenPtr->size > 50 ? 50 : testTokenPtr->size),
                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.
       */

      if (compileScripts) {
          envPtr->currStackDepth = savedStackDepth;
          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;
          } 
      }

      if (realCond) {
          /*
           * 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;
          }
      } else if (boolVal) {
          /* 
           *We were processing an "if 1 {...}"; stop compiling
           * scripts
           */

          compileScripts = 0;
      } else {
          /* 
           *We were processing an "if 0 {...}"; reset so that
           * the rest (elseif, else) is compiled correctly
           */

          realCond = 1;
          compileScripts = 1;
      } 

      tokenPtr += (tokenPtr->numComponents + 1);
      wordIdx++;
    }

    /*
     * Restore the current stack depth in the environment; the 
     * "else" clause (or its default) will add 1 to this.
     */

    envPtr->currStackDepth = savedStackDepth;

    /*
     * Check for the optional else clause. Do not compile
     * anything if this was an "if 1 {...}" case.
     */

    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;
          }
      }

      if (compileScripts) {
          /*
           * 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;
          }
      }

      /*
       * 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.
       */

      if (compileScripts) {
          TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
      }
    }

    /*
     * 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:
    envPtr->currStackDepth = savedStackDepth + 1;
    TclFreeJumpFixupArray(&jumpFalseFixupArray);
    TclFreeJumpFixupArray(&jumpEndFixupArray);
    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.
 *
 * 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;
    int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
    int code = TCL_OK;

    if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
      Tcl_ResetResult(interp);
      Tcl_AppendToObj(Tcl_GetObjResult(interp),
              "wrong # args: should be \"incr varName ?increment?\"", -1);
      return TCL_ERROR;
    }

    varTokenPtr = parsePtr->tokenPtr
          + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarName(interp, varTokenPtr, envPtr, 
          (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR),
          &localIndex, &simpleVarName, &isScalar);
    if (code != TCL_OK) {
      goto done;
    }

    /*
     * If an increment is given, push it, but see first if it's a small
     * integer.
     */

    haveImmValue = 0;
    immValue = 1;
    if (parsePtr->numWords == 3) {
      incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
      if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
          CONST char *word = incrTokenPtr[1].start;
          int numBytes = incrTokenPtr[1].size;

          /*
           * Note there is a danger that modifying the string could have
           * undesirable side effects.  In this case, TclLooksLikeInt has
           * no dependencies on shared strings so we should be safe.
           */

          if (TclLooksLikeInt(word, numBytes)) {
            int code;
            Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
            Tcl_IncrRefCount(intObj);
            code = Tcl_GetIntFromObj(NULL, intObj, &immValue);
            Tcl_DecrRefCount(intObj);
            if ((code == TCL_OK)
                  && (-127 <= immValue) && (immValue <= 127)) {
                haveImmValue = 1;
            }
          }
          if (!haveImmValue) {
            TclEmitPush(
                  TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
          }
      } else {
          code = TclCompileTokens(interp, incrTokenPtr+1, 
                  incrTokenPtr->numComponents, envPtr);
          if (code != TCL_OK) {
            goto done;
          }
      }
    } else {                  /* no incr amount given so use 1 */
      haveImmValue = 1;
    }
    
    /*
     * Emit the instruction to increment the variable.
     */

    if (simpleVarName) {
      if (isScalar) {
          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:
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLappendCmd --
 *
 *    Procedure called to compile the "lappend" command.
 *
 * Results:
 *    The return value is a standard Tcl result, which is normally TCL_OK
 *    unless there was an error while parsing string. If an error occurs
 *    then the interpreter's result contains a standard error message. If
 *    complation fails because the command requires a second level of
 *    substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
 *    command should be compiled "out of line" by emitting code to
 *    invoke its command procedure (Tcl_LappendObjCmd) at runtime.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the "lappend" command
 *    at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLappendCmd(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;
    int simpleVarName, isScalar, localIndex, numWords;
    int code = TCL_OK;

    /*
     * If we're not in a procedure, don't compile.
     */
    if (envPtr->procPtr == NULL) {
      return TCL_OUT_LINE_COMPILE;
    }

    numWords = parsePtr->numWords;
    if (numWords == 1) {
      Tcl_ResetResult(interp);
      Tcl_AppendToObj(Tcl_GetObjResult(interp),
            "wrong # args: should be \"lappend varName ?value value ...?\"", -1);
      return TCL_ERROR;
    }
    if (numWords != 3) {
      /*
       * LAPPEND instructions currently only handle one value appends
       */
        return TCL_OUT_LINE_COMPILE;
    }

    /*
     * 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. 
     */

    varTokenPtr = parsePtr->tokenPtr
          + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
          &localIndex, &simpleVarName, &isScalar);
    if (code != TCL_OK) {
      goto done;
    }

    /*
     * If we are doing an assignment, push the new value.
     * In the no values case, create an empty object.
     */

    if (numWords > 2) {
      valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
      if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
          TclEmitPush(TclRegisterNewLiteral(envPtr, 
                valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
      } else {
          code = TclCompileTokens(interp, valueTokenPtr+1,
                  valueTokenPtr->numComponents, envPtr);
          if (code != TCL_OK) {
            goto done;
          }
      }
    }

    /*
     * Emit instructions to set/get the variable.
     */

    /*
     * The *_STK opcodes should be refactored to make better use of existing
     * LOAD/STORE instructions.
     */
    if (simpleVarName) {
      if (isScalar) {
          if (localIndex >= 0) {
            if (localIndex <= 255) {
                TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
            } else {
                TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
            }
          } else {
            TclEmitOpcode(INST_LAPPEND_STK, envPtr);
          }
      } else {
          if (localIndex >= 0) {
            if (localIndex <= 255) {
                TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
            } else {
                TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
            }
          } else {
            TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
          }
      }
    } else {
      TclEmitOpcode(INST_LAPPEND_STK, envPtr);
    }

    done:
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLindexCmd --
 *
 *    Procedure called to compile the "lindex" command.
 *
 * Results:
 *    The return value is a standard Tcl result, which is TCL_OK if the
 *    compilation was successful.  If the command cannot be byte-compiled,
 *    TCL_OUT_LINE_COMPILE is returned.  If an error occurs then the
 *    interpreter's result contains an error message, and TCL_ERROR is
 *    returned.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the "lindex" command
 *    at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLindexCmd(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;
    int code, i;

    int numWords;
    numWords = parsePtr->numWords;

    /*
     * Quit if too few args
     */

    if ( numWords <= 1 ) {
      return TCL_OUT_LINE_COMPILE;
    }

    varTokenPtr = parsePtr->tokenPtr
      + (parsePtr->tokenPtr->numComponents + 1);
    
    /*
     * Push the operands onto the stack.
     */
      
    for ( i = 1 ; i < numWords ; i++ ) {
      if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
          TclEmitPush(
                TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
                varTokenPtr[1].size), envPtr);
      } else {
          code = TclCompileTokens(interp, varTokenPtr+1,
                            varTokenPtr->numComponents, envPtr);
          if (code != TCL_OK) {
            return code;
          }
      }
      varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
    }
      
    /*
     * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI
     * if there are multiple index args.
     */

    if ( numWords == 3 ) {
      TclEmitOpcode( INST_LIST_INDEX, envPtr );
    } else {
      TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr );
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileListCmd --
 *
 *    Procedure called to compile the "list" command.
 *
 * Results:
 *    The return value is a standard Tcl result, which is normally TCL_OK
 *    unless there was an error while parsing string. If an error occurs
 *    then the interpreter's result contains a standard error message. If
 *    complation fails because the command requires a second level of
 *    substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
 *    command should be compiled "out of line" by emitting code to
 *    invoke its command procedure (Tcl_ListObjCmd) at runtime.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the "list" command
 *    at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileListCmd(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 we're not in a procedure, don't compile.
     */
    if (envPtr->procPtr == NULL) {
      return TCL_OUT_LINE_COMPILE;
    }

    if (parsePtr->numWords == 1) {
      /*
       * Empty args case
       */

      TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    } else {
      /*
       * Push the all values onto the stack.
       */
      Tcl_Token *valueTokenPtr;
      int i, code, numWords;

      numWords = parsePtr->numWords;

      valueTokenPtr = parsePtr->tokenPtr
          + (parsePtr->tokenPtr->numComponents + 1);
      for (i = 1; i < numWords; i++) {
          if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
            TclEmitPush(TclRegisterNewLiteral(envPtr,
                  valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
          } else {
            code = TclCompileTokens(interp, valueTokenPtr+1,
                  valueTokenPtr->numComponents, envPtr);
            if (code != TCL_OK) {
                return code;
            }
          }
          valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);
      }
      TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLlengthCmd --
 *
 *    Procedure called to compile the "llength" command.
 *
 * Results:
 *    The return value is a standard Tcl result, which is TCL_OK if the
 *    compilation was successful.  If the command cannot be byte-compiled,
 *    TCL_OUT_LINE_COMPILE is returned.  If an error occurs then the
 *    interpreter's result contains an error message, and TCL_ERROR is
 *    returned.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the "llength" command
 *    at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLlengthCmd(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;
    int code;

    if (parsePtr->numWords != 2) {
      Tcl_SetResult(interp, "wrong # args: should be \"llength list\"",
            TCL_STATIC);
      return TCL_ERROR;
    }
    varTokenPtr = parsePtr->tokenPtr
      + (parsePtr->tokenPtr->numComponents + 1);

    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
      /*
       * We could simply count the number of elements here and push
       * that value, but that is too rare a case to waste the code space.
       */
      TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
            varTokenPtr[1].size), envPtr);
    } else {
      code = TclCompileTokens(interp, varTokenPtr+1,
            varTokenPtr->numComponents, envPtr);
      if (code != TCL_OK) {
          return code;
      }
    }
    TclEmitOpcode(INST_LIST_LENGTH, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLsetCmd --
 *
 *    Procedure called to compile the "lset" command.
 *
 * Results:
 *    The return value is a standard Tcl result, which is TCL_OK if
 *    the compilation was successful.  If the "lset" command is too
 *    complex for this function, then TCL_OUT_LINE_COMPILE is returned,
 *    indicating that the command should be compiled "out of line"
 *    (that is, not byte-compiled).  If an error occurs, TCL_ERROR is
 *    returned, and the interpreter result contains an error message.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the "lset" command
 *    at runtime.
 *
 * The general template for execution of the "lset" command is:
 *    (1) Instructions to push the variable name, unless the
 *        variable is local to the stack frame.
 *    (2) If the variable is an array element, instructions
 *        to push the array element name.
 *    (3) Instructions to push each of zero or more "index" arguments
 *        to the stack, followed with the "newValue" element.
 *    (4) Instructions to duplicate the variable name and/or array
 *        element name onto the top of the stack, if either was
 *        pushed at steps (1) and (2).
 *    (5) The appropriate INST_LOAD_* instruction to place the
 *        original value of the list variable at top of stack.
 *    (6) At this point, the stack contains:
 *         varName? arrayElementName? index1 index2 ... newValue oldList
 *        The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
 *        according as whether there is exactly one index element (LIST)
 *        or either zero or else two or more (FLAT).  This instruction
 *        removes everything from the stack except for the two names
 *        and pushes the new value of the variable.
 *    (7) Finally, INST_STORE_* stores the new value in the variable
 *        and cleans up the stack.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLsetCmd( interp, parsePtr, envPtr )
    Tcl_Interp* interp;       /* Tcl interpreter for error reporting */
    Tcl_Parse* parsePtr;      /* Points to a parse structure for
                         * the command */
    CompileEnv* envPtr;       /* Holds the resulting instructions */
{

    int tempDepth;            /* Depth used for emitting one part
                         * of the code burst. */
    Tcl_Token* varTokenPtr;   /* Pointer to the Tcl_Token representing
                         * the parse of the variable name */

    int result;               /* Status return from library calls */

    int localIndex;           /* Index of var in local var table */
    int simpleVarName;        /* Flag == 1 if var name is simple */
    int isScalar;       /* Flag == 1 if scalar, 0 if array */

    int i;

    /* Check argument count */

    if ( parsePtr->numWords < 3 ) {
      /* Fail at run time, not in compilation */
      return TCL_OUT_LINE_COMPILE;
    }

    /*
     * 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. 
     */

    varTokenPtr = parsePtr->tokenPtr
          + (parsePtr->tokenPtr->numComponents + 1);
    result = TclPushVarName( interp, varTokenPtr, envPtr, 
            TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar );
    if (result != TCL_OK) {
      return result;
    }

    /* Push the "index" args and the new element value. */

    for ( i = 2; i < parsePtr->numWords; ++i ) {

      /* Advance to next arg */

      varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);

      /* Push an arg */

      if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
          TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
                varTokenPtr[1].size), envPtr);
      } else {
          result = TclCompileTokens(interp, varTokenPtr+1,
                              varTokenPtr->numComponents, envPtr);
          if ( result != TCL_OK ) {
            return result;
          }
      }
    }

    /*
     * Duplicate the variable name if it's been pushed.  
     */

    if ( !simpleVarName || localIndex < 0 ) {
      if ( !simpleVarName || isScalar ) {
          tempDepth = parsePtr->numWords - 2;
      } else {
          tempDepth = parsePtr->numWords - 1;
      }
      TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
    }

    /*
     * Duplicate an array index if one's been pushed
     */

    if ( simpleVarName && !isScalar ) {
      if ( localIndex < 0 ) {
          tempDepth = parsePtr->numWords - 1;
      } else {
          tempDepth = parsePtr->numWords - 2;
      }
      TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
    }

    /*
     * Emit code to load the variable's value.
     */

    if ( !simpleVarName ) {
      TclEmitOpcode( INST_LOAD_STK, envPtr );
    } else if ( isScalar ) {
      if ( localIndex < 0 ) {
          TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr );
      } else if ( localIndex < 0x100 ) {
          TclEmitInstInt1( INST_LOAD_SCALAR1, localIndex, envPtr );
      } else {
          TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr );
      }
    } else {
      if ( localIndex < 0 ) {
          TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr );
      } else if ( localIndex < 0x100 ) {
          TclEmitInstInt1( INST_LOAD_ARRAY1, localIndex, envPtr );
      } else {
          TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr );
      }
    }

    /*
     * Emit the correct variety of 'lset' instruction
     */

    if ( parsePtr->numWords == 4 ) {
      TclEmitOpcode( INST_LSET_LIST, envPtr );
    } else {
      TclEmitInstInt4( INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr );
    }

    /*
     * Emit code to put the value back in the variable
     */

    if ( !simpleVarName ) {
      TclEmitOpcode( INST_STORE_STK, envPtr );
    } else if ( isScalar ) {
      if ( localIndex < 0 ) {
          TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr );
      } else if ( localIndex < 0x100 ) {
          TclEmitInstInt1( INST_STORE_SCALAR1, localIndex, envPtr );
      } else {
          TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr );
      }
    } else {
      if ( localIndex < 0 ) {
          TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr );
      } else if ( localIndex < 0x100 ) {
          TclEmitInstInt1( INST_STORE_ARRAY1, localIndex, envPtr );
      } else {
          TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr );
      }
    }
    
    return TCL_OK;

}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileRegexpCmd --
 *
 *    Procedure called to compile the "regexp" command.
 *
 * Results:
 *    The return value is a standard Tcl result, which is TCL_OK if
 *    the compilation was successful.  If the "regexp" command is too
 *    complex for this function, then TCL_OUT_LINE_COMPILE is returned,
 *    indicating that the command should be compiled "out of line"
 *    (that is, not byte-compiled).  If an error occurs, TCL_ERROR is
 *    returned, and the interpreter result contains an error message.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the "regexp" command
 *    at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileRegexpCmd(interp, parsePtr, envPtr)
    Tcl_Interp* interp;       /* Tcl interpreter for error reporting */
    Tcl_Parse* parsePtr;      /* Points to a parse structure for
                         * the command */
    CompileEnv* envPtr;       /* Holds the resulting instructions */
{
    Tcl_Token *varTokenPtr;   /* Pointer to the Tcl_Token representing
                         * the parse of the RE or string */
    int i, len, code, nocase, anchorLeft, anchorRight, start;
    char *str;

    /*
     * We are only interested in compiling simple regexp cases.
     * Currently supported compile cases are:
     *   regexp ?-nocase? ?--? staticString $var
     *   regexp ?-nocase? ?--? {^staticString$} $var
     */
    if (parsePtr->numWords < 3) {
      return TCL_OUT_LINE_COMPILE;
    }

    nocase = 0;
    varTokenPtr = parsePtr->tokenPtr;

    /*
     * We only look for -nocase and -- as options.  Everything else
     * gets pushed to runtime execution.  This is different than regexp's
     * runtime option handling, but satisfies our stricter needs.
     */
    for (i = 1; i < parsePtr->numWords - 2; i++) {
      varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
      if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
          /* Not a simple string - punt to runtime. */
          return TCL_OUT_LINE_COMPILE;
      }
      str = (char *) varTokenPtr[1].start;
      len = varTokenPtr[1].size;
      if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
          i++;
          break;
      } else if ((len > 1)
            && (strncmp(str, "-nocase", (unsigned) len) == 0)) {
          nocase = 1;
      } else {
          /* Not an option we recognize. */
          return TCL_OUT_LINE_COMPILE;
      }
    }

    if ((parsePtr->numWords - i) != 2) {
      /* We don't support capturing to variables */
      return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Get the regexp string.  If it is not a simple string, punt to runtime.
     * If it has a '-', it could be an incorrectly formed regexp command.
     */
    varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
    str = (char *) varTokenPtr[1].start;
    len = varTokenPtr[1].size;
    if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) {
      return TCL_OUT_LINE_COMPILE;
    }

    if (len == 0) {
      /*
       * The semantics of regexp are always match on re == "".
       */
      TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
      return TCL_OK;
    }

    /*
     * Make a copy of the string that is null-terminated for checks which
     * require such.
     */
    str = (char *) ckalloc((unsigned) len + 1);
    strncpy(str, varTokenPtr[1].start, (size_t) len);
    str[len] = '\0';
    start = 0;

    /*
     * Check for anchored REs (ie ^foo$), so we can use string equal if
     * possible. Do not alter the start of str so we can free it correctly.
     */
    if (str[0] == '^') {
      start++;
      anchorLeft = 1;
    } else {
      anchorLeft = 0;
    }
    if ((str[len-1] == '$') && ((len == 1) || (str[len-2] != '\\'))) {
      anchorRight = 1;
      str[--len] = '\0';
    } else {
      anchorRight = 0;
    }

    /*
     * On the first (pattern) arg, check to see if any RE special characters
     * are in the word.  If not, this is the same as 'string equal'.
     */
    if ((len > (1+start)) && (str[start] == '.') && (str[start+1] == '*')) {
      start += 2;
      anchorLeft = 0;
    }
    if ((len > (2+start)) && (str[len-3] != '\\')
          && (str[len-2] == '.') && (str[len-1] == '*')) {
      len -= 2;
      str[len] = '\0';
      anchorRight = 0;
    }

    /*
     * Don't do anything with REs with other special chars.  Also check if
     * this is a bad RE (do this at the end because it can be expensive).
     * If so, let it complain at runtime.
     */
    if ((strpbrk(str + start, "*+?{}()[].\\|^$") != NULL)
          || (Tcl_RegExpCompile(NULL, str) == NULL)) {
      ckfree((char *) str);
      return TCL_OUT_LINE_COMPILE;
    }

    if (anchorLeft && anchorRight) {
      TclEmitPush(TclRegisterNewLiteral(envPtr, str+start, len-start),
            envPtr);
    } else {
      /*
       * This needs to find the substring anywhere in the string, so
       * use string match and *foo*, with appropriate anchoring.
       */
      char *newStr  = ckalloc((unsigned) len + 3);
      len -= start;
      if (anchorLeft) {
          strncpy(newStr, str + start, (size_t) len);
      } else {
          newStr[0] = '*';
          strncpy(newStr + 1, str + start, (size_t) len++);
      }
      if (!anchorRight) {
          newStr[len++] = '*';
      }
      newStr[len] = '\0';
      TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len), envPtr);
      ckfree((char *) newStr);
    }
    ckfree((char *) str);

    /*
     * Push the string arg
     */
    varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
      TclEmitPush(TclRegisterNewLiteral(envPtr,
            varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
    } else {
      code = TclCompileTokens(interp, varTokenPtr+1,
            varTokenPtr->numComponents, envPtr);
      if (code != TCL_OK) {
          return code;
      }
    }

    if (anchorLeft && anchorRight && !nocase) {
      TclEmitOpcode(INST_STR_EQ, envPtr);
    } else {
      TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileReturnCmd --
 *
 *    Procedure called to compile the "return" command.
 *
 * Results:
 *    The return value is a standard Tcl result, which is TCL_OK if the
 *    compilation was successful.  If the particular return command is
 *    too complex for this function (ie, return with any flags like "-code"
 *    or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that
 *    the command should be compiled "out of line" (eg, not byte compiled).
 *    If an error occurs then the interpreter's result contains a standard
 *    error message.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the "return" command
 *    at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileReturnCmd(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;
    int code;
    int index = envPtr->exceptArrayNext - 1;

    /*
     * If we're not in a procedure, don't compile.
     */

    if (envPtr->procPtr == NULL) {
      return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Look back through the ExceptionRanges of the current CompileEnv,
     * from exceptArrayPtr[(exceptArrayNext - 1)] down to 
     * exceptArrayPtr[0] to see if any of them is an enclosing [catch].
     * If there's an enclosing [catch], don't compile.
     */

    while (index >= 0) {
      ExceptionRange range = envPtr->exceptArrayPtr[index];
      if ((range.type == CATCH_EXCEPTION_RANGE) 
            && (range.catchOffset == -1)) {
          return TCL_OUT_LINE_COMPILE;
      }
      index--;
    }

    switch (parsePtr->numWords) {
      case 1: {
          /*
           * Simple case:  [return]
           * Just push the literal string "".
           */
          TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
          break;
      }
      case 2: {
          /*
           * More complex cases:
           * [return "foo"]
           * [return $value]
           * [return [otherCmd]]
           */
          varTokenPtr = parsePtr->tokenPtr
            + (parsePtr->tokenPtr->numComponents + 1);
          if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
            /*
             * [return "foo"] case:  the parse token is a simple word,
             * so just push it.
             */
            TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
                  varTokenPtr[1].size), envPtr);
          } else {
            /*
             * Parse token is more complex, so compile it; this handles the
             * variable reference and nested command cases.  If the
             * parse token can be byte-compiled, then this instance of
             * "return" will be byte-compiled; otherwise it will be
             * out line compiled.
             */
            code = TclCompileTokens(interp, varTokenPtr+1,
                  varTokenPtr->numComponents, envPtr);
            if (code != TCL_OK) {
                return code;
            }
          }
          break;
      }
      default: {
          /*
           * Most complex return cases: everything else, including
           * [return -code error], etc.
           */
          return TCL_OUT_LINE_COMPILE;
      }
    }

    /*
     * The INST_DONE opcode actually causes the branching out of the
     * subroutine, and takes the top stack item as the return result
     * (which is why we pushed the value above).
     */
    TclEmitOpcode(INST_DONE, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * 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;
    int isAssignment, isScalar, simpleVarName, localIndex, numWords;
    int code = TCL_OK;

    numWords = parsePtr->numWords;
    if ((numWords != 2) && (numWords != 3)) {
      Tcl_ResetResult(interp);
      Tcl_AppendToObj(Tcl_GetObjResult(interp),
              "wrong # args: should be \"set varName ?newValue?\"", -1);
        return TCL_ERROR;
    }
    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. 
     */

    varTokenPtr = parsePtr->tokenPtr
          + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
          &localIndex, &simpleVarName, &isScalar);
    if (code != TCL_OK) {
      goto done;
    }

    /*
     * If we are doing an assignment, push the new value.
     */

    if (isAssignment) {
      valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
      if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
          TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
                valueTokenPtr[1].size), envPtr);
      } else {
          code = TclCompileTokens(interp, valueTokenPtr+1,
                  valueTokenPtr->numComponents, envPtr);
          if (code != TCL_OK) {
            goto done;
          }
      }
    }

    /*
     * Emit instructions to set/get the variable.
     */

    if (simpleVarName) {
      if (isScalar) {
          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:
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileStringCmd --
 *
 *    Procedure called to compile the "string" command.
 *
 * Results:
 *    The return value is a standard Tcl result, which is TCL_OK if the
 *    compilation was successful.  If the command cannot be byte-compiled,
 *    TCL_OUT_LINE_COMPILE is returned.  If an error occurs then the
 *    interpreter's result contains an error message, and TCL_ERROR is
 *    returned.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the "string" command
 *    at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileStringCmd(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 *opTokenPtr, *varTokenPtr;
    Tcl_Obj *opObj;
    int index;
    int code;
    
    static CONST char *options[] = {
      "bytelength",     "compare",  "equal",    "first",
      "index",    "is",       "last",           "length",
      "map",            "match",    "range",    "repeat",
      "replace",  "tolower",  "toupper",  "totitle",
      "trim",           "trimleft", "trimright",
      "wordend",  "wordstart",      (char *) NULL
    };
    enum options {
      STR_BYTELENGTH,   STR_COMPARE,      STR_EQUAL,  STR_FIRST,
      STR_INDEX,  STR_IS,           STR_LAST,   STR_LENGTH,
      STR_MAP,    STR_MATCH,  STR_RANGE,  STR_REPEAT,
      STR_REPLACE,      STR_TOLOWER,      STR_TOUPPER,      STR_TOTITLE,
      STR_TRIM,   STR_TRIMLEFT,     STR_TRIMRIGHT,
      STR_WORDEND,      STR_WORDSTART
    };        

    if (parsePtr->numWords < 2) {
      /* Fail at run time, not in compilation */
      return TCL_OUT_LINE_COMPILE;
    }
    opTokenPtr = parsePtr->tokenPtr
      + (parsePtr->tokenPtr->numComponents + 1);

    opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size);
    if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0,
          &index) != TCL_OK) {
      Tcl_DecrRefCount(opObj);
      Tcl_ResetResult(interp);
      return TCL_OUT_LINE_COMPILE;
    }
    Tcl_DecrRefCount(opObj);

    varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1);

    switch ((enum options) index) {
      case STR_BYTELENGTH:
      case STR_FIRST:
      case STR_IS:
      case STR_LAST:
      case STR_MAP:
      case STR_RANGE:
      case STR_REPEAT:
      case STR_REPLACE:
      case STR_TOLOWER:
      case STR_TOUPPER:
      case STR_TOTITLE:
      case STR_TRIM:
      case STR_TRIMLEFT:
      case STR_TRIMRIGHT:
      case STR_WORDEND:
      case STR_WORDSTART:
          /*
           * All other cases: compile out of line.
           */
          return TCL_OUT_LINE_COMPILE;

      case STR_COMPARE: 
      case STR_EQUAL: {
          int i;
          /*
           * If there are any flags to the command, we can't byte compile it
           * because the INST_STR_EQ bytecode doesn't support flags.
           */

          if (parsePtr->numWords != 4) {
            return TCL_OUT_LINE_COMPILE;
          }

          /*
           * Push the two operands onto the stack.
           */

          for (i = 0; i < 2; i++) {
            if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
                TclEmitPush(TclRegisterNewLiteral(envPtr,
                      varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
            } else {
                code = TclCompileTokens(interp, varTokenPtr+1,
                      varTokenPtr->numComponents, envPtr);
                if (code != TCL_OK) {
                  return code;
                }
            }
            varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
          }

          TclEmitOpcode(((((enum options) index) == STR_COMPARE) ?
                INST_STR_CMP : INST_STR_EQ), envPtr);
          return TCL_OK;
      }
      case STR_INDEX: {
          int i;

          if (parsePtr->numWords != 4) {
            /* Fail at run time, not in compilation */
            return TCL_OUT_LINE_COMPILE;
          }

          /*
           * Push the two operands onto the stack.
           */

          for (i = 0; i < 2; i++) {
            if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
                TclEmitPush(TclRegisterNewLiteral(envPtr,
                      varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
            } else {
                code = TclCompileTokens(interp, varTokenPtr+1,
                      varTokenPtr->numComponents, envPtr);
                if (code != TCL_OK) {
                  return code;
                }
            }
            varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
          }

          TclEmitOpcode(INST_STR_INDEX, envPtr);
          return TCL_OK;
      }
      case STR_LENGTH: {
          if (parsePtr->numWords != 3) {
            /* Fail at run time, not in compilation */
            return TCL_OUT_LINE_COMPILE;
          }

          if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
            /*
             * Here someone is asking for the length of a static string.
             * Just push the actual character (not byte) length.
             */
            char buf[TCL_INTEGER_SPACE];
            int len = Tcl_NumUtfChars(varTokenPtr[1].start,
                  varTokenPtr[1].size);
            len = sprintf(buf, "%d", len);
            TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
            return TCL_OK;
          } else {
            code = TclCompileTokens(interp, varTokenPtr+1,
                  varTokenPtr->numComponents, envPtr);
            if (code != TCL_OK) {
                return code;
            }
          }
          TclEmitOpcode(INST_STR_LEN, envPtr);
          return TCL_OK;
      }
      case STR_MATCH: {
          int i, length, exactMatch = 0, nocase = 0;
          CONST char *str;

          if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
            /* Fail at run time, not in compilation */
            return TCL_OUT_LINE_COMPILE;
          }

          if (parsePtr->numWords == 5) {
            if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
                return TCL_OUT_LINE_COMPILE;
            }
            str    = varTokenPtr[1].start;
            length = varTokenPtr[1].size;
            if ((length > 1) &&
                  strncmp(str, "-nocase", (size_t) length) == 0) {
                nocase = 1;
            } else {
                /* Fail at run time, not in compilation */
                return TCL_OUT_LINE_COMPILE;
            }
            varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
          }

          for (i = 0; i < 2; i++) {
            if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
                str = varTokenPtr[1].start;
                length = varTokenPtr[1].size;
                if (!nocase && (i == 0)) {
                  /*
                   * On the first (pattern) arg, check to see if any
                   * glob special characters are in the word '*[]?\\'.
                   * If not, this is the same as 'string equal'.  We
                   * can use strpbrk here because the glob chars are all
                   * in the ascii-7 range.  If -nocase was specified,
                   * we can't do this because INST_STR_EQ has no support
                   * for nocase.
                   */
                  Tcl_Obj *copy = Tcl_NewStringObj(str, length);
                  Tcl_IncrRefCount(copy);
                  exactMatch = (strpbrk(Tcl_GetString(copy),
                        "*[]?\\") == NULL);
                  Tcl_DecrRefCount(copy);
                }
                TclEmitPush(
                      TclRegisterNewLiteral(envPtr, str, length), envPtr);
            } else {
                code = TclCompileTokens(interp, varTokenPtr+1,
                      varTokenPtr->numComponents, envPtr);
                if (code != TCL_OK) {
                  return code;
                }
            }
            varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
          }

          if (exactMatch) {
            TclEmitOpcode(INST_STR_EQ, envPtr);
          } else {
            TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
          }
          return TCL_OK;
      }
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileVariableCmd --
 *
 *    Procedure called to reserve the local variables for the 
 *      "variable" command. The command itself is *not* compiled.
 *
 * Results:
 *      Always returns TCL_OUT_LINE_COMPILE.
 *
 * Side effects:
 *      Indexed local variables are added to the environment.
 *
 *----------------------------------------------------------------------
 */
int
TclCompileVariableCmd(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;
    int i, numWords;
    CONST char *varName, *tail;
    
    if (envPtr->procPtr == NULL) {
      return TCL_OUT_LINE_COMPILE;
    }

    numWords = parsePtr->numWords;
    
    varTokenPtr = parsePtr->tokenPtr
      + (parsePtr->tokenPtr->numComponents + 1);
    for (i = 1; i < numWords; i += 2) {
      if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
          varName = varTokenPtr[1].start;
          tail = varName + varTokenPtr[1].size - 1;
          if ((*tail == ')') || (tail < varName)) continue;
          while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
            tail--;
          }
          if ((*tail == ':') && (tail > varName)) {
            tail++;
          }
          (void) TclFindCompiledLocal(tail, (tail-varName+1),
                /*create*/ 1, /*flags*/ 0, envPtr->procPtr);
          varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
      }
    }
    return TCL_OUT_LINE_COMPILE;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * 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 jumpEvalCondFixup;
    int testCodeOffset, bodyCodeOffset, jumpDist;
    int range, code;
    char buffer[32 + TCL_INTEGER_SPACE];
    int savedStackDepth = envPtr->currStackDepth;
    int loopMayEnd = 1;         /* This is set to 0 if it is recognized as
                         * an infinite loop. */
    Tcl_Obj *boolObj;
    int boolVal;

    if (parsePtr->numWords != 3) {
      Tcl_ResetResult(interp);
      Tcl_AppendToObj(Tcl_GetObjResult(interp),
              "wrong # args: should be \"while test command\"", -1);
      return TCL_ERROR;
    }

    /*
     * 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" {}".
     *
     * Bail out also if the body expression requires substitutions
     * in order to insure correct behaviour [Bug 219166]
     */

    testTokenPtr = parsePtr->tokenPtr
          + (parsePtr->tokenPtr->numComponents + 1);
    bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
    if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
          || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
      return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Find out if the condition is a constant. 
     */

    boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
    Tcl_IncrRefCount(boolObj);
    code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
    Tcl_DecrRefCount(boolObj);
    if (code == TCL_OK) {
      if (boolVal) {
          /*
           * it is an infinite loop 
           */

          loopMayEnd = 0;  
      } else {
          /*
           * This is an empty loop: "while 0 {...}" or such.
           * Compile no bytecodes.
           */

          goto pushResult;
      }
    }

    /* 
     * 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);

    /*
     * Jump to the evaluation of the condition. This code uses the "loop
     * rotation" optimisation (which eliminates one branch from the loop).
     * "while cond body" produces then:
     *       goto A
     *    B: body                : bodyCodeOffset
     *    A: cond -> result      : testCodeOffset, continueOffset
     *       if (result) goto B
     *
     * The infinite loop "while 1 body" produces:
     *    B: body                : all three offsets here
     *       goto B
     */

    if (loopMayEnd) {
      TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
      testCodeOffset = 0; /* avoid compiler warning */
    } else {
      testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
    }
    

    /*
     * Compile the loop body.
     */

    bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
    code = TclCompileCmdWord(interp, bodyTokenPtr+1,
          bodyTokenPtr->numComponents, envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;
    if (code != TCL_OK) {
      if (code == TCL_ERROR) {
          sprintf(buffer, "\n    (\"while\" body line %d)",
                interp->errorLine);
            Tcl_AddObjErrorInfo(interp, buffer, -1);
        }
      goto error;
    }
    envPtr->exceptArrayPtr[range].numCodeBytes =
          (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
    TclEmitOpcode(INST_POP, envPtr);

    /*
     * Compile the test expression then emit the conditional jump that
     * terminates the while. We already know it's a simple word.
     */

    if (loopMayEnd) {
      testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
      jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
      if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
          bodyCodeOffset += 3;
          testCodeOffset += 3;
      }
      envPtr->currStackDepth = savedStackDepth;
      code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
      if (code != TCL_OK) {
          if (code == TCL_ERROR) {
            Tcl_AddObjErrorInfo(interp,
                            "\n    (\"while\" test expression)", -1);
          }
          goto error;
      }
      envPtr->currStackDepth = savedStackDepth + 1;
    
      jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
      if (jumpDist > 127) {
          TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
      } else {
          TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
      }
    } else {
      jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
      if (jumpDist > 127) {
          TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
      } else {
          TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
      }     
    }


    /*
     * Set the loop's body, continue and break offsets.
     */

    envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
    envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
    envPtr->exceptArrayPtr[range].breakOffset =
          (envPtr->codeNext - envPtr->codeStart);
    
    /*
     * The while command's result is an empty string.
     */

    pushResult:
    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    envPtr->exceptDepth--;
    return TCL_OK;

    error:
    envPtr->exceptDepth--;
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPushVarName --
 *
 *    Procedure used in the compiling where pushing a variable name
 *    is necessary (append, lappend, set).
 *
 * Results:
 *    The return value is a standard Tcl result, which is normally TCL_OK
 *    unless there was an error while parsing string. If an error occurs
 *    then the interpreter's result contains a standard error message.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the "set" command
 *    at runtime.
 *
 *----------------------------------------------------------------------
 */

static int
TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
      simpleVarNamePtr, isScalarPtr)
    Tcl_Interp *interp;       /* Used for error reporting. */
    Tcl_Token *varTokenPtr;   /* Points to a variable token. */
    CompileEnv *envPtr;       /* Holds resulting instructions. */
    int flags;                /* takes TCL_CREATE_VAR or
                         * TCL_NO_LARGE_INDEX */
    int *localIndexPtr;       /* must not be NULL */
    int *simpleVarNamePtr;    /* must not be NULL */
    int *isScalarPtr;         /* must not be NULL */
{
    register CONST char *p;
    CONST char *name, *elName;
    register int i, n;
    int nameChars, elNameChars, simpleVarName, localIndex;
    int code = TCL_OK;

    Tcl_Token *elemTokenPtr = NULL;
    int elemTokenCount = 0;
    int allocedTokens = 0;
    int removedParen = 0;

    /*
     * 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;

    /*
     * 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.
     */

    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.
       */
      simpleVarName = 1;

      name = varTokenPtr[1].start;
      nameChars = varTokenPtr[1].size;
      if ( *(name + nameChars - 1) == ')') {
          /* 
           * last char is ')' => potential array reference.
           */

          for (i = 0, p = name;  i < nameChars;  i++, p++) {
            if (*p == '(') {
                elName = p + 1;
                elNameChars = nameChars - i - 2;
                nameChars = i ;
                break;
            }
          }

          if ((elName != NULL) && elNameChars) {
            /*
             * An array element, the element name is a simple
             * string: assemble the corresponding token.
             */

            elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token));
            allocedTokens = 1;
            elemTokenPtr->type = TCL_TOKEN_TEXT;
            elemTokenPtr->start = elName;
            elemTokenPtr->size = elNameChars;
            elemTokenPtr->numComponents = 0;
            elemTokenCount = 1;
          }
      }
    } 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] == ')')) {

        /*
       * Check for parentheses inside first token
       */

        simpleVarName = 0;
        for (i = 0, p = varTokenPtr[1].start; 
           i < varTokenPtr[1].size; i++, p++) {
            if (*p == '(') {
                simpleVarName = 1;
                break;
            }
        }
        if (simpleVarName) {
          int remainingChars;

          /*
           * Check the last token: if it is just ')', do not count
           * it. Otherwise, remove the ')' and flag so that it is
           * restored at the end.
           */

          if (varTokenPtr[n].size == 1) {
            --n;
          } else {
            --varTokenPtr[n].size;
            removedParen = n;
          }

            name = varTokenPtr[1].start;
            nameChars = p - varTokenPtr[1].start;
            elName = p + 1;
            remainingChars = (varTokenPtr[2].start - p) - 1;
            elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;

          if (remainingChars) {
            /*
             * Make a first token with the extra characters in the first 
             * token.
             */

            elemTokenPtr = (Tcl_Token *) ckalloc(n * sizeof(Tcl_Token));
            allocedTokens = 1;
            elemTokenPtr->type = TCL_TOKEN_TEXT;
            elemTokenPtr->start = elName;
            elemTokenPtr->size = remainingChars;
            elemTokenPtr->numComponents = 0;
            elemTokenCount = n;
            
            /*
             * Copy the remaining tokens.
             */
            
            memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]),
                   ((n-1) * sizeof(Tcl_Token)));
          } else {
            /*
             * Use the already available tokens.
             */
            
            elemTokenPtr = &varTokenPtr[2];
            elemTokenCount = n - 1;     
          }
      }
    }

    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*/ (flags & TCL_CREATE_VAR),
                    /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
                envPtr->procPtr);
          if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
            /* we'll push the name */
            localIndex = -1;
          }
      }
      if (localIndex < 0) {
          TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr);
      }

      /*
       * Compile the element script, if any.
       */

      if (elName != NULL) {
          if (elNameChars) {
            code = TclCompileTokens(interp, elemTokenPtr,
                        elemTokenCount, envPtr);
            if (code != TCL_OK) {
                goto done;
            }
          } else {
            TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
          }
      }
    } 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;
      }
    }

    done:
    if (removedParen) {
      ++varTokenPtr[removedParen].size;
    }
    if (allocedTokens) {
        ckfree((char *) elemTokenPtr);
    }
    *localIndexPtr      = localIndex;
    *simpleVarNamePtr   = simpleVarName;
    *isScalarPtr  = (elName == NULL);
    return code;
}

Generated by  Doxygen 1.6.0   Back to index